rclone special remote

Added rclone special remote, which can be used without needing to install the git-annex-remote-rclone program. This needs a new version of rclone, which supports "rclone gitannex". This is implemented as a variant of an external special remote, that runs "rclone gitannex" instead of the usual git-annex-remote- command. Parameterized Remote.External to support that. Sponsored-by: Luke T. Shumaker on Patreon
2024-04-17 15:19:42 -04:00 · 2024-04-17 15:19:42 -04:00 · d372553540
commit d372553540
parent 5c542c0382
10 changed files with 114 additions and 48 deletions
--- a/3
+++ b/3
@ -15,6 +15,9 @@ git-annex (10.20240228) UNRELEASED; urgency=medium
    versions of MinTTY.
  * sync, assist, import: Allow -m option to be specified multiple
    times, to provide additional paragraphs for the commit message.
+  * Added rclone special remote, which can be used without needing
+    to install the git-annex-remote-rclone program. This needs
+    a new version of rclone, which supports "rclone gitannex".

 -- Joey Hess <id@joeyh.name>  Tue, 27 Feb 2024 13:07:10 -0400

--- a/Remote/External.hs
+++ b/Remote/External.hs
@ -9,7 +9,7 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE RankNTypes #-}

-module Remote.External (remote) where
+module Remote.External where

 import Remote.External.Types
 import Remote.External.AsyncExtension
@ -48,10 +48,10 @@ remote :: RemoteType
 remote = specialRemoteType $ RemoteType
 	{ typename = "external"
 	, enumerate = const (findSpecialRemotes "externaltype")
-	, generate = gen
-	, configParser = remoteConfigParser
-	, setup = externalSetup
-	, exportSupported = checkExportSupported
+	, generate = gen remote Nothing
+	, configParser = remoteConfigParser Nothing
+	, setup = externalSetup Nothing Nothing
+	, exportSupported = checkExportSupported Nothing
 	, importSupported = importUnsupported
 	, thirdPartyPopulated = False
 	}
@ -62,15 +62,15 @@ externaltypeField = Accepted "externaltype"
 readonlyField :: RemoteConfigField
 readonlyField = Accepted "readonly"

-gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
-gen r u rc gc rs
+gen :: RemoteType -> Maybe ExternalProgram -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
+gen rt externalprogram r u rc gc rs
 	-- readonly mode only downloads urls; does not use external program
-	| externaltype == "readonly" = do
+	| externalprogram' == ExternalType "readonly" = do
 		c <- parsedRemoteConfig remote rc
 		cst <- remoteCost gc c expensiveRemoteCost
 		let rmt = mk c cst (pure GloballyAvailable)
 			Nothing
-			(externalInfo externaltype)
+			(externalInfo externalprogram')
 			Nothing
 			Nothing
 			exportUnsupported
@ -83,7 +83,7 @@ gen r u rc gc rs
 			rmt
 	| otherwise = do
 		c <- parsedRemoteConfig remote rc
-		external <- newExternal externaltype (Just u) c (Just gc)
+		external <- newExternal externalprogram' (Just u) c (Just gc)
 			(Git.remoteName r) (Just rs)
 		Annex.addCleanupAction (RemoteCleanup u) $ stopExternal external
 		cst <- getCost external r gc c
@ -150,19 +150,27 @@ gen r u rc gc rs
 			, appendonly = False
 			, untrustworthy = False
 			, availability = avail
-			, remotetype = remote 
+			, remotetype = rt 
 				{ exportSupported = cheapexportsupported }
-			, mkUnavailable = gen r u rc
-				(gc { remoteAnnexExternalType = Just "!dne!" }) rs
+			, mkUnavailable =
+				let dneprogram = case externalprogram of
+					Just (ExternalCommand _ _) -> Just (ExternalType "!dne!")
+					_ -> Nothing
+				    dnegc = gc { remoteAnnexExternalType = Just "!dne!" }
+				in gen rt dneprogram r u rc dnegc rs
 			, getInfo = togetinfo
 			, claimUrl = toclaimurl
 			, checkUrl = tocheckurl
 			, remoteStateHandle = rs
 			}
-	externaltype = fromMaybe (giveup "missing externaltype") (remoteAnnexExternalType gc)
+	externalprogram' = case externalprogram of
+		Just p -> p
+		Nothing -> ExternalType $ 
+			fromMaybe (giveup "missing externaltype")
+				(remoteAnnexExternalType gc)

-externalSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-externalSetup _ mu _ c gc = do
+externalSetup :: Maybe ExternalProgram -> Maybe (String, String) -> SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+externalSetup externalprogram setgitconfig _ mu _ c gc = do
 	u <- maybe (liftIO genUUID) return mu
 	pc <- either giveup return $ parseRemoteConfig c lenientRemoteConfigParser
 	let readonlyconfig = getRemoteConfigValue readonlyField pc == Just True
@ -182,7 +190,8 @@ externalSetup _ mu _ c gc = do
 			return c'
 		else do
 			pc' <- either giveup return $ parseRemoteConfig c' lenientRemoteConfigParser
-			external <- newExternal externaltype (Just u) pc' (Just gc) Nothing Nothing
+			let p = fromMaybe (ExternalType externaltype) externalprogram
+			external <- newExternal p (Just u) pc' (Just gc) Nothing Nothing
 			-- Now that we have an external, ask it to LISTCONFIGS, 
 			-- and re-parse the RemoteConfig strictly, so we can
 			-- error out if the user provided an unexpected config.
@ -200,17 +209,20 @@ externalSetup _ mu _ c gc = do
 				liftIO . atomically . readTMVar . externalConfigChanges
 			return (changes c')

-	gitConfigSpecialRemote u c'' [("externaltype", externaltype)]
+	gitConfigSpecialRemote u c''
+		[ fromMaybe ("externaltype", externaltype) setgitconfig ]
 	return (M.delete readonlyField c'', u)

-checkExportSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool
-checkExportSupported c gc = do
+checkExportSupported :: Maybe ExternalProgram -> ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool
+checkExportSupported Nothing c gc = do
 	let externaltype = fromMaybe (giveup "Specify externaltype=") $
 		remoteAnnexExternalType gc <|> getRemoteConfigValue externaltypeField c
 	if externaltype == "readonly"
 		then return False
-		else checkExportSupported' 
-			=<< newExternal externaltype Nothing c (Just gc) Nothing Nothing
+		else checkExportSupported (Just (ExternalType externaltype)) c gc
+checkExportSupported (Just externalprogram) c gc = 
+	checkExportSupported' 
+		=<< newExternal externalprogram Nothing c (Just gc) Nothing Nothing

 checkExportSupported' :: External -> Annex Bool
 checkExportSupported' external = go `catchNonAsync` (const (return False))
@ -658,7 +670,7 @@ startExternal' external = do
 		n <- succ <$> readTVar (externalLastPid external)
 		writeTVar (externalLastPid external) n
 		return n
-	AddonProcess.startExternalAddonProcess basecmd [] pid >>= \case
+	AddonProcess.startExternalAddonProcess externalcmd externalparams pid >>= \case
 		Left (AddonProcess.ProgramFailure err) -> do
 			unusable err
 		Left (AddonProcess.ProgramNotInstalled err) ->
@ -667,7 +679,7 @@ startExternal' external = do
 					[ err
 					, "This remote has annex-readonly=true, and previous versions of"
 					, "git-annex would try to download from it without"
-					, "installing " ++ basecmd ++ ". If you want that, you need to set:"
+					, "installing " ++ externalcmd ++ ". If you want that, you need to set:"
 					, "git config remote." ++ rname ++ ".annex-externaltype readonly"
 					]
 				_ -> unusable err
@ -686,7 +698,9 @@ startExternal' external = do
 			extensions <- startproto st
 			return (st, extensions)
  where
-	basecmd = "git-annex-remote-" ++ externalType external
+	(externalcmd, externalparams) = case externalProgram external of
+		ExternalType t -> ("git-annex-remote-" ++ t, [])
+		ExternalCommand c ps -> (c, ps)
 	startproto st = do
 		receiveMessage st external
 			(const Nothing)
@ -707,13 +721,13 @@ startExternal' external = do
 		case filter (`notElem` fromExtensionList supportedExtensionList) (fromExtensionList exwanted) of
 			[] -> return exwanted
 			exrest -> unusable $ unwords $
-				[ basecmd
+				[ externalcmd
 				, "requested extensions that this version of git-annex does not support:"
 				] ++ exrest

 	unusable msg = do
 		warning (UnquotedString msg)
-		giveup ("unable to use external special remote " ++ basecmd)
+		giveup ("unable to use external special remote " ++ externalcmd)

 stopExternal :: External -> Annex ()
 stopExternal external = liftIO $ do
@ -825,12 +839,13 @@ getWebUrls key = filter supported <$> getUrls key
  where
 	supported u = snd (getDownloader u) == WebDownloader
 			
-externalInfo :: ExternalType -> Annex [(String, String)]
-externalInfo et = return [("externaltype", et)]
+externalInfo :: ExternalProgram -> Annex [(String, String)]
+externalInfo (ExternalType et) = return [("externaltype", et)]
+externalInfo (ExternalCommand _ _) = return []

 getInfoM :: External -> Annex [(String, String)]
 getInfoM external = (++)
-	<$> externalInfo (externalType external)
+	<$> externalInfo (externalProgram external)
 	<*> handleRequest external GETINFO Nothing (collect [])
  where
 	collect l req = case req of
@ -886,8 +901,8 @@ listConfigs external = handleRequest external LISTCONFIGS Nothing (collect [])
 		UNSUPPORTED_REQUEST -> result Nothing
 		_ -> Nothing

-remoteConfigParser :: RemoteConfig -> Annex RemoteConfigParser
-remoteConfigParser c
+remoteConfigParser :: Maybe ExternalProgram -> RemoteConfig -> Annex RemoteConfigParser
+remoteConfigParser externalprogram c
 	-- No need to start the external when there is no config to parse,
 	-- or when everything in the config was already accepted; in those
 	-- cases the lenient parser will do the same thing as the strict
@ -899,7 +914,8 @@ remoteConfigParser c
 			(Nothing, _) -> return lenientRemoteConfigParser
 			(_, Just True) -> return lenientRemoteConfigParser
 			(Just externaltype, _) -> do
-				external <- newExternal externaltype Nothing pc Nothing Nothing Nothing
+				let p = fromMaybe (ExternalType externaltype) externalprogram
+				external <- newExternal p Nothing pc Nothing Nothing Nothing
 				strictRemoteConfigParser external
  where
 	isproposed (Accepted _) = False
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@ -1,6 +1,6 @@
 {- External special remote data types.
 -
- - Copyright 2013-2020 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2024 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}
@ -12,7 +12,7 @@
 module Remote.External.Types (
 	External(..),
 	newExternal,
-	ExternalType,
+	ExternalProgram(..),
 	ExternalState(..),
 	PrepareStatus(..),
 	ExtensionList(..),
@ -64,7 +64,7 @@ import Text.Read
 import qualified Data.ByteString.Short as S (fromShort)

 data External = External
-	{ externalType :: ExternalType
+	{ externalProgram :: ExternalProgram
 	, externalUUID :: Maybe UUID
 	, externalState :: TVar [ExternalState]
 	-- ^ Contains states for external special remote processes
@ -77,9 +77,9 @@ data External = External
 	, externalAsync :: TMVar ExternalAsync
 	}

-newExternal :: ExternalType -> Maybe UUID -> ParsedRemoteConfig -> Maybe RemoteGitConfig -> Maybe RemoteName -> Maybe RemoteStateHandle -> Annex External
-newExternal externaltype u c gc rn rs = liftIO $ External
-	<$> pure externaltype
+newExternal :: ExternalProgram -> Maybe UUID -> ParsedRemoteConfig -> Maybe RemoteGitConfig -> Maybe RemoteName -> Maybe RemoteStateHandle -> Annex External
+newExternal p u c gc rn rs = liftIO $ External
+	<$> pure p
 	<*> pure u
 	<*> atomically (newTVar [])
 	<*> atomically (newTVar 0)
@ -89,7 +89,12 @@ newExternal externaltype u c gc rn rs = liftIO $ External
 	<*> pure rs
 	<*> atomically (newTMVar UncheckedExternalAsync)

-type ExternalType = String
+data ExternalProgram
+	= ExternalType String
+	-- ^ "git-annex-remote-" is prepended to this to get the program
+	| ExternalCommand String [CommandParam]
+	-- ^ to use a program with a different name, and parameters
+	deriving (Show, Eq)

 data ExternalState = ExternalState
 	{ externalSend :: forall t. (Proto.Sendable t, ToAsyncWrapped t) => t -> IO ()
--- a/Remote/List.hs
+++ b/Remote/List.hs
@ -37,6 +37,7 @@ import qualified Remote.Ddar
 import qualified Remote.GitLFS
 import qualified Remote.HttpAlso
 import qualified Remote.Borg
+import qualified Remote.Rclone
 import qualified Remote.Hook
 import qualified Remote.External

@ -59,6 +60,7 @@ remoteTypes = map adjustExportImportRemoteType
 	, Remote.GitLFS.remote
 	, Remote.HttpAlso.remote
 	, Remote.Borg.remote
+	, Remote.Rclone.remote
 	, Remote.Hook.remote
 	, Remote.External.remote
 	]
--- a/Remote/Rclone.hs
+++ b/Remote/Rclone.hs
@ -0,0 +1,31 @@
+{- Rclone special remote, using "rclone gitannex"
+ -
+ - Copyright 2024 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Remote.Rclone (remote) where
+
+import Types
+import Types.Remote
+import Remote.Helper.Special
+import Remote.Helper.ExportImport
+import Utility.SafeCommand
+import qualified Remote.External as External
+import Remote.External.Types
+
+remote :: RemoteType
+remote = specialRemoteType $ RemoteType
+	{ typename = "rclone"
+	, enumerate = const (findSpecialRemotes "rclone")
+	, generate = External.gen remote p
+	, configParser = External.remoteConfigParser p
+	, setup = External.externalSetup p setgitconfig 
+	, exportSupported = External.checkExportSupported p
+	, importSupported = importUnsupported
+	, thirdPartyPopulated = False
+	}
+  where
+	p = Just $ ExternalCommand "rclone" [Param "gitannex"]
+	setgitconfig = Just ("rclone", "true")
--- a/doc/git-annex.mdwn
+++ b/doc/git-annex.mdwn
@ -1794,6 +1794,11 @@ Remotes are configured using these settings in `.git/config`.
  Used to identify Amazon Glacier special remotes.
  Normally this is automatically set up by `git annex initremote`.

+* `remote.<name>.annex-rclone`
+
+  Used to identify rclone special remotes.
+  Normally this is automatically set up by `git annex initremote`.
+
 * `remote.<name>.annex-web`

  Used to identify web special remotes.
@ -1832,7 +1837,7 @@ Remotes are configured using these settings in `.git/config`.

 * `remote.<name>.annex-externaltype`

-  Used external special remotes to record the type of the remote.
+  Used by external special remotes to record the type of the remote.

  Eg, if this is set to "foo", git-annex will run a "git-annex-remote-foo"
  program to communicate with the external special remote.
--- a/doc/special_remotes.mdwn
+++ b/doc/special_remotes.mdwn
@ -26,6 +26,7 @@ the git history is not stored in them.
 * [[git]]
 * [[httpalso]]
 * [[borg]]
+* [[rclone]]

 The above special remotes are built into git-annex, and can be used
 to tie git-annex into many cloud services.
--- a/doc/special_remotes/rclone.mdwn
+++ b/doc/special_remotes/rclone.mdwn
@ -26,12 +26,12 @@ the time of writing, this includes the following services:

 That list is regularly expanding. 

-git-annex supports all of those through
-the use of the [rclone special remote](https://github.com/DanielDent/git-annex-remote-rclone).
+There are two ways to use rclone as a git-annex special remote.

-Alternatively, rclone recently gained support for being used as a special
-remote on its own, without needing installation of the above program.
-For documentation on using rclone that way, see the output of
-`rclone gitannex -h` or [here](//github.com/rclone/rclone/blob/master/cmd/gitannex/gitannex.md).
+1. Install [git-annex-remote-rclone](https://github.com/DanielDent/git-annex-remote-rclone).
+   This will work with any versions of rclone and git-annex.
+2. With a recent version of rclone and git-annex, it is not necessary to
+   install anything else, just use `git-annex initremote type=rclone ...`

-See their documentation for more concrete examples.
+   For documentation on using rclone that way, see the output of
+   `rclone gitannex -h` or [here](https://github.com/rclone/rclone/blob/master/cmd/gitannex/gitannex.md).
--- a/doc/todo/external_special_remotes_not_using_git-annex-remote_in_name.mdwn
+++ b/doc/todo/external_special_remotes_not_using_git-annex-remote_in_name.mdwn
@ -44,3 +44,5 @@ a wrapper around the external special remote, that makes it use
 > I feel that the simplicity of the type=rclone config will pay off in the
 > long term, vs short term complication for probably a small subset of users
 > who somehow can upgrade rclone but can't upgrade git-annex. --[[Joey]]
+
+> > [[done]] 
--- a/git-annex.cabal
+++ b/git-annex.cabal
@ -900,6 +900,7 @@ Executable git-annex
    Remote.List
    Remote.List.Util
    Remote.P2P
+    Remote.Rclone
    Remote.Rsync
    Remote.Rsync.RsyncUrl
    Remote.S3