move new interface to git-annex transfer

This is to avoid breakage when upgrading or downgrading git-annex with a
process running that uses the interface. It's better to keep the
compatability code for a few years than worry about such breakage.

This commit was sponsored by Brett Eisenberg on Patreon.

Annex/TransferrerPool.hs

@@ -1,4 +1,4 @@
-{- A pool of "git-annex transferkeys" processes
+{- A pool of "git-annex transfer" processes
  -
  - Copyright 2013-2020 Joey Hess <id@joeyh.name>
  -
@@ -197,12 +197,12 @@ detectStalls (Just (StallDetection minsz duration)) metervar onstall = go Nothin
 						then onstall
 						else go (Just sofar)
 
-{- Starts a new git-annex transferkeys process, setting up handles
+{- Starts a new git-annex transfer process, setting up handles
  - that will be used to communicate with it. -}
 mkTransferrer :: FilePath -> BatchCommandMaker -> IO Transferrer
 mkTransferrer program batchmaker = do
 	{- It runs as a batch job. -}
-	let (program', params') = batchmaker (program, [Param "transferkeys"])
+	let (program', params') = batchmaker (program, [Param "transfer"])
 	{- It's put into its own group so that the whole group can be
 	 - killed to stop a transfer. -}
 	(Just writeh, Just readh, _, pid) <- createProcess
@@ -243,10 +243,10 @@ readResponse h = do
 	case readMaybe l of
 		Just (TransferOutput so) -> return (Left so)
 		Just (TransferResult r) -> return (Right r)
-		Nothing -> transferKeysProtocolError l
+		Nothing -> transferProtocolError l
 
-transferKeysProtocolError :: String -> a
-transferKeysProtocolError l = error $ "transferkeys protocol error: " ++ show l
+transferProtocolError :: String -> a
+transferProtocolError l = error $ "transfer protocol error: " ++ show l
 
 {- Closing the fds will shut down the transferrer, but only when it's
  - in between transfers. -}

CmdLine/GitAnnex.hs

@@ -35,6 +35,7 @@ import qualified Command.FromKey
 import qualified Command.RegisterUrl
 import qualified Command.SetKey
 import qualified Command.DropKey
+import qualified Command.Transfer
 import qualified Command.TransferKey
 import qualified Command.TransferKeys
 import qualified Command.SetPresentKey
@@ -177,6 +178,7 @@ cmds testoptparser testrunner mkbenchmarkgenerator =
 	, Command.RegisterUrl.cmd
 	, Command.SetKey.cmd
 	, Command.DropKey.cmd
+	, Command.Transfer.cmd
 	, Command.TransferKey.cmd
 	, Command.TransferKeys.cmd
 	, Command.SetPresentKey.cmd

Command/Transfer.hs

@@ -0,0 +1,112 @@
+{- git-annex command
+ -
+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Command.Transfer where
+
+import Command
+import qualified Annex
+import Annex.Content
+import Logs.Location
+import Annex.Transfer
+import qualified Remote
+import Utility.SimpleProtocol (dupIoHandles)
+import qualified Database.Keys
+import Annex.BranchState
+import Types.Messages
+import Annex.TransferrerPool
+
+import Text.Read (readMaybe)
+
+cmd :: Command
+cmd = command "transfer" SectionPlumbing "transfers content"
+	paramNothing (withParams seek)
+
+seek :: CmdParams -> CommandSeek
+seek = withNothing (commandAction start)
+
+start :: CommandStart
+start = do
+	enableInteractiveBranchAccess
+	(readh, writeh) <- liftIO dupIoHandles
+	Annex.setOutput $ SerializedOutput
+		(\v -> hPutStrLn writeh (show (TransferOutput v)) >> hFlush writeh)
+		(readMaybe <$> hGetLine readh)
+	runRequests readh writeh runner
+	stop
+  where
+	runner (TransferRequest AnnexLevel direction _ keydata file) remote
+		| direction == Upload =
+			-- This is called by eg, Annex.Transfer.upload,
+			-- so caller is responsible for doing notification,
+			-- and for retrying.
+			upload' (Remote.uuid remote) key file noRetry
+				(Remote.action . Remote.storeKey remote key file)
+				noNotification
+		| otherwise =
+			-- This is called by eg, Annex.Transfer.download
+			-- so caller is responsible for doing notification
+			-- and for retrying.
+			let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
+				Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p)
+			in download' (Remote.uuid remote) key file noRetry go 
+				noNotification
+	  where
+		key = mkKey (const keydata)
+	runner (TransferRequest AssistantLevel direction _ keydata file) remote
+		| direction == Upload = notifyTransfer direction file $
+			upload' (Remote.uuid remote) key file stdRetry $ \p -> do
+				tryNonAsync (Remote.storeKey remote key file p) >>= \case
+					Left e -> do
+						warning (show e)
+						return False
+					Right () -> do
+						Remote.logStatus remote key InfoPresent
+						return True
+		| otherwise = notifyTransfer direction file $
+			download' (Remote.uuid remote) key file stdRetry $ \p ->
+				getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
+					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case
+						Left e -> do
+							warning (show e)
+							return (False, UnVerified)
+						Right v -> return (True, v)
+					-- Make sure we get the current
+					-- associated files data for the key,
+					-- not old cached data.
+					Database.Keys.closeDb			
+					return r
+	  where
+		key = mkKey (const keydata)
+
+runRequests
+	:: Handle
+	-> Handle
+	-> (TransferRequest -> Remote -> Annex Bool)
+	-> Annex ()
+runRequests readh writeh a = go Nothing Nothing
+  where
+	go lastremoteoruuid lastremote = unlessM (liftIO $ hIsEOF readh) $ do
+		l <- liftIO $ hGetLine readh
+		case readMaybe l of
+			Just tr@(TransferRequest _ _ remoteoruuid _ _) -> do
+				-- Often the same remote will be used
+				-- repeatedly, so cache the last one to
+				-- avoid looking up repeatedly.
+				mremote <- if lastremoteoruuid == Just remoteoruuid
+					then pure lastremote
+					else eitherToMaybe <$> Remote.byName'
+						(either fromUUID id remoteoruuid)
+				case mremote of
+					Just remote -> do
+						sendresult =<< a tr remote
+						go (Just remoteoruuid) mremote
+					Nothing -> transferProtocolError l
+			Nothing -> transferProtocolError l
+
+	sendresult b = liftIO $ do
+		hPutStrLn writeh $ show $ TransferResult b
+		hFlush writeh

Command/TransferKeys.hs

@@ -1,28 +1,31 @@
-{- git-annex command
+{- git-annex command, used internally by assistant in version
+ - 8.20201127 and older and provided only to avoid upgrade breakage.
+ - Remove at some point when such old versions of git-annex are unlikely
+ - to be running any longer.
  -
- - Copyright 2012-2020 Joey Hess <id@joeyh.name>
+ - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+
 module Command.TransferKeys where
 
 import Command
-import qualified Annex
 import Annex.Content
 import Logs.Location
 import Annex.Transfer
 import qualified Remote
 import Utility.SimpleProtocol (dupIoHandles)
+import Git.Types (RemoteName)
 import qualified Database.Keys
 import Annex.BranchState
-import Types.Messages
-import Annex.TransferrerPool
 
-import Text.Read (readMaybe)
+data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
 
 cmd :: Command
-cmd = command "transferkeys" SectionPlumbing "transfers keys"
+cmd = command "transferkeys" SectionPlumbing "transfers keys (deprecated)"
 	paramNothing (withParams seek)
 
 seek :: CmdParams -> CommandSeek
@@ -32,31 +35,10 @@ start :: CommandStart
 start = do
 	enableInteractiveBranchAccess
 	(readh, writeh) <- liftIO dupIoHandles
-	Annex.setOutput $ SerializedOutput
-		(\v -> hPutStrLn writeh (show (TransferOutput v)) >> hFlush writeh)
-		(readMaybe <$> hGetLine readh)
 	runRequests readh writeh runner
 	stop
   where
-	runner (TransferRequest AnnexLevel direction _ keydata file) remote
-		| direction == Upload =
-			-- This is called by eg, Annex.Transfer.upload,
-			-- so caller is responsible for doing notification,
-			-- and for retrying.
-			upload' (Remote.uuid remote) key file noRetry
-				(Remote.action . Remote.storeKey remote key file)
-				noNotification
-		| otherwise =
-			-- This is called by eg, Annex.Transfer.download
-			-- so caller is responsible for doing notification
-			-- and for retrying.
-			let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
-				Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p)
-			in download' (Remote.uuid remote) key file noRetry go 
-				noNotification
-	  where
-		key = mkKey (const keydata)
-	runner (TransferRequest AssistantLevel direction _ keydata file) remote
+	runner (TransferRequest direction remote key file)
 		| direction == Upload = notifyTransfer direction file $
 			upload' (Remote.uuid remote) key file stdRetry $ \p -> do
 				tryNonAsync (Remote.storeKey remote key file p) >>= \case
@@ -79,34 +61,82 @@ start = do
 					-- not old cached data.
 					Database.Keys.closeDb			
 					return r
-	  where
-		key = mkKey (const keydata)
 
 runRequests
 	:: Handle
 	-> Handle
-	-> (TransferRequest -> Remote -> Annex Bool)
+	-> (TransferRequest -> Annex Bool)
 	-> Annex ()
-runRequests readh writeh a = go Nothing Nothing
+runRequests readh writeh a = do
+	liftIO $ hSetBuffering readh NoBuffering
+	go =<< readrequests
   where
-	go lastremoteoruuid lastremote = unlessM (liftIO $ hIsEOF readh) $ do
-		l <- liftIO $ hGetLine readh
-		case readMaybe l of
-			Just tr@(TransferRequest _ _ remoteoruuid _ _) -> do
-				-- Often the same remote will be used
-				-- repeatedly, so cache the last one to
-				-- avoid looking up repeatedly.
-				mremote <- if lastremoteoruuid == Just remoteoruuid
-					then pure lastremote
-					else eitherToMaybe <$> Remote.byName'
-						(either fromUUID id remoteoruuid)
+	go (d:rn:k:f:rest) = do
+		case (deserialize d, deserialize rn, deserialize k, deserialize f) of
+			(Just direction, Just remotename, Just key, Just file) -> do
+				mremote <- Remote.byName' remotename
 				case mremote of
-					Just remote -> do
-						sendresult =<< a tr remote
-						go (Just remoteoruuid) mremote
-					Nothing -> transferKeysProtocolError l
-			Nothing -> transferKeysProtocolError l
+					Left _ -> sendresult False
+					Right remote -> sendresult =<< a
+						(TransferRequest direction remote key file)
+			_ -> sendresult False
+		go rest
+	go [] = noop
+	go [""] = noop
+	go v = error $ "transferkeys protocol error: " ++ show v
 
+	readrequests = liftIO $ split fieldSep <$> hGetContents readh
 	sendresult b = liftIO $ do
-		hPutStrLn writeh $ show $ TransferResult b
+		hPutStrLn writeh $ serialize b
 		hFlush writeh
+
+sendRequest :: Transfer -> TransferInfo -> Handle -> IO ()
+sendRequest t tinfo h = do
+	hPutStr h $ intercalate fieldSep
+		[ serialize (transferDirection t)
+		, maybe (serialize ((fromUUID (transferUUID t)) :: String))
+			(serialize . Remote.name)
+			(transferRemote tinfo)
+		, serialize (transferKey t)
+		, serialize (associatedFile tinfo)
+		, "" -- adds a trailing null
+		]
+	hFlush h
+
+readResponse :: Handle -> IO Bool
+readResponse h = fromMaybe False . deserialize <$> hGetLine h
+
+fieldSep :: String
+fieldSep = "\0"
+
+class TCSerialized a where
+	serialize :: a -> String
+	deserialize :: String -> Maybe a
+
+instance TCSerialized Bool where
+	serialize True = "1"
+	serialize False = "0"
+	deserialize "1" = Just True
+	deserialize "0" = Just False
+	deserialize _ = Nothing
+
+instance TCSerialized Direction where
+	serialize Upload = "u"
+	serialize Download = "d"
+	deserialize "u" = Just Upload
+	deserialize "d" = Just Download
+	deserialize _ = Nothing
+
+instance TCSerialized AssociatedFile where
+	serialize (AssociatedFile (Just f)) = fromRawFilePath f
+	serialize (AssociatedFile Nothing) = ""
+	deserialize "" = Just (AssociatedFile Nothing)
+	deserialize f = Just (AssociatedFile (Just (toRawFilePath f)))
+
+instance TCSerialized RemoteName where
+	serialize n = n
+	deserialize n = Just n
+
+instance TCSerialized Key where
+	serialize = serializeKey
+	deserialize = deserializeKey

Types/TransferrerPool.hs

@@ -1,4 +1,4 @@
-{- A pool of "git-annex transferkeys" processes available for use
+{- A pool of "git-annex transfer" processes available for use
  -
  - Copyright 2013-2020 Joey Hess <id@joeyh.name>
  -

doc/git-annex-transfer.mdwn

@@ -0,0 +1,24 @@
+# NAME
+
+git-annex transfer - transfers content
+
+# SYNOPSIS
+
+git annex transfer
+
+# DESCRIPTION
+
+This plumbing-level command is used to transfer data.
+It is a long-running process, which is fed instructions about
+what to transfer using an internal stdio protocol, which is
+intentionally not documented (as it may change at any time).
+
+# SEE ALSO
+
+[[git-annex]](1)
+
+# AUTHOR
+
+Joey Hess <id@joeyh.name>
+
+Warning: Automatically converted into a man page by mdwn2man. Edit with care.

doc/git-annex-transferkeys.mdwn

@@ -1,6 +1,6 @@
 # NAME
 
-git-annex transferkeys - transfers keys
+git-annex transferkeys - transfers keys (deprecated)
 
 # SYNOPSIS
 
@@ -8,7 +8,10 @@ git annex transferkeys
 
 # DESCRIPTION
 
-This plumbing-level command is used to transfer data.
+This plumbing-level command is used to transfer data, by the assistant
+in git-annex version 8.20201127 and older. It is still included only
+to prevent breakage during upgrades.
+
 It is a long-running process, which is fed instructions about the keys
 to transfer using an internal stdio protocol, which is
 intentionally not documented (as it may change at any time).

doc/git-annex.mdwn

@@ -631,9 +631,15 @@ content from the key-value store.
   
   See [[git-annex-transferkey]](1) for details.
 
+* `transfer`
+  
+  Used internally by git-annex to transfer content.
+
+  See [[git-annex-transfer]](1) for details.
+
 * `transferkeys`
   
-  Used internally by the assistant.
+  Used internally by old versions of the assistant.
 
   See [[git-annex-transferkey]](1) for details.
 

git-annex.cabal

@@ -794,6 +794,7 @@ Executable git-annex
     Command.Test
     Command.TestRemote
     Command.TransferInfo
+    Command.Transfer
     Command.TransferKey
     Command.TransferKeys
     Command.Trust