From: Joey Hess Date: Wed, 9 Dec 2020 16:32:29 +0000 (-0400) Subject: move new interface to git-annex transfer X-Git-Tag: archive/raspbian/10.20250416-2+rpi1~2^2^2~76^2~390 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=05c0543e8e1a59964318a3ffd377332549a263d2;p=git-annex.git move new interface to git-annex transfer This is to avoid breakage when upgrading or downgrading git-annex with a process running that uses the interface. It's better to keep the compatability code for a few years than worry about such breakage. This commit was sponsored by Brett Eisenberg on Patreon. --- 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_transfer.mdwn b/doc/todo/serialize_Messages_for_transfer.mdwn new file mode 100644 index 0000000000..18a1aafcaa --- /dev/null +++ b/doc/todo/serialize_Messages_for_transfer.mdwn @@ -0,0 +1,47 @@ +For [[todo/more_extensive_retries_to_mask_transient_failures]], +multiple transferkeys processes need to be run. So all console IO needs to +be serialized and sent back to the main git-annex process from them, +to avoid concurrent output. + +Using --json and --json-progress and --json-error-messages is pretty close +to what would be needed. That handles progress of transfers, and overall +success/failure. + +Using --json-error-messages makes most error messages be output in json. +However, that uses an error-messages array in the json object, +which error messages are added to as an action runs, and it's only sent at +the end. So a problem for eg, a relay of stderr output from a command +(eg ssh password prompt), or for anything that displays a warning that +should be displayed before the transfer is complete. + +Since the existing json is not a perfect fit, it might be better to use a +custom protocol, implemented as a new output type. Then anything in +Messages and child modules that looks at output types will support it. +(Although perhaps some of that stuff is not used by remotes.) + +A few notes on implementing that: + +* Messages.Progress.mkOutputHandler, which uses mkStderrEmitter, + outputs to stderr directly no matter the output type currently. + It would need to be changed to support the new output type. + (And probably should for concurrent output mode too actually!) + + > It's true, this is not concurrent output safe. However, that's already + > the case, and output to stderr doesn't affect the piping of serialized + > messages on stdout. So, punted on this. + +* So does warningIO, though it's only used in a couple of remotes + and rarely. It would be good to find a way to eliminate it. + + > Eliminated except for one call in a non-relevant code path. + +* Messages.prompt. Which is used by remotes, and would need to + communicate over the pipe to the parent git-annex bidirectionally. + Eg, send a message saying the parent needs to prepare for prompt, + wait for it to reply saying it has, and then send a message when the + prompting is done. (Note that the parent would need to detect if the child + process crashed to avoid being locked waiting for the prompt.) + + > Done. + +[[done]] diff --git a/doc/todo/serialize_Messages_for_transferkeys.mdwn b/doc/todo/serialize_Messages_for_transferkeys.mdwn deleted file mode 100644 index 18a1aafcaa..0000000000 --- a/doc/todo/serialize_Messages_for_transferkeys.mdwn +++ /dev/null @@ -1,47 +0,0 @@ -For [[todo/more_extensive_retries_to_mask_transient_failures]], -multiple transferkeys processes need to be run. So all console IO needs to -be serialized and sent back to the main git-annex process from them, -to avoid concurrent output. - -Using --json and --json-progress and --json-error-messages is pretty close -to what would be needed. That handles progress of transfers, and overall -success/failure. - -Using --json-error-messages makes most error messages be output in json. -However, that uses an error-messages array in the json object, -which error messages are added to as an action runs, and it's only sent at -the end. So a problem for eg, a relay of stderr output from a command -(eg ssh password prompt), or for anything that displays a warning that -should be displayed before the transfer is complete. - -Since the existing json is not a perfect fit, it might be better to use a -custom protocol, implemented as a new output type. Then anything in -Messages and child modules that looks at output types will support it. -(Although perhaps some of that stuff is not used by remotes.) - -A few notes on implementing that: - -* Messages.Progress.mkOutputHandler, which uses mkStderrEmitter, - outputs to stderr directly no matter the output type currently. - It would need to be changed to support the new output type. - (And probably should for concurrent output mode too actually!) - - > It's true, this is not concurrent output safe. However, that's already - > the case, and output to stderr doesn't affect the piping of serialized - > messages on stdout. So, punted on this. - -* So does warningIO, though it's only used in a couple of remotes - and rarely. It would be good to find a way to eliminate it. - - > Eliminated except for one call in a non-relevant code path. - -* Messages.prompt. Which is used by remotes, and would need to - communicate over the pipe to the parent git-annex bidirectionally. - Eg, send a message saying the parent needs to prepare for prompt, - wait for it to reply saying it has, and then send a message when the - prompting is done. (Note that the parent would need to detect if the child - process crashed to avoid being locked waiting for the prompt.) - - > Done. - -[[done]] 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