From: Joey Hess Date: Wed, 9 Dec 2020 17:21:20 +0000 (-0400) Subject: rename helper X-Git-Tag: archive/raspbian/10.20250416-2+rpi1~2^2^2~76^2~385 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=677003a6df9005fff22a6428ee845d45bb82d0da;p=git-annex.git rename helper More consistent name with TransferrerPool --- diff --git a/Annex/TransferrerPool.hs b/Annex/TransferrerPool.hs index f6babdcc63..8e5894a590 100644 --- a/Annex/TransferrerPool.hs +++ b/Annex/TransferrerPool.hs @@ -1,4 +1,4 @@ -{- A pool of "git-annex transfer" processes +{- A pool of "git-annex transferrer" processes - - Copyright 2013-2020 Joey Hess - @@ -205,7 +205,7 @@ detectStalls (Just (StallDetection minsz duration)) metervar onstall = go Nothin mkTransferrer :: FilePath -> BatchCommandMaker -> IO Transferrer mkTransferrer program batchmaker = do {- It runs as a batch job. -} - let (program', params') = batchmaker (program, [Param "transfer"]) + let (program', params') = batchmaker (program, [Param "transferrer"]) {- 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 @@ -246,10 +246,10 @@ readResponse h = do case readMaybe l of Just (TransferOutput so) -> return (Left so) Just (TransferResult r) -> return (Right r) - Nothing -> transferProtocolError l + Nothing -> transferrerProtocolError l -transferProtocolError :: String -> a -transferProtocolError l = error $ "transfer protocol error: " ++ show l +transferrerProtocolError :: String -> a +transferrerProtocolError l = error $ "transferrer 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 2364df8bac..6d9cc4a438 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -35,7 +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.Transferrer import qualified Command.TransferKey import qualified Command.TransferKeys import qualified Command.SetPresentKey @@ -178,7 +178,7 @@ cmds testoptparser testrunner mkbenchmarkgenerator = , Command.RegisterUrl.cmd , Command.SetKey.cmd , Command.DropKey.cmd - , Command.Transfer.cmd + , Command.Transferrer.cmd , Command.TransferKey.cmd , Command.TransferKeys.cmd , Command.SetPresentKey.cmd diff --git a/Command/Transfer.hs b/Command/Transfer.hs deleted file mode 100644 index f4a1cd28df..0000000000 --- a/Command/Transfer.hs +++ /dev/null @@ -1,112 +0,0 @@ -{- 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/Transferrer.hs b/Command/Transferrer.hs new file mode 100644 index 0000000000..0596c6c34e --- /dev/null +++ b/Command/Transferrer.hs @@ -0,0 +1,112 @@ +{- git-annex command + - + - Copyright 2012-2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Command.Transferrer 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 "transferrer" 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 -> transferrerProtocolError l + Nothing -> transferrerProtocolError l + + sendresult b = liftIO $ do + hPutStrLn writeh $ show $ TransferResult b + hFlush writeh diff --git a/doc/git-annex-transfer.mdwn b/doc/git-annex-transfer.mdwn deleted file mode 100644 index a318959d9e..0000000000 --- a/doc/git-annex-transfer.mdwn +++ /dev/null @@ -1,24 +0,0 @@ -# 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-transferrer.mdwn b/doc/git-annex-transferrer.mdwn new file mode 100644 index 0000000000..b1fb7f0359 --- /dev/null +++ b/doc/git-annex-transferrer.mdwn @@ -0,0 +1,24 @@ +# NAME + +git-annex transferrer - transfers content + +# SYNOPSIS + +git annex transferrer + +# 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.mdwn b/doc/git-annex.mdwn index b1be9055f1..f83398997e 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -631,11 +631,11 @@ content from the key-value store. See [[git-annex-transferkey]](1) for details. -* `transfer` +* `transferrer` Used internally by git-annex to transfer content. - See [[git-annex-transfer]](1) for details. + See [[git-annex-transferrer]](1) for details. * `transferkeys` diff --git a/git-annex.cabal b/git-annex.cabal index a7d74579ee..0d209da99e 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -794,7 +794,7 @@ Executable git-annex Command.Test Command.TestRemote Command.TransferInfo - Command.Transfer + Command.Transferrer Command.TransferKey Command.TransferKeys Command.Trust