diff --git a/Annex/TransferrerPool.hs b/Annex/TransferrerPool.hs index 973f756298..f44d46db90 100644 --- a/Annex/TransferrerPool.hs +++ b/Annex/TransferrerPool.hs @@ -1,4 +1,4 @@ -{- A pool of "git-annex transferkeys" processes +{- A pool of "git-annex transfer" processes - - Copyright 2013-2020 Joey Hess - @@ -197,12 +197,12 @@ detectStalls (Just (StallDetection minsz duration)) metervar onstall = go Nothin then onstall else go (Just sofar) -{- Starts a new git-annex transferkeys process, setting up handles +{- Starts a new git-annex transfer process, setting up handles - that will be used to communicate with it. -} mkTransferrer :: FilePath -> BatchCommandMaker -> IO Transferrer mkTransferrer program batchmaker = do {- It runs as a batch job. -} - let (program', params') = batchmaker (program, [Param "transferkeys"]) + let (program', params') = batchmaker (program, [Param "transfer"]) {- It's put into its own group so that the whole group can be - killed to stop a transfer. -} (Just writeh, Just readh, _, pid) <- createProcess @@ -243,10 +243,10 @@ readResponse h = do case readMaybe l of Just (TransferOutput so) -> return (Left so) Just (TransferResult r) -> return (Right r) - Nothing -> transferKeysProtocolError l + Nothing -> transferProtocolError l -transferKeysProtocolError :: String -> a -transferKeysProtocolError l = error $ "transferkeys protocol error: " ++ show l +transferProtocolError :: String -> a +transferProtocolError l = error $ "transfer protocol error: " ++ show l {- Closing the fds will shut down the transferrer, but only when it's - in between transfers. -} diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 9fc0d272ae..2364df8bac 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -35,6 +35,7 @@ import qualified Command.FromKey import qualified Command.RegisterUrl import qualified Command.SetKey import qualified Command.DropKey +import qualified Command.Transfer import qualified Command.TransferKey import qualified Command.TransferKeys import qualified Command.SetPresentKey @@ -177,6 +178,7 @@ cmds testoptparser testrunner mkbenchmarkgenerator = , Command.RegisterUrl.cmd , Command.SetKey.cmd , Command.DropKey.cmd + , Command.Transfer.cmd , Command.TransferKey.cmd , Command.TransferKeys.cmd , Command.SetPresentKey.cmd diff --git a/Command/Transfer.hs b/Command/Transfer.hs new file mode 100644 index 0000000000..f4a1cd28df --- /dev/null +++ b/Command/Transfer.hs @@ -0,0 +1,112 @@ +{- git-annex command + - + - Copyright 2012-2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Command.Transfer where + +import Command +import qualified Annex +import Annex.Content +import Logs.Location +import Annex.Transfer +import qualified Remote +import Utility.SimpleProtocol (dupIoHandles) +import qualified Database.Keys +import Annex.BranchState +import Types.Messages +import Annex.TransferrerPool + +import Text.Read (readMaybe) + +cmd :: Command +cmd = command "transfer" SectionPlumbing "transfers content" + paramNothing (withParams seek) + +seek :: CmdParams -> CommandSeek +seek = withNothing (commandAction start) + +start :: CommandStart +start = do + enableInteractiveBranchAccess + (readh, writeh) <- liftIO dupIoHandles + Annex.setOutput $ SerializedOutput + (\v -> hPutStrLn writeh (show (TransferOutput v)) >> hFlush writeh) + (readMaybe <$> hGetLine readh) + 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 $ + upload' (Remote.uuid remote) key file stdRetry $ \p -> do + tryNonAsync (Remote.storeKey remote key file p) >>= \case + Left e -> do + warning (show e) + return False + Right () -> do + Remote.logStatus remote key InfoPresent + return True + | otherwise = notifyTransfer direction 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 + Left e -> do + warning (show e) + return (False, UnVerified) + Right v -> return (True, v) + -- Make sure we get the current + -- associated files data for the key, + -- not old cached data. + Database.Keys.closeDb + return r + where + key = mkKey (const keydata) + +runRequests + :: Handle + -> Handle + -> (TransferRequest -> Remote -> Annex Bool) + -> Annex () +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 + -- 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 + Just remote -> do + sendresult =<< a tr remote + go (Just remoteoruuid) mremote + Nothing -> transferProtocolError l + Nothing -> transferProtocolError l + + sendresult b = liftIO $ do + hPutStrLn writeh $ show $ TransferResult b + hFlush writeh diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 573530e98f..aba5feabaa 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -1,28 +1,31 @@ -{- git-annex command +{- git-annex command, used internally by assistant in version + - 8.20201127 and older and provided only to avoid upgrade breakage. + - Remove at some point when such old versions of git-annex are unlikely + - to be running any longer. - - - Copyright 2012-2020 Joey Hess + - Copyright 2012, 2013 Joey Hess - - 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 import qualified Remote import Utility.SimpleProtocol (dupIoHandles) +import Git.Types (RemoteName) import qualified Database.Keys import Annex.BranchState -import Types.Messages -import Annex.TransferrerPool -import Text.Read (readMaybe) +data TransferRequest = TransferRequest Direction Remote Key AssociatedFile cmd :: Command -cmd = command "transferkeys" SectionPlumbing "transfers keys" +cmd = command "transferkeys" SectionPlumbing "transfers keys (deprecated)" paramNothing (withParams seek) seek :: CmdParams -> CommandSeek @@ -32,31 +35,10 @@ start :: CommandStart start = do enableInteractiveBranchAccess (readh, writeh) <- liftIO dupIoHandles - Annex.setOutput $ SerializedOutput - (\v -> hPutStrLn writeh (show (TransferOutput v)) >> hFlush writeh) - (readMaybe <$> hGetLine readh) 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 + runner (TransferRequest direction remote key file) | direction == Upload = notifyTransfer direction file $ upload' (Remote.uuid remote) key file stdRetry $ \p -> do tryNonAsync (Remote.storeKey remote key file p) >>= \case @@ -79,34 +61,82 @@ start = do -- not old cached data. Database.Keys.closeDb return r - where - key = mkKey (const keydata) runRequests :: Handle -> Handle - -> (TransferRequest -> Remote -> Annex Bool) + -> (TransferRequest -> Annex Bool) -> Annex () -runRequests readh writeh a = go Nothing Nothing +runRequests readh writeh a = do + liftIO $ hSetBuffering readh NoBuffering + go =<< readrequests where - 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) + 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 case mremote of - Just remote -> do - sendresult =<< a tr remote - go (Just remoteoruuid) mremote - Nothing -> transferKeysProtocolError l - Nothing -> transferKeysProtocolError l + 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 + readrequests = liftIO $ split fieldSep <$> hGetContents readh sendresult b = liftIO $ do - hPutStrLn writeh $ show $ TransferResult b + hPutStrLn writeh $ serialize 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 + +readResponse :: Handle -> IO Bool +readResponse h = fromMaybe False . deserialize <$> hGetLine h + +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 diff --git a/Types/TransferrerPool.hs b/Types/TransferrerPool.hs index 72d61a3b9a..e2150e3008 100644 --- a/Types/TransferrerPool.hs +++ b/Types/TransferrerPool.hs @@ -1,4 +1,4 @@ -{- A pool of "git-annex transferkeys" processes available for use +{- A pool of "git-annex transfer" processes available for use - - Copyright 2013-2020 Joey Hess - diff --git a/doc/git-annex-transfer.mdwn b/doc/git-annex-transfer.mdwn new file mode 100644 index 0000000000..a318959d9e --- /dev/null +++ b/doc/git-annex-transfer.mdwn @@ -0,0 +1,24 @@ +# NAME + +git-annex transfer - transfers content + +# SYNOPSIS + +git annex transfer + +# DESCRIPTION + +This plumbing-level command is used to transfer data. +It is a long-running process, which is fed instructions about +what to transfer using an internal stdio protocol, which is +intentionally not documented (as it may change at any time). + +# SEE ALSO + +[[git-annex]](1) + +# AUTHOR + +Joey Hess + +Warning: Automatically converted into a man page by mdwn2man. Edit with care. diff --git a/doc/git-annex-transferkeys.mdwn b/doc/git-annex-transferkeys.mdwn index b1f983d5b8..cdc97771d4 100644 --- a/doc/git-annex-transferkeys.mdwn +++ b/doc/git-annex-transferkeys.mdwn @@ -1,6 +1,6 @@ # NAME -git-annex transferkeys - transfers keys +git-annex transferkeys - transfers keys (deprecated) # SYNOPSIS @@ -8,7 +8,10 @@ git annex transferkeys # DESCRIPTION -This plumbing-level command is used to transfer data. +This plumbing-level command is used to transfer data, by the assistant +in git-annex version 8.20201127 and older. It is still included only +to prevent breakage during upgrades. + It is a long-running process, which is fed instructions about the keys to transfer using an internal stdio protocol, which is intentionally not documented (as it may change at any time). diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index b739cdafd2..b1be9055f1 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -631,9 +631,15 @@ content from the key-value store. See [[git-annex-transferkey]](1) for details. +* `transfer` + + Used internally by git-annex to transfer content. + + See [[git-annex-transfer]](1) for details. + * `transferkeys` - Used internally by the assistant. + Used internally by old versions of the assistant. See [[git-annex-transferkey]](1) for details. diff --git a/doc/todo/serialize_Messages_for_transferkeys.mdwn b/doc/todo/serialize_Messages_for_transfer.mdwn similarity index 100% rename from doc/todo/serialize_Messages_for_transferkeys.mdwn rename to doc/todo/serialize_Messages_for_transfer.mdwn diff --git a/git-annex.cabal b/git-annex.cabal index 6f7a9ab2c8..a7d74579ee 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -794,6 +794,7 @@ Executable git-annex Command.Test Command.TestRemote Command.TransferInfo + Command.Transfer Command.TransferKey Command.TransferKeys Command.Trust