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.

Annex/TransferrerPool.hs

@@ -14,7 +14,6 @@ import qualified Annex
 import Types.TransferrerPool
 import Types.Transferrer
 import Types.Transfer
-import Types.Key
 import qualified Types.Remote as Remote
 import Types.StallDetection
 import Types.Messages
@@ -24,12 +23,12 @@ import Utility.Batch
 import Utility.Metered
 import Utility.HumanTime
 import Utility.ThreadScheduler
+import qualified Utility.SimpleProtocol as Proto
 
 import Control.Concurrent
 import Control.Concurrent.Async
 import Control.Concurrent.STM hiding (check)
 import Control.Monad.IO.Class (MonadIO)
-import Text.Read (readMaybe)
 import Data.Time.Clock.POSIX
 import System.Log.Logger (debugM)
 
@@ -91,6 +90,9 @@ checkTransferrerPoolItem program batchmaker i = case i of
 		t <- mkTransferrer program batchmaker
 		return (TransferrerPoolItem (Just t) check, t)
 
+data TransferRequestLevel = AnnexLevel | AssistantLevel
+	deriving (Show)
+
 {- Requests that a Transferrer perform a Transfer, and waits for it to
  - finish.
  -
@@ -212,17 +214,28 @@ mkTransferrer program batchmaker = do
 -- | Send a request to perform a transfer.
 sendRequest :: TransferRequestLevel -> Transfer -> Maybe Remote -> AssociatedFile -> Handle -> IO ()
 sendRequest level t mremote afile h = do
-	let l = show $ TransferRequest level
-		(transferDirection t)
-		(maybe (Left (transferUUID t)) (Right . Remote.name) mremote)
-		(keyData (transferKey t))
-		afile
+	let tr = maybe
+		(TransferRemoteUUID (transferUUID t))
+		(TransferRemoteName . Remote.name)
+		mremote
+	let f = case (level, transferDirection t) of
+		(AnnexLevel, Upload) -> UploadRequest
+		(AnnexLevel, Download) -> DownloadRequest
+		(AssistantLevel, Upload) -> AssistantUploadRequest
+		(AssistantLevel, Download) -> AssistantDownloadRequest
+	let r = f tr (transferKey t) (TransferAssociatedFile afile)
+	let l = unwords $ Proto.formatMessage r
 	debugM "transfer" ("> " ++ l)
 	hPutStrLn h l
 	hFlush h
 
 sendSerializedOutputResponse :: Handle -> SerializedOutputResponse -> IO ()
-sendSerializedOutputResponse h sor = hPutStrLn h $ show sor
+sendSerializedOutputResponse h sor = do
+	let l = unwords $ Proto.formatMessage $
+		TransferSerializedOutputResponse sor
+	debugM "transfer" ("> " ++ show l)
+	hPutStrLn h l
+	hFlush h
 
 -- | Read a response to a transfer requests.
 --
@@ -232,13 +245,13 @@ readResponse :: Handle -> IO (Either SerializedOutput Bool)
 readResponse h = do
 	l <- liftIO $ hGetLine h
 	debugM "transfer" ("< " ++ l)
-	case readMaybe l of
+	case Proto.parseMessage l of
 		Just (TransferOutput so) -> return (Left so)
 		Just (TransferResult r) -> return (Right r)
 		Nothing -> transferrerProtocolError l
 
 transferrerProtocolError :: String -> a
-transferrerProtocolError l = error $ "transferrer protocol error: " ++ show l
+transferrerProtocolError l = giveup $ "transferrer protocol error: " ++ show l
 
 {- Closing the fds will shut down the transferrer, but only when it's
  - in between transfers. -}