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