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:
parent
34ca1d698c
commit
77af38ec6c
5 changed files with 104 additions and 24 deletions
|
@ -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)
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue