new protocol for transferkeys, with message serialization

Necessarily threw out the old protocol, so if an old git-annex assistant
is running, and starts a transferkeys from the new git-annex, it would
fail. But, that seems unlikely; the assistant starts up transferkeys
processes and then keeps them running. Still, may need to test that
scenario.

The new protocol is simple read/show and looks like this:

TransferRequest Download (Right "origin") (Key {keyName = "f8f8766a836fb6120abf4d5328ce8761404e437529e997aaa0363bdd4fecd7bb", keyVariety = SHA2Key (HashSize 256) (HasExt True), keySize = Just 30, keyMtime = Nothing, keyChunkSize = Nothing, keyChunkNum = Nothing}) (AssociatedFile (Just "foo"))
TransferOutput (ProgressMeter (Just 30) (MeterState {meterBytesProcessed = BytesProcessed 0, meterTimeStamp = 1.6070268727892535e9}) (MeterState {meterBytesProcessed = BytesProcessed 30, meterTimeStamp = 1.6070268728043e9}))
TransferOutput (OutputMessage "(checksum...) ")
TransferResult True

Granted, this is not optimally fast, but it seems good enough, and is
probably nearly as fast as the old protocol anyhow.

emitSerializedOutput for ProgressMeter is not yet implemented. It needs
to somehow start or update a progress meter. There may need to be a new
message that allocates a progress meter, and then have ProgressMeter
update it.

This commit was sponsored by Ethan Aubin

Command/TransferKeys.hs

@@ -1,15 +1,14 @@
-{- git-annex command, used internally by assistant
+{- git-annex command
  -
- - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2020 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
@@ -18,8 +17,19 @@ import Utility.SimpleProtocol (dupIoHandles)
 import Git.Types (RemoteName)
 import qualified Database.Keys
 import Annex.BranchState
+import Types.Messages
+import Types.Key
+import Messages.Internal
 
-data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
+import Text.Read (readMaybe)
+
+data TransferRequest = TransferRequest Direction (Either UUID RemoteName) KeyData AssociatedFile
+	deriving (Show, Read)
+
+data TransferResponse
+	= TransferOutput SerializedOutput
+	| TransferResult Bool
+	deriving (Show, Read)
 
 cmd :: Command
 cmd = command "transferkeys" SectionPlumbing "transfers keys"
@@ -32,10 +42,12 @@ start :: CommandStart
 start = do
 	enableInteractiveBranchAccess
 	(readh, writeh) <- liftIO dupIoHandles
+	Annex.setOutput $ SerializedOutput $
+		hPutStrLn writeh . show . TransferOutput
 	runRequests readh writeh runner
 	stop
   where
-	runner (TransferRequest direction remote key file)
+	runner (TransferRequest 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
@@ -58,82 +70,58 @@ start = do
 					-- not old cached data.
 					Database.Keys.closeDb			
 					return r
+	  where
+		key = mkKey (const keydata)
 
 runRequests
 	:: Handle
 	-> Handle
-	-> (TransferRequest -> Annex Bool)
+	-> (TransferRequest -> Remote -> Annex Bool)
 	-> Annex ()
-runRequests readh writeh a = do
-	liftIO $ hSetBuffering readh NoBuffering
-	go =<< readrequests
+runRequests readh writeh a = go Nothing Nothing
   where
-	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
+	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
-					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
+					Just remote -> do
+						sendresult =<< a tr remote
+						go (Just remoteoruuid) mremote
+					Nothing -> protocolError l
+			Nothing -> protocolError l
 
-	readrequests = liftIO $ split fieldSep <$> hGetContents readh
 	sendresult b = liftIO $ do
-		hPutStrLn writeh $ serialize b
+		hPutStrLn writeh $ show $ TransferResult 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
+sendRequest t tinfo h = hPutStrLn h $ show $ TransferRequest
+	(transferDirection t)
+	(maybe (Left (transferUUID t)) (Right . Remote.name) (transferRemote tinfo))
+	(keyData (transferKey t))
+	(associatedFile tinfo)
 
-readResponse :: Handle -> IO Bool
-readResponse h = fromMaybe False . deserialize <$> hGetLine h
+-- | Read a response from this command.
+--
+-- Each TransferOutput line that is read before the final TransferResult
+-- will be output.
+readResponse :: Handle -> Annex Bool
+readResponse h = do
+	l <- liftIO $ hGetLine h
+	case readMaybe l of
+		Just (TransferOutput so) -> do
+			emitSerializedOutput so
+			readResponse h
+		Just (TransferResult r) -> return r
+		Nothing -> protocolError l
 
-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
+protocolError :: String -> a
+protocolError l = error $ "transferkeys protocol error: " ++ show l