git-annex-shell transferinfo command

TODO: Use this when running sendkey, to feed back transfer info from the
client side rsync.
This commit is contained in:
Joey Hess 2012-09-21 16:23:25 -04:00
parent 34ca1d698c
commit 77af38ec6c
5 changed files with 104 additions and 24 deletions

60
Command/TransferInfo.hs Normal file
View file

@ -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
]

View file

@ -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]

View file

@ -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)

View file

@ -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

View file

@ -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.