diff options
Diffstat (limited to 'Command/TransferInfo.hs')
-rw-r--r-- | Command/TransferInfo.hs | 60 |
1 files changed, 60 insertions, 0 deletions
diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs new file mode 100644 index 000000000..0e0e81609 --- /dev/null +++ b/Command/TransferInfo.hs @@ -0,0 +1,60 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.TransferInfo where + +import Common.Annex +import Command +import Annex.Content +import Logs.Transfer +import Types.Remote +import Types.Key + +def :: [Command] +def = [noCommit $ command "transferinfo" paramdesc seek + "updates sender on number of bytes of content received"] + +seek :: [CommandSeek] +seek = [withWords start] + +paramdesc :: String +paramdesc = paramKey `paramPair` paramUUID `paramPair` paramOptional paramFile + +start :: [String] -> CommandStart +start (k:u:f:[]) = start' (file2key k) (toUUID u) (Just f) >> stop +start (k:u:[]) = start' (file2key k) (toUUID u) Nothing >> stop +start _ = error "wrong number of parameters" + +{- Security: + - + - The transfer info file contains the user-supplied key, but + - the built-in guards prevent slashes in it from showing up in the filename. + - It also contains the UUID of the remote. But slashes are also filtered + - out of that when generating the filename. + - + - Checks that the key being transferred is inAnnex, to prevent + - malicious spamming of bogus keys. Does not check that a transfer + - of the key is actually in progress, because this could be started + - concurrently with sendkey, and win the race. + -} +start' :: Maybe Key -> UUID -> AssociatedFile -> Annex () +start' Nothing _ _ = error "bad key" +start' (Just key) u file = whenM (inAnnex key) $ do + let t = Transfer + { transferDirection = Upload + , transferUUID = u + , transferKey = key + } + info <- liftIO $ startTransferInfo file + (update, tfile) <- mkProgressUpdater t info + liftIO $ mapM_ void + [ tryIO $ forever $ do + bytes <- readish <$> getLine + maybe (error "transferinfo protocol error") update bytes + , tryIO $ removeFile tfile + , exitSuccess + ] |