custom protocol for transferrer
Rather than using Read/Show, which would force me to preserve data types into the future. I considered just deriving json and sending that, but I don't much like deriving json with data types that have named constructors (like Key does) because again it locks in data type details. So instead, used SimpleProtocol, with a fairly complex and unreadable protocol. But it is as efficient as the p2p protocol at least, and as future proof. (Writing my own custom json instances would have worked but I thought of it too late and don't want to do all the work twice. The only real benefit might be that aeson could be faster.) Note that, when a new protocol request type is added later, git-annex trying to use it will cause the git-annex transferrer to display a protocol error message. That seems ok; it would only happen if a new git-annex found an old version of itself in PATH or the program file. So it's unlikely, and all it can do anyway is display an error. (The error message could perhaps be improved..) This commit was sponsored by Jack Hill on Patreon.
This commit is contained in:
parent
447d798987
commit
04c12aa6df
6 changed files with 194 additions and 53 deletions
|
@ -19,8 +19,7 @@ import Annex.BranchState
|
|||
import Types.Messages
|
||||
import Annex.TransferrerPool
|
||||
import Types.Transferrer
|
||||
|
||||
import Text.Read (readMaybe)
|
||||
import qualified Utility.SimpleProtocol as Proto
|
||||
|
||||
cmd :: Command
|
||||
cmd = command "transferrer" SectionPlumbing "transfers content"
|
||||
|
@ -33,32 +32,36 @@ start :: CommandStart
|
|||
start = do
|
||||
enableInteractiveBranchAccess
|
||||
(readh, writeh) <- liftIO dupIoHandles
|
||||
Annex.setOutput $ SerializedOutput
|
||||
(\v -> hPutStrLn writeh (show (TransferOutput v)) >> hFlush writeh)
|
||||
(readMaybe <$> hGetLine readh)
|
||||
let outputwriter v = do
|
||||
hPutStrLn writeh $
|
||||
unwords $ Proto.formatMessage $ TransferOutput v
|
||||
hFlush writeh
|
||||
let outputresponsereader = do
|
||||
l <- hGetLine readh
|
||||
return $ case Proto.parseMessage l of
|
||||
Just (TransferSerializedOutputResponse r) -> Just r
|
||||
Nothing -> Nothing
|
||||
Annex.setOutput $ SerializedOutput outputwriter outputresponsereader
|
||||
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 $
|
||||
runner (UploadRequest _ key (TransferAssociatedFile file)) remote =
|
||||
-- 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
|
||||
runner (DownloadRequest _ key (TransferAssociatedFile file)) remote =
|
||||
-- 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
|
||||
runner (AssistantUploadRequest _ key (TransferAssociatedFile file)) remote =
|
||||
notifyTransfer Upload file $
|
||||
upload' (Remote.uuid remote) key file stdRetry $ \p -> do
|
||||
tryNonAsync (Remote.storeKey remote key file p) >>= \case
|
||||
Left e -> do
|
||||
|
@ -67,7 +70,8 @@ start = do
|
|||
Right () -> do
|
||||
Remote.logStatus remote key InfoPresent
|
||||
return True
|
||||
| otherwise = notifyTransfer direction file $
|
||||
runner (AssistantDownloadRequest _ key (TransferAssociatedFile file)) remote =
|
||||
notifyTransfer Download 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
|
||||
|
@ -80,8 +84,6 @@ start = do
|
|||
-- not old cached data.
|
||||
Database.Keys.closeDb
|
||||
return r
|
||||
where
|
||||
key = mkKey (const keydata)
|
||||
|
||||
runRequests
|
||||
:: Handle
|
||||
|
@ -92,15 +94,19 @@ 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
|
||||
case Proto.parseMessage l of
|
||||
Just tr -> do
|
||||
let remoteoruuid = transferRequestRemote tr
|
||||
-- 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)
|
||||
else case remoteoruuid of
|
||||
TransferRemoteName n ->
|
||||
eitherToMaybe <$> Remote.byName' n
|
||||
TransferRemoteUUID u ->
|
||||
Remote.byUUID u
|
||||
case mremote of
|
||||
Just remote -> do
|
||||
sendresult =<< a tr remote
|
||||
|
@ -109,5 +115,6 @@ runRequests readh writeh a = go Nothing Nothing
|
|||
Nothing -> transferrerProtocolError l
|
||||
|
||||
sendresult b = liftIO $ do
|
||||
hPutStrLn writeh $ show $ TransferResult b
|
||||
hPutStrLn writeh $
|
||||
unwords $ Proto.formatMessage $ TransferResult b
|
||||
hFlush writeh
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue