diff options
| -rw-r--r-- | Command/TransferInfo.hs | 60 | ||||
| -rw-r--r-- | GitAnnexShell.hs | 2 | ||||
| -rw-r--r-- | Logs/Transfer.hs | 55 | ||||
| -rw-r--r-- | Types/Key.hs | 2 | ||||
| -rw-r--r-- | doc/git-annex-shell.mdwn | 9 |
5 files changed, 104 insertions, 24 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 + ] diff --git a/GitAnnexShell.hs b/GitAnnexShell.hs index d9b60c0f6..ebe280279 100644 --- a/GitAnnexShell.hs +++ b/GitAnnexShell.hs @@ -23,6 +23,7 @@ import qualified Command.InAnnex import qualified Command.DropKey import qualified Command.RecvKey import qualified Command.SendKey +import qualified Command.TransferInfo import qualified Command.Commit cmds_readonly :: [Command] @@ -30,6 +31,7 @@ cmds_readonly = concat [ Command.ConfigList.def , Command.InAnnex.def , Command.SendKey.def + , Command.TransferInfo.def ] cmds_notreadonly :: [Command] diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index e9ac5bd87..7188143d6 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -89,18 +89,9 @@ download u key file a = runTransfer (Transfer Download u key) file (const a) -} runTransfer :: Transfer -> Maybe FilePath -> (MeterUpdate -> Annex Bool) -> Annex Bool runTransfer t file a = do - tfile <- fromRepo $ transferFile t - createAnnexDirectory $ takeDirectory tfile + info <- liftIO $ startTransferInfo file + (meter, tfile) <- mkProgressUpdater t info mode <- annexFileMode - info <- liftIO $ TransferInfo - <$> (Just . utcTimeToPOSIXSeconds <$> getCurrentTime) - <*> pure Nothing -- pid not stored in file, so omitted for speed - <*> pure Nothing -- tid ditto - <*> pure Nothing -- not 0; transfer may be resuming - <*> pure Nothing - <*> pure file - <*> pure False - meter <- liftIO $ progressupdater tfile info ok <- bracketIO (prep tfile mode info) (cleanup tfile) (a meter) unless ok $ failed info return ok @@ -122,16 +113,24 @@ runTransfer t file a = do failedtfile <- fromRepo $ failedTransferFile t createAnnexDirectory $ takeDirectory failedtfile liftIO $ writeTransferInfoFile info failedtfile - {- Updates transfer info file as transfer progresses. -} - progressupdater tfile info = do - mvar <- newMVar 0 - return $ \bytes -> modifyMVar_ mvar $ \oldbytes -> do - if (bytes - oldbytes >= mindelta) - then do - let info' = info { bytesComplete = Just bytes } - writeTransferInfoFile info' tfile - return bytes - else return oldbytes + + +{- Generates a callback that can be called as transfer progresses to update + - the transfer info file. Also returns the file it'll be updating. -} +mkProgressUpdater :: Transfer -> TransferInfo -> Annex (MeterUpdate, FilePath) +mkProgressUpdater t info = do + tfile <- fromRepo $ transferFile t + createAnnexDirectory $ takeDirectory tfile + mvar <- liftIO $ newMVar 0 + return (liftIO . updater tfile mvar, tfile) + where + updater tfile mvar bytes = modifyMVar_ mvar $ \oldbytes -> do + if (bytes - oldbytes >= mindelta) + then do + let info' = info { bytesComplete = Just bytes } + writeTransferInfoFile info' tfile + return bytes + else return oldbytes {- The minimum change in bytesComplete that is worth - updating a transfer info file for is 1% of the total - keySize, rounded down. -} @@ -139,6 +138,16 @@ runTransfer t file a = do Just sz -> sz `div` 100 Nothing -> 100 * 1024 -- arbitrarily, 100 kb +startTransferInfo :: Maybe FilePath -> IO TransferInfo +startTransferInfo file = TransferInfo + <$> (Just . utcTimeToPOSIXSeconds <$> getCurrentTime) + <*> pure Nothing -- pid not stored in file, so omitted for speed + <*> pure Nothing -- tid ditto + <*> pure Nothing -- not 0; transfer may be resuming + <*> pure Nothing + <*> pure file + <*> pure False + {- If a transfer is still running, returns its TransferInfo. -} checkTransfer :: Transfer -> Annex (Maybe TransferInfo) checkTransfer t = do @@ -192,7 +201,7 @@ removeFailedTransfer t = do {- The transfer information file to use for a given Transfer. -} transferFile :: Transfer -> Git.Repo -> FilePath transferFile (Transfer direction u key) r = transferDir direction r - </> fromUUID u + </> filter (/= '/') (fromUUID u) </> keyFile key {- The transfer information file to use to record a failed Transfer -} @@ -278,4 +287,4 @@ failedTransferDir :: UUID -> Direction -> Git.Repo -> FilePath failedTransferDir u direction r = gitAnnexTransferDir r </> "failed" </> showLcDirection direction - </> fromUUID u + </> filter (/= '/') (fromUUID u) diff --git a/Types/Key.hs b/Types/Key.hs index 619315aed..6794ee003 100644 --- a/Types/Key.hs +++ b/Types/Key.hs @@ -40,7 +40,7 @@ stubKey = Key { fieldSep :: Char fieldSep = '-' -{- Converts a key to a strings that are suitable for use as a filename. +{- Converts a key to a string that is suitable for use as a filename. - The name field is always shown last, separated by doubled fieldSeps, - and is the only field allowed to contain the fieldSep. -} key2file :: Key -> FilePath diff --git a/doc/git-annex-shell.mdwn b/doc/git-annex-shell.mdwn index 20a9d3d37..8256da0e3 100644 --- a/doc/git-annex-shell.mdwn +++ b/doc/git-annex-shell.mdwn @@ -46,6 +46,15 @@ first "/~/" or "/~user/" is expanded to the specified home directory. This runs rsync in server mode to transfer out the content of a key. +* transferinfo directory key uuid [file] + + This is typically run at the same time as sendkey is sending a key + to the remote with the specified uuid. + + It reads lines from standard input, each giving the number of bytes + that have been received so far. This is optional, but is used to update + progress information for the transfer of the key. + * commit directory This commits any staged changes to the git-annex branch. |