custom protocol for transferrer

Rather than using Read/Show, which would force me to preserve data types
into the future.

I considered just deriving json and sending that, but I don't much like
deriving json with data types that have named constructors (like Key
does) because again it locks in data type details.

So instead, used SimpleProtocol, with a fairly complex and unreadable
protocol. But it is as efficient as the p2p protocol at least, and as
future proof.

(Writing my own custom json instances would have worked but I thought
of it too late and don't want to do all the work twice. The only real
benefit might be that aeson could be faster.)

Note that, when a new protocol request type is added later, git-annex
trying to use it will cause the git-annex transferrer to display a
protocol error message. That seems ok; it would only happen if a new
git-annex found an old version of itself in PATH or the program
file. So it's unlikely, and all it can do anyway is display an error.
(The error message could perhaps be improved..)

This commit was sponsored by Jack Hill on Patreon.

Command/Transferrer.hs

@@ -19,8 +19,7 @@ import Annex.BranchState
 import Types.Messages
 import Annex.TransferrerPool
 import Types.Transferrer
-
-import Text.Read (readMaybe)
+import qualified Utility.SimpleProtocol as Proto
 
 cmd :: Command
 cmd = command "transferrer" SectionPlumbing "transfers content"
@@ -33,32 +32,36 @@ start :: CommandStart
 start = do
 	enableInteractiveBranchAccess
 	(readh, writeh) <- liftIO dupIoHandles
-	Annex.setOutput $ SerializedOutput
-		(\v -> hPutStrLn writeh (show (TransferOutput v)) >> hFlush writeh)
-		(readMaybe <$> hGetLine readh)
+	let outputwriter v = do
+		hPutStrLn writeh $
+			unwords $ Proto.formatMessage $ TransferOutput v
+		hFlush writeh
+	let outputresponsereader = do
+		l <- hGetLine readh
+		return $ case Proto.parseMessage l of
+			Just (TransferSerializedOutputResponse r) -> Just r
+			Nothing -> Nothing
+	Annex.setOutput $ SerializedOutput outputwriter outputresponsereader
 	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 $
+	runner (UploadRequest _ key (TransferAssociatedFile file)) remote =
+		-- 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
+	runner (DownloadRequest _ key (TransferAssociatedFile file)) remote =
+		-- 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
+	runner (AssistantUploadRequest _ key (TransferAssociatedFile file)) remote =
+		notifyTransfer Upload file $
 			upload' (Remote.uuid remote) key file stdRetry $ \p -> do
 				tryNonAsync (Remote.storeKey remote key file p) >>= \case
 					Left e -> do
@@ -67,7 +70,8 @@ start = do
 					Right () -> do
 						Remote.logStatus remote key InfoPresent
 						return True
-		| otherwise = notifyTransfer direction file $
+	runner (AssistantDownloadRequest _ key (TransferAssociatedFile file)) remote =
+		notifyTransfer Download 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
@@ -80,8 +84,6 @@ start = do
 					-- not old cached data.
 					Database.Keys.closeDb			
 					return r
-	  where
-		key = mkKey (const keydata)
 
 runRequests
 	:: Handle
@@ -92,15 +94,19 @@ 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
+		case Proto.parseMessage l of
+			Just tr -> do
+				let remoteoruuid = transferRequestRemote tr
 				-- 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)
+					else case remoteoruuid of
+						TransferRemoteName n ->
+							eitherToMaybe <$> Remote.byName' n
+						TransferRemoteUUID u -> 
+							Remote.byUUID u
 				case mremote of
 					Just remote -> do
 						sendresult =<< a tr remote
@@ -109,5 +115,6 @@ runRequests readh writeh a = go Nothing Nothing
 			Nothing -> transferrerProtocolError l
 
 	sendresult b = liftIO $ do
-		hPutStrLn writeh $ show $ TransferResult b
+		hPutStrLn writeh $
+			unwords $ Proto.formatMessage $ TransferResult b
 		hFlush writeh