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.
This commit is contained in:
Joey Hess 2020-12-09 12:32:29 -04:00
parent b9c1aa9258
commit 05c0543e8e
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
10 changed files with 238 additions and 60 deletions

View file

@ -1,4 +1,4 @@
{- A pool of "git-annex transferkeys" processes {- A pool of "git-annex transfer" processes
- -
- Copyright 2013-2020 Joey Hess <id@joeyh.name> - Copyright 2013-2020 Joey Hess <id@joeyh.name>
- -
@ -197,12 +197,12 @@ detectStalls (Just (StallDetection minsz duration)) metervar onstall = go Nothin
then onstall then onstall
else go (Just sofar) 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. -} - that will be used to communicate with it. -}
mkTransferrer :: FilePath -> BatchCommandMaker -> IO Transferrer mkTransferrer :: FilePath -> BatchCommandMaker -> IO Transferrer
mkTransferrer program batchmaker = do mkTransferrer program batchmaker = do
{- It runs as a batch job. -} {- 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 {- It's put into its own group so that the whole group can be
- killed to stop a transfer. -} - killed to stop a transfer. -}
(Just writeh, Just readh, _, pid) <- createProcess (Just writeh, Just readh, _, pid) <- createProcess
@ -243,10 +243,10 @@ readResponse h = do
case readMaybe l of case readMaybe l of
Just (TransferOutput so) -> return (Left so) Just (TransferOutput so) -> return (Left so)
Just (TransferResult r) -> return (Right r) Just (TransferResult r) -> return (Right r)
Nothing -> transferKeysProtocolError l Nothing -> transferProtocolError l
transferKeysProtocolError :: String -> a transferProtocolError :: String -> a
transferKeysProtocolError l = error $ "transferkeys protocol error: " ++ show l transferProtocolError l = error $ "transfer protocol error: " ++ show l
{- Closing the fds will shut down the transferrer, but only when it's {- Closing the fds will shut down the transferrer, but only when it's
- in between transfers. -} - in between transfers. -}

View file

@ -35,6 +35,7 @@ import qualified Command.FromKey
import qualified Command.RegisterUrl import qualified Command.RegisterUrl
import qualified Command.SetKey import qualified Command.SetKey
import qualified Command.DropKey import qualified Command.DropKey
import qualified Command.Transfer
import qualified Command.TransferKey import qualified Command.TransferKey
import qualified Command.TransferKeys import qualified Command.TransferKeys
import qualified Command.SetPresentKey import qualified Command.SetPresentKey
@ -177,6 +178,7 @@ cmds testoptparser testrunner mkbenchmarkgenerator =
, Command.RegisterUrl.cmd , Command.RegisterUrl.cmd
, Command.SetKey.cmd , Command.SetKey.cmd
, Command.DropKey.cmd , Command.DropKey.cmd
, Command.Transfer.cmd
, Command.TransferKey.cmd , Command.TransferKey.cmd
, Command.TransferKeys.cmd , Command.TransferKeys.cmd
, Command.SetPresentKey.cmd , Command.SetPresentKey.cmd

112
Command/Transfer.hs Normal file
View file

@ -0,0 +1,112 @@
{- 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

View file

@ -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 <id@joeyh.name> - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module Command.TransferKeys where module Command.TransferKeys where
import Command import Command
import qualified Annex
import Annex.Content import Annex.Content
import Logs.Location import Logs.Location
import Annex.Transfer import Annex.Transfer
import qualified Remote import qualified Remote
import Utility.SimpleProtocol (dupIoHandles) import Utility.SimpleProtocol (dupIoHandles)
import Git.Types (RemoteName)
import qualified Database.Keys import qualified Database.Keys
import Annex.BranchState import Annex.BranchState
import Types.Messages
import Annex.TransferrerPool
import Text.Read (readMaybe) data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
cmd :: Command cmd :: Command
cmd = command "transferkeys" SectionPlumbing "transfers keys" cmd = command "transferkeys" SectionPlumbing "transfers keys (deprecated)"
paramNothing (withParams seek) paramNothing (withParams seek)
seek :: CmdParams -> CommandSeek seek :: CmdParams -> CommandSeek
@ -32,31 +35,10 @@ start :: CommandStart
start = do start = do
enableInteractiveBranchAccess enableInteractiveBranchAccess
(readh, writeh) <- liftIO dupIoHandles (readh, writeh) <- liftIO dupIoHandles
Annex.setOutput $ SerializedOutput
(\v -> hPutStrLn writeh (show (TransferOutput v)) >> hFlush writeh)
(readMaybe <$> hGetLine readh)
runRequests readh writeh runner runRequests readh writeh runner
stop stop
where where
runner (TransferRequest AnnexLevel direction _ keydata file) remote runner (TransferRequest direction remote key file)
| 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 $ | direction == Upload = notifyTransfer direction file $
upload' (Remote.uuid remote) key file stdRetry $ \p -> do upload' (Remote.uuid remote) key file stdRetry $ \p -> do
tryNonAsync (Remote.storeKey remote key file p) >>= \case tryNonAsync (Remote.storeKey remote key file p) >>= \case
@ -79,34 +61,82 @@ start = do
-- not old cached data. -- not old cached data.
Database.Keys.closeDb Database.Keys.closeDb
return r return r
where
key = mkKey (const keydata)
runRequests runRequests
:: Handle :: Handle
-> Handle -> Handle
-> (TransferRequest -> Remote -> Annex Bool) -> (TransferRequest -> Annex Bool)
-> Annex () -> Annex ()
runRequests readh writeh a = go Nothing Nothing runRequests readh writeh a = do
liftIO $ hSetBuffering readh NoBuffering
go =<< readrequests
where where
go lastremoteoruuid lastremote = unlessM (liftIO $ hIsEOF readh) $ do go (d:rn:k:f:rest) = do
l <- liftIO $ hGetLine readh case (deserialize d, deserialize rn, deserialize k, deserialize f) of
case readMaybe l of (Just direction, Just remotename, Just key, Just file) -> do
Just tr@(TransferRequest _ _ remoteoruuid _ _) -> do mremote <- Remote.byName' remotename
-- 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 case mremote of
Just remote -> do Left _ -> sendresult False
sendresult =<< a tr remote Right remote -> sendresult =<< a
go (Just remoteoruuid) mremote (TransferRequest direction remote key file)
Nothing -> transferKeysProtocolError l _ -> sendresult False
Nothing -> transferKeysProtocolError l go rest
go [] = noop
go [""] = noop
go v = error $ "transferkeys protocol error: " ++ show v
readrequests = liftIO $ split fieldSep <$> hGetContents readh
sendresult b = liftIO $ do sendresult b = liftIO $ do
hPutStrLn writeh $ show $ TransferResult b hPutStrLn writeh $ serialize b
hFlush writeh 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

View file

@ -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 <id@joeyh.name> - Copyright 2013-2020 Joey Hess <id@joeyh.name>
- -

View file

@ -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 <id@joeyh.name>
Warning: Automatically converted into a man page by mdwn2man. Edit with care.

View file

@ -1,6 +1,6 @@
# NAME # NAME
git-annex transferkeys - transfers keys git-annex transferkeys - transfers keys (deprecated)
# SYNOPSIS # SYNOPSIS
@ -8,7 +8,10 @@ git annex transferkeys
# DESCRIPTION # 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 It is a long-running process, which is fed instructions about the keys
to transfer using an internal stdio protocol, which is to transfer using an internal stdio protocol, which is
intentionally not documented (as it may change at any time). intentionally not documented (as it may change at any time).

View file

@ -631,9 +631,15 @@ content from the key-value store.
See [[git-annex-transferkey]](1) for details. See [[git-annex-transferkey]](1) for details.
* `transfer`
Used internally by git-annex to transfer content.
See [[git-annex-transfer]](1) for details.
* `transferkeys` * `transferkeys`
Used internally by the assistant. Used internally by old versions of the assistant.
See [[git-annex-transferkey]](1) for details. See [[git-annex-transferkey]](1) for details.

View file

@ -794,6 +794,7 @@ Executable git-annex
Command.Test Command.Test
Command.TestRemote Command.TestRemote
Command.TransferInfo Command.TransferInfo
Command.Transfer
Command.TransferKey Command.TransferKey
Command.TransferKeys Command.TransferKeys
Command.Trust Command.Trust