2020-12-09 16:32:29 +00:00
|
|
|
{- git-annex command
|
|
|
|
-
|
|
|
|
- Copyright 2012-2020 Joey Hess <id@joeyh.name>
|
|
|
|
-
|
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
2020-12-09 17:21:20 +00:00
|
|
|
module Command.Transferrer where
|
2020-12-09 16:32:29 +00:00
|
|
|
|
|
|
|
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
|
2020-12-09 17:28:16 +00:00
|
|
|
import Types.Transferrer
|
2020-12-09 19:44:00 +00:00
|
|
|
import qualified Utility.SimpleProtocol as Proto
|
2020-12-09 16:32:29 +00:00
|
|
|
|
|
|
|
cmd :: Command
|
2020-12-11 20:16:07 +00:00
|
|
|
cmd = noCommit $ command "transferrer" SectionPlumbing "transfers content"
|
2020-12-09 16:32:29 +00:00
|
|
|
paramNothing (withParams seek)
|
|
|
|
|
|
|
|
seek :: CmdParams -> CommandSeek
|
|
|
|
seek = withNothing (commandAction start)
|
|
|
|
|
|
|
|
start :: CommandStart
|
|
|
|
start = do
|
|
|
|
enableInteractiveBranchAccess
|
|
|
|
(readh, writeh) <- liftIO dupIoHandles
|
2020-12-10 20:33:52 +00:00
|
|
|
let outputwriter = sendTransferResponse writeh . TransferOutput
|
2020-12-09 19:44:00 +00:00
|
|
|
let outputresponsereader = do
|
2020-12-11 19:28:58 +00:00
|
|
|
l <- getNextLine readh
|
2020-12-09 19:44:00 +00:00
|
|
|
return $ case Proto.parseMessage l of
|
|
|
|
Just (TransferSerializedOutputResponse r) -> Just r
|
|
|
|
Nothing -> Nothing
|
|
|
|
Annex.setOutput $ SerializedOutput outputwriter outputresponsereader
|
2020-12-09 16:32:29 +00:00
|
|
|
runRequests readh writeh runner
|
|
|
|
stop
|
|
|
|
where
|
2024-07-01 14:42:27 +00:00
|
|
|
runner (UploadRequest _ key (TransferAssociatedFile af)) remote =
|
2020-12-09 19:44:00 +00:00
|
|
|
-- This is called by eg, Annex.Transfer.upload,
|
|
|
|
-- so caller is responsible for doing notification,
|
2021-02-03 19:35:32 +00:00
|
|
|
-- and for retrying, and updating location log,
|
|
|
|
-- and stall canceling.
|
2024-07-01 14:42:27 +00:00
|
|
|
upload' (Remote.uuid remote) key af Nothing noRetry
|
|
|
|
(Remote.action . Remote.storeKey remote key af Nothing)
|
2020-12-09 19:44:00 +00:00
|
|
|
noNotification
|
2024-07-01 14:42:27 +00:00
|
|
|
runner (DownloadRequest _ key (TransferAssociatedFile af)) remote =
|
2020-12-09 19:44:00 +00:00
|
|
|
-- This is called by eg, Annex.Transfer.download
|
|
|
|
-- so caller is responsible for doing notification
|
2021-02-03 19:35:32 +00:00
|
|
|
-- and for retrying, and updating location log,
|
|
|
|
-- and stall canceling.
|
2024-07-01 14:42:27 +00:00
|
|
|
let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do
|
|
|
|
Remote.verifiedAction (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote))
|
|
|
|
in download' (Remote.uuid remote) key af Nothing noRetry go
|
2020-12-09 19:44:00 +00:00
|
|
|
noNotification
|
2024-07-01 14:42:27 +00:00
|
|
|
runner (AssistantUploadRequest _ key (TransferAssociatedFile af)) remote =
|
|
|
|
notifyTransfer Upload af $
|
|
|
|
upload' (Remote.uuid remote) key af Nothing stdRetry $ \p -> do
|
|
|
|
tryNonAsync (Remote.storeKey remote key af Nothing p) >>= \case
|
2020-12-09 16:32:29 +00:00
|
|
|
Left e -> do
|
filter out control characters in warning messages
Converted warning and similar to use StringContainingQuotedPath. Most
warnings are static strings, some do refer to filepaths that need to be
quoted, and others don't need quoting.
Note that, since quote filters out control characters of even
UnquotedString, this makes all warnings safe, even when an attacker
sneaks in a control character in some other way.
When json is being output, no quoting is done, since json gets its own
quoting.
This does, as a side effect, make warning messages in json output not
be indented. The indentation is only needed to offset warning messages
underneath the display of the file they apply to, so that's ok.
Sponsored-by: Brett Eisenberg on Patreon
2023-04-10 18:47:32 +00:00
|
|
|
warning (UnquotedString (show e))
|
2020-12-09 16:32:29 +00:00
|
|
|
return False
|
|
|
|
Right () -> do
|
2024-08-23 20:35:12 +00:00
|
|
|
Remote.logStatus NoLiveUpdate remote key InfoPresent
|
2020-12-09 16:32:29 +00:00
|
|
|
return True
|
2020-12-09 19:44:00 +00:00
|
|
|
runner (AssistantDownloadRequest _ key (TransferAssociatedFile file)) remote =
|
|
|
|
notifyTransfer Download file $
|
2021-02-03 19:35:32 +00:00
|
|
|
download' (Remote.uuid remote) key file Nothing stdRetry $ \p ->
|
2024-08-23 20:35:12 +00:00
|
|
|
logStatusAfter NoLiveUpdate key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do
|
2021-08-17 16:41:36 +00:00
|
|
|
r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case
|
2020-12-09 16:32:29 +00:00
|
|
|
Left e -> do
|
filter out control characters in warning messages
Converted warning and similar to use StringContainingQuotedPath. Most
warnings are static strings, some do refer to filepaths that need to be
quoted, and others don't need quoting.
Note that, since quote filters out control characters of even
UnquotedString, this makes all warnings safe, even when an attacker
sneaks in a control character in some other way.
When json is being output, no quoting is done, since json gets its own
quoting.
This does, as a side effect, make warning messages in json output not
be indented. The indentation is only needed to offset warning messages
underneath the display of the file they apply to, so that's ok.
Sponsored-by: Brett Eisenberg on Patreon
2023-04-10 18:47:32 +00:00
|
|
|
warning (UnquotedString (show e))
|
2020-12-09 16:32:29 +00:00
|
|
|
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
|
2020-12-11 19:28:58 +00:00
|
|
|
l <- liftIO $ getNextLine readh
|
2020-12-09 19:44:00 +00:00
|
|
|
case Proto.parseMessage l of
|
|
|
|
Just tr -> do
|
|
|
|
let remoteoruuid = transferRequestRemote tr
|
2020-12-09 16:32:29 +00:00
|
|
|
-- 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
|
2020-12-09 19:44:00 +00:00
|
|
|
else case remoteoruuid of
|
|
|
|
TransferRemoteName n ->
|
|
|
|
eitherToMaybe <$> Remote.byName' n
|
|
|
|
TransferRemoteUUID u ->
|
|
|
|
Remote.byUUID u
|
2020-12-09 16:32:29 +00:00
|
|
|
case mremote of
|
|
|
|
Just remote -> do
|
|
|
|
sendresult =<< a tr remote
|
|
|
|
go (Just remoteoruuid) mremote
|
2020-12-09 17:21:20 +00:00
|
|
|
Nothing -> transferrerProtocolError l
|
|
|
|
Nothing -> transferrerProtocolError l
|
2020-12-09 16:32:29 +00:00
|
|
|
|
2020-12-10 20:33:52 +00:00
|
|
|
sendresult = liftIO . sendTransferResponse writeh . TransferResult
|
|
|
|
|
|
|
|
sendTransferResponse :: Handle -> TransferResponse -> IO ()
|
2020-12-11 19:28:58 +00:00
|
|
|
sendTransferResponse h r = silenceIOErrors $ do
|
2020-12-10 20:33:52 +00:00
|
|
|
hPutStrLn h $ unwords $ Proto.formatMessage r
|
|
|
|
hFlush h
|
2020-12-11 19:28:58 +00:00
|
|
|
|
|
|
|
getNextLine :: Handle -> IO String
|
|
|
|
getNextLine = silenceIOErrors . hGetLine
|
|
|
|
|
|
|
|
{- If the pipe we're talking to gets closed due to the parent git-annex
|
|
|
|
- having exited, read/write would throw an exception due to sigpipe,
|
|
|
|
- which gets displayed on the console in an ugly way. This silences that
|
|
|
|
- display, and exits on exception instead.
|
|
|
|
-
|
|
|
|
- Normally signals like SIGINT get propagated to this process
|
|
|
|
- from the parent process. However, since this process is run in its own
|
|
|
|
- process group, that propagation requires the parent to actively
|
|
|
|
- propagate the signal. One way that could not happen is if the parent
|
|
|
|
- gets a signal it cannot catch. Another way is if the parent is hit by
|
|
|
|
- the signal before it can set up the signal propagation.
|
|
|
|
-}
|
|
|
|
silenceIOErrors :: IO a -> IO a
|
|
|
|
silenceIOErrors a = catchIO a (const exitFailure)
|