diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs index d08b7f7ee1..ba2044e2fb 100644 --- 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 81231b3f8a..2d2aceebc5 100644 --- 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 fccef96f30..ee3e17e280 100644 --- 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 88804ec0d6..5222011c95 100644 --- 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 80fc176c45..16d1d24993 100644 --- 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 08e48227eb..f4b38e7c75 100644 --- 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