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.

diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs
index d08b7f7ee1b63d0881fa9f4c1df8111e9dae2207..ba2044e2fb42b382f044d64eee6c697d2772d7e0 100644 (file)
--- a/Annex/Transfer.hs
+++ b/Annex/Transfer.hs
@@ -34,7 +34,6 @@ import Utility.Metered
 import Utility.ThreadScheduler
 import Annex.LockPool
 import Types.Key
-import Types.Transferrer
 import qualified Types.Remote as Remote
 import Types.Concurrency
 import Annex.Concurrent.Utility

diff --git a/Annex/TransferrerPool.hs b/Annex/TransferrerPool.hs
index 81231b3f8a5c4b291c19f2223dac402fcf920e5b..2d2aceebc5750795ae591449cad246b6275ba702 100644 (file)
--- a/Annex/TransferrerPool.hs
+++ b/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. -}

diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs
index fccef96f3012e8cbcd40b8758dcbcf7dcfd764e8..ee3e17e280ee1c9b8e00f51d66d4e628e797fd84 100644 (file)
--- a/Assistant/TransferSlots.hs
+++ b/Assistant/TransferSlots.hs
@@ -26,7 +26,6 @@ import Assistant.Commits
 import Assistant.Drop
 import Annex.Transfer (stallDetection)
 import Types.Transfer
-import Types.Transferrer
 import Logs.Transfer
 import Logs.Location
 import qualified Git

diff --git a/Command/Transferrer.hs b/Command/Transferrer.hs
index 88804ec0d6ae2026aff7edbf9e52f2d654673f5e..5222011c9506d18a638c37c27bafd528711d98f9 100644 (file)
--- a/Command/Transferrer.hs
+++ b/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

diff --git a/Types/Messages.hs b/Types/Messages.hs
index 80fc176c45370ee48e2be0707c10bd6a603f5cea..16d1d249930dd945ff3635067113a8061ab62a67 100644 (file)
--- a/Types/Messages.hs
+++ b/Types/Messages.hs
@@ -77,8 +77,8 @@ data SerializedOutput
        | JSONObject L.ByteString
        -- ^ This is always sent, it's up to the consumer to decide if it
        -- wants to display JSON, or human-readable messages.
-       deriving (Show, Read)
+       deriving (Show)
 
 data SerializedOutputResponse
        = ReadyPrompt
-       deriving (Eq, Show, Read)
+       deriving (Eq, Show)

diff --git a/Types/Transferrer.hs b/Types/Transferrer.hs
index 08e48227ebecbe8667348b0a288e75313ec22068..f4b38e7c754a1a07e61a7207f1bedc5675ed438a 100644 (file)
--- a/Types/Transferrer.hs
+++ b/Types/Transferrer.hs
@@ -8,17 +8,140 @@
 module Types.Transferrer where
 
 import Annex.Common
-import Types.Transfer
 import Types.Messages
 import Git.Types (RemoteName)
+import qualified Utility.SimpleProtocol as Proto
+import Utility.Format
 
-data TransferRequest = TransferRequest TransferRequestLevel Direction (Either UUID RemoteName) KeyData AssociatedFile
-       deriving (Show, Read)
+import Data.Char
 
-data TransferRequestLevel = AnnexLevel | AssistantLevel
-       deriving (Show, Read)
+-- Sent to start a transfer.
+data TransferRequest
+       = UploadRequest TransferRemote Key TransferAssociatedFile
+       | DownloadRequest TransferRemote Key TransferAssociatedFile
+       | AssistantUploadRequest TransferRemote Key TransferAssociatedFile
+       | AssistantDownloadRequest TransferRemote Key TransferAssociatedFile
+       deriving (Show)
+
+transferRequestRemote :: TransferRequest -> TransferRemote
+transferRequestRemote (UploadRequest r _ _) = r
+transferRequestRemote (DownloadRequest r _ _) = r
+transferRequestRemote (AssistantUploadRequest r _ _) = r
+transferRequestRemote (AssistantDownloadRequest r _ _) = r
+
+data TransferRemote
+       = TransferRemoteUUID UUID
+       | TransferRemoteName RemoteName
+       deriving (Show, Eq)
+
+newtype TransferAssociatedFile = TransferAssociatedFile AssociatedFile
+       deriving (Show)
 
 data TransferResponse
        = TransferOutput SerializedOutput
+       -- ^ any number may be sent before TransferResult
        | TransferResult Bool
-       deriving (Show, Read)
+       deriving (Show)
+
+data TransferSerializedOutputResponse = TransferSerializedOutputResponse SerializedOutputResponse
+       deriving (Show)
+
+instance Proto.Sendable TransferRequest where
+       formatMessage (UploadRequest r kd af) =
+               [ "u"
+               , Proto.serialize r
+               , Proto.serialize kd
+               , Proto.serialize af
+               ]
+       formatMessage (DownloadRequest r kd af) =
+               [ "d"
+               , Proto.serialize r
+               , Proto.serialize kd
+               , Proto.serialize af
+               ]
+       formatMessage (AssistantUploadRequest r kd af) =
+               [ "au"
+               , Proto.serialize r
+               , Proto.serialize kd
+               , Proto.serialize af
+               ]
+       formatMessage (AssistantDownloadRequest r kd af) =
+               [ "ad"
+               , Proto.serialize r
+               , Proto.serialize kd
+               , Proto.serialize af
+               ]
+
+instance Proto.Receivable TransferRequest where
+       parseCommand "u" = Proto.parse3 UploadRequest
+       parseCommand "d" = Proto.parse3 DownloadRequest
+       parseCommand "au" = Proto.parse3 AssistantUploadRequest
+       parseCommand "ad" = Proto.parse3 AssistantDownloadRequest
+       parseCommand _ = Proto.parseFail
+
+instance Proto.Sendable TransferResponse where
+       formatMessage (TransferOutput (OutputMessage m)) =
+               ["om", Proto.serialize (encode_c (decodeBS m))]
+       formatMessage (TransferOutput (OutputError e)) =
+               ["oe", Proto.serialize (encode_c e)]
+       formatMessage (TransferOutput (StartProgressMeter (Just n))) =
+               ["ops", Proto.serialize n]
+       formatMessage (TransferOutput (StartProgressMeter Nothing)) =
+               ["opsx"]
+       formatMessage (TransferOutput (UpdateProgressMeter n)) =
+               ["op", Proto.serialize n]
+       formatMessage (TransferOutput EndProgressMeter) =
+               ["ope"]
+       formatMessage (TransferOutput StartPrompt) =
+               ["oprs"]
+       formatMessage (TransferOutput EndPrompt) =
+               ["opre"]
+       formatMessage (TransferOutput (JSONObject b)) =
+               ["oj", Proto.serialize (encode_c (decodeBL b))]
+       formatMessage (TransferResult True) =
+               ["t"]
+       formatMessage (TransferResult False) =
+               ["f"]
+
+instance Proto.Receivable TransferResponse where
+       parseCommand "om" = Proto.parse1 (TransferOutput . OutputMessage . encodeBS . decode_c)
+       parseCommand "oe" = Proto.parse1 (TransferOutput . OutputError . decode_c)
+       parseCommand "ops" = Proto.parse1 (TransferOutput . StartProgressMeter . Just)
+       parseCommand "opsx" = Proto.parse0 (TransferOutput (StartProgressMeter Nothing))
+       parseCommand "op" = Proto.parse1 (TransferOutput . UpdateProgressMeter)
+       parseCommand "ope" = Proto.parse0 (TransferOutput EndProgressMeter)
+       parseCommand "oprs" = Proto.parse0 (TransferOutput StartPrompt)
+       parseCommand "opre" = Proto.parse0 (TransferOutput EndPrompt)
+       parseCommand "oj" = Proto.parse1 (TransferOutput . JSONObject . encodeBL . decode_c)
+       parseCommand "t" = Proto.parse0 (TransferResult True)
+       parseCommand "f" = Proto.parse0 (TransferResult False)
+       parseCommand _ = Proto.parseFail
+
+instance Proto.Sendable TransferSerializedOutputResponse where
+       formatMessage (TransferSerializedOutputResponse ReadyPrompt) = ["opr"]
+
+instance Proto.Receivable TransferSerializedOutputResponse where
+       parseCommand "opr" = Proto.parse0 (TransferSerializedOutputResponse ReadyPrompt)
+       parseCommand _ = Proto.parseFail
+
+instance Proto.Serializable TransferRemote where
+       serialize (TransferRemoteUUID u) = 'u':fromUUID u
+       -- A remote name could contain whitespace or newlines, which needs
+       -- to be escaped for the protocol. Use C-style encoding.
+       serialize (TransferRemoteName r) = 'r':encode_c' isSpace r
+
+       deserialize ('u':u) = Just (TransferRemoteUUID (toUUID u))
+       deserialize ('r':r) = Just (TransferRemoteName (decode_c r))
+       deserialize _ = Nothing
+
+instance Proto.Serializable TransferAssociatedFile where
+       -- Comes last, so whitespace is ok. But, in case the filename
+       -- contains eg a newline, escape it. Use C-style encoding.
+       serialize (TransferAssociatedFile (AssociatedFile (Just f))) =
+               encode_c (fromRawFilePath f)
+       serialize (TransferAssociatedFile (AssociatedFile Nothing)) = ""
+
+       deserialize "" = Just $ TransferAssociatedFile $
+               AssociatedFile Nothing
+       deserialize s = Just $ TransferAssociatedFile $
+               AssociatedFile $ Just $ toRawFilePath $ decode_c s