-{- A pool of "git-annex transferkeys" processes
+{- A pool of "git-annex transfer" processes
-
- Copyright 2013-2020 Joey Hess <id@joeyh.name>
-
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
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. -}
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
, Command.RegisterUrl.cmd
, Command.SetKey.cmd
, Command.DropKey.cmd
+ , Command.Transfer.cmd
, Command.TransferKey.cmd
, Command.TransferKeys.cmd
, Command.SetPresentKey.cmd
--- /dev/null
+{- git-annex command
+ -
+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>
+ -
+ - 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
-{- 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 <id@joeyh.name>
+ - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
-
- 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
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
-- 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
-{- 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 <id@joeyh.name>
-
--- /dev/null
+# 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 <id@joeyh.name>
+
+Warning: Automatically converted into a man page by mdwn2man. Edit with care.
# NAME
-git-annex transferkeys - transfers keys
+git-annex transferkeys - transfers keys (deprecated)
# SYNOPSIS
# 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).
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.
--- /dev/null
+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]]
+++ /dev/null
-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]]
Command.Test
Command.TestRemote
Command.TransferInfo
+ Command.Transfer
Command.TransferKey
Command.TransferKeys
Command.Trust
projects / git-annex.git / commitdiff