04c12aa6df
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.
120 lines
3.9 KiB
Haskell
120 lines
3.9 KiB
Haskell
{- 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 Types.Transferrer
|
|
import qualified Utility.SimpleProtocol as Proto
|
|
|
|
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
|
|
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 (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
|
|
warning (show e)
|
|
return False
|
|
Right () -> do
|
|
Remote.logStatus remote key InfoPresent
|
|
return True
|
|
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
|
|
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
|
|
|
|
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 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 case remoteoruuid of
|
|
TransferRemoteName n ->
|
|
eitherToMaybe <$> Remote.byName' n
|
|
TransferRemoteUUID u ->
|
|
Remote.byUUID u
|
|
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 $
|
|
unwords $ Proto.formatMessage $ TransferResult b
|
|
hFlush writeh
|