summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Command/RecvKey.hs2
-rw-r--r--Command/SendKey.hs8
-rw-r--r--Command/TransferKey.hs4
-rw-r--r--Logs/Transfer.hs50
-rw-r--r--Remote/Bup.hs8
-rw-r--r--Remote/Directory.hs8
-rw-r--r--Remote/Git.hs10
-rw-r--r--Remote/Helper/Encryptable.hs8
-rw-r--r--Remote/Helper/Hooks.hs2
-rw-r--r--Remote/Hook.hs8
-rw-r--r--Remote/Rsync.hs8
-rw-r--r--Remote/S3.hs8
-rw-r--r--Remote/Web.hs4
-rw-r--r--Types/Remote.hs6
14 files changed, 75 insertions, 59 deletions
diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs
index 49f0d9e98..07e0eab80 100644
--- a/Command/RecvKey.hs
+++ b/Command/RecvKey.hs
@@ -25,7 +25,7 @@ seek = [withKeys start]
start :: Key -> CommandStart
start key = ifM (inAnnex key)
( error "key is already present in annex"
- , fieldTransfer Download key $ do
+ , fieldTransfer Download key $ \p -> do
ifM (getViaTmp key $ liftIO . rsyncServerReceive)
( do
-- forcibly quit after receiving one key,
diff --git a/Command/SendKey.hs b/Command/SendKey.hs
index 6fcbf7075..79cc61876 100644
--- a/Command/SendKey.hs
+++ b/Command/SendKey.hs
@@ -12,6 +12,7 @@ import Command
import Annex.Content
import Utility.Rsync
import Logs.Transfer
+import Types.Remote
import qualified Fields
def :: [Command]
@@ -23,7 +24,7 @@ seek = [withKeys start]
start :: Key -> CommandStart
start key = ifM (inAnnex key)
- ( fieldTransfer Upload key $ do
+ ( fieldTransfer Upload key $ \p -> do
file <- inRepo $ gitAnnexLocation key
liftIO $ rsyncServerSend file
, do
@@ -31,10 +32,11 @@ start key = ifM (inAnnex key)
liftIO exitFailure
)
-fieldTransfer :: Direction -> Key -> Annex Bool -> CommandStart
+fieldTransfer :: Direction -> Key -> (ProgressCallback -> Annex Bool) -> CommandStart
fieldTransfer direction key a = do
afile <- Fields.getField Fields.associatedFile
- ok <- maybe a (\u -> runTransfer (Transfer direction (toUUID u) key) afile a)
+ ok <- maybe (a $ const noop)
+ (\u -> runTransfer (Transfer direction (toUUID u) key) afile a)
=<< Fields.getField Fields.remoteUUID
if ok
then liftIO exitSuccess
diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs
index ed6fbb68c..793dbeb56 100644
--- a/Command/TransferKey.hs
+++ b/Command/TransferKey.hs
@@ -43,8 +43,8 @@ start to from file key =
toPerform :: Remote -> Key -> AssociatedFile -> CommandPerform
toPerform remote key file = next $
- upload (uuid remote) key file $ do
- ok <- Remote.storeKey remote key file
+ upload (uuid remote) key file $ \p -> do
+ ok <- Remote.storeKey remote key file p
when ok $
Remote.logStatus remote key InfoPresent
return ok
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index 8aac5f7d5..d7f7a8d16 100644
--- a/Logs/Transfer.hs
+++ b/Logs/Transfer.hs
@@ -74,11 +74,11 @@ percentComplete :: Transfer -> TransferInfo -> Maybe Percentage
percentComplete (Transfer { transferKey = key }) info =
percentage <$> keySize key <*> Just (fromMaybe 0 $ bytesComplete info)
-upload :: UUID -> Key -> AssociatedFile -> Annex Bool -> Annex Bool
+upload :: UUID -> Key -> AssociatedFile -> (ProgressCallback -> Annex Bool) -> Annex Bool
upload u key file a = runTransfer (Transfer Upload u key) file a
download :: UUID -> Key -> AssociatedFile -> Annex Bool -> Annex Bool
-download u key file a = runTransfer (Transfer Download u key) file a
+download u key file a = runTransfer (Transfer Download u key) file (const a)
{- Runs a transfer action. Creates and locks the lock file while the
- action is running, and stores info in the transfer information
@@ -87,7 +87,7 @@ download u key file a = runTransfer (Transfer Download u key) file a
- If the transfer action returns False, the transfer info is
- left in the failedTransferDir.
-}
-runTransfer :: Transfer -> Maybe FilePath -> Annex Bool -> Annex Bool
+runTransfer :: Transfer -> Maybe FilePath -> (ProgressCallback -> Annex Bool) -> Annex Bool
runTransfer t file a = do
tfile <- fromRepo $ transferFile t
createAnnexDirectory $ takeDirectory tfile
@@ -100,7 +100,9 @@ runTransfer t file a = do
<*> pure Nothing
<*> pure file
<*> pure False
- ok <- bracketIO (prep tfile mode info) (cleanup tfile) a
+ ok <- bracketIO (prep tfile mode info) (cleanup tfile) $ a $ \bytes ->
+ writeTransferInfoFile (info { bytesComplete = Just bytes }) tfile
+
unless ok $ failed info
return ok
where
@@ -208,12 +210,16 @@ writeTransferInfoFile info tfile = do
hPutStr h $ writeTransferInfo info
hClose h
+{- File format is a header line containing the startedTime and any
+ - bytesComplete value. Followed by a newline and the associatedFile.
+ -
+ - The transferPid is not included; instead it is obtained by looking
+ - at the process that locks the file.
+ -}
writeTransferInfo :: TransferInfo -> String
writeTransferInfo info = unlines
- -- transferPid is not included; instead obtained by looking at
- -- the process that locks the file.
- [ maybe "" show $ startedTime info
- -- bytesComplete is not included; changes too fast
+ [ (maybe "" show $ startedTime info) ++
+ (maybe "" (\b -> " " ++ show b) $ bytesComplete info)
, fromMaybe "" $ associatedFile info -- comes last; arbitrary content
]
@@ -224,20 +230,24 @@ readTransferInfoFile mpid tfile = do
hClose h `after` (readTransferInfo mpid <$> hGetContentsStrict h)
readTransferInfo :: (Maybe ProcessID) -> String -> Maybe TransferInfo
-readTransferInfo mpid s =
- case bits of
- [time] -> TransferInfo
- <$> (Just <$> parsePOSIXTime time)
- <*> pure mpid
- <*> pure Nothing
- <*> pure Nothing
- <*> pure Nothing
- <*> pure (if null filename then Nothing else Just filename)
- <*> pure False
- _ -> Nothing
+readTransferInfo mpid s = TransferInfo
+ <$> time
+ <*> pure mpid
+ <*> pure Nothing
+ <*> pure Nothing
+ <*> bytes
+ <*> pure (if null filename then Nothing else Just filename)
+ <*> pure False
where
- (bits, filebits) = splitAt 1 $ lines s
+ (bits, filebits) = splitAt 1 $ lines s
filename = join "\n" filebits
+ numbits = length bits
+ time = if numbits > 0
+ then Just <$> parsePOSIXTime (bits !! 0)
+ else pure Nothing
+ bytes = if numbits > 1
+ then Just <$> readish (bits !! 1)
+ else pure Nothing
parsePOSIXTime :: String -> Maybe POSIXTime
parsePOSIXTime s = utcTimeToPOSIXSeconds
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index e3ba7fe9b..fb4e5a48c 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -113,14 +113,14 @@ bupSplitParams r buprepo k src = do
return $ bupParams "split" buprepo
(os ++ [Param "-n", Param (bupRef k), src])
-store :: Git.Repo -> BupRepo -> Key -> AssociatedFile -> Annex Bool
-store r buprepo k _f = do
+store :: Git.Repo -> BupRepo -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool
+store r buprepo k _f p = do
src <- inRepo $ gitAnnexLocation k
params <- bupSplitParams r buprepo k (File src)
liftIO $ boolSystem "bup" params
-storeEncrypted :: Git.Repo -> BupRepo -> (Cipher, Key) -> Key -> Annex Bool
-storeEncrypted r buprepo (cipher, enck) k = do
+storeEncrypted :: Git.Repo -> BupRepo -> (Cipher, Key) -> Key -> ProgressCallback -> Annex Bool
+storeEncrypted r buprepo (cipher, enck) k p = do
src <- inRepo $ gitAnnexLocation k
params <- bupSplitParams r buprepo enck (Param "-")
liftIO $ catchBoolIO $
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 0ec564ca1..2bf44634d 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -124,8 +124,8 @@ withCheckedFiles check (Just _) d k a = go $ locations d k
withStoredFiles :: ChunkSize -> FilePath -> Key -> ([FilePath] -> IO Bool) -> IO Bool
withStoredFiles = withCheckedFiles doesFileExist
-store :: FilePath -> ChunkSize -> Key -> AssociatedFile -> Annex Bool
-store d chunksize k _f = do
+store :: FilePath -> ChunkSize -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool
+store d chunksize k _f p = do
src <- inRepo $ gitAnnexLocation k
metered k $ \meterupdate ->
storeHelper d chunksize k $ \dests ->
@@ -139,8 +139,8 @@ store d chunksize k _f = do
storeSplit meterupdate chunksize dests
=<< L.readFile src
-storeEncrypted :: FilePath -> ChunkSize -> (Cipher, Key) -> Key -> Annex Bool
-storeEncrypted d chunksize (cipher, enck) k = do
+storeEncrypted :: FilePath -> ChunkSize -> (Cipher, Key) -> Key -> ProgressCallback -> Annex Bool
+storeEncrypted d chunksize (cipher, enck) k p = do
src <- inRepo $ gitAnnexLocation k
metered k $ \meterupdate ->
storeHelper d chunksize enck $ \dests ->
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 626476c18..46f65ac74 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -262,8 +262,8 @@ copyFromRemoteCheap r key file
| otherwise = return False
{- Tries to copy a key's content to a remote's annex. -}
-copyToRemote :: Git.Repo -> Key -> AssociatedFile -> Annex Bool
-copyToRemote r key file
+copyToRemote :: Git.Repo -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool
+copyToRemote r key file p
| not $ Git.repoIsUrl r = guardUsable r False $ commitOnCleanup r $ do
keysrc <- inRepo $ gitAnnexLocation key
params <- rsyncParams r
@@ -276,7 +276,7 @@ copyToRemote r key file
download u key file $
Annex.Content.saveState True `after`
Annex.Content.getViaTmp key
- (rsyncOrCopyFile params keysrc)
+ (\d -> rsyncOrCopyFile params keysrc d p)
)
| Git.repoIsSsh r = commitOnCleanup r $ do
keysrc <- inRepo $ gitAnnexLocation key
@@ -295,8 +295,8 @@ rsyncHelper p = do
{- Copys a file with rsync unless both locations are on the same
- filesystem. Then cp could be faster. -}
-rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> Annex Bool
-rsyncOrCopyFile rsyncparams src dest =
+rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> ProgressCallback -> Annex Bool
+rsyncOrCopyFile rsyncparams src dest p =
ifM (sameDeviceIds src dest)
( liftIO $ copyFileExternal src dest
, rsyncHelper $ rsyncparams ++ [Param src, Param dest]
diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs
index 6d5405d9e..e3cb40df4 100644
--- a/Remote/Helper/Encryptable.hs
+++ b/Remote/Helper/Encryptable.hs
@@ -45,7 +45,7 @@ encryptionSetup c = case (M.lookup "encryption" c, extractCipher c) of
- to support storing and retrieving encrypted content. -}
encryptableRemote
:: Maybe RemoteConfig
- -> ((Cipher, Key) -> Key -> Annex Bool)
+ -> ((Cipher, Key) -> Key -> ProgressCallback -> Annex Bool)
-> ((Cipher, Key) -> Key -> FilePath -> Annex Bool)
-> Remote
-> Remote
@@ -59,9 +59,9 @@ encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r =
cost = cost r + encryptedRemoteCostAdj
}
where
- store k f = cip k >>= maybe
- (storeKey r k f)
- (`storeKeyEncrypted` k)
+ store k f p = cip k >>= maybe
+ (storeKey r k f p)
+ (\enck -> storeKeyEncrypted enck k p)
retrieve k f d = cip k >>= maybe
(retrieveKeyFile r k f d)
(\enck -> retrieveKeyFileEncrypted enck k d)
diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs
index 0a6b22081..eb788bc3e 100644
--- a/Remote/Helper/Hooks.hs
+++ b/Remote/Helper/Hooks.hs
@@ -27,7 +27,7 @@ addHooks' r Nothing Nothing = r
addHooks' r starthook stophook = r'
where
r' = r
- { storeKey = \k f -> wrapper $ storeKey r k f
+ { storeKey = \k f p -> wrapper $ storeKey r k f p
, retrieveKeyFile = \k f d -> wrapper $ retrieveKeyFile r k f d
, retrieveKeyFileCheap = \k f -> wrapper $ retrieveKeyFileCheap r k f
, removeKey = \k -> wrapper $ removeKey r k
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index c73a8deb8..cf0425590 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -103,13 +103,13 @@ runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype h
return False
)
-store :: String -> Key -> AssociatedFile -> Annex Bool
-store h k _f = do
+store :: String -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool
+store h k _f _p = do
src <- inRepo $ gitAnnexLocation k
runHook h "store" k (Just src) $ return True
-storeEncrypted :: String -> (Cipher, Key) -> Key -> Annex Bool
-storeEncrypted h (cipher, enck) k = withTmp enck $ \tmp -> do
+storeEncrypted :: String -> (Cipher, Key) -> Key -> ProgressCallback -> Annex Bool
+storeEncrypted h (cipher, enck) k _p = withTmp enck $ \tmp -> do
src <- inRepo $ gitAnnexLocation k
liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp
runHook h "store" enck (Just tmp) $ return True
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 3655ce483..aba427d4b 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -104,11 +104,11 @@ rsyncUrls o k = map use annexHashes
use h = rsyncUrl o </> h k </> rsyncEscape o (f </> f)
f = keyFile k
-store :: RsyncOpts -> Key -> AssociatedFile -> Annex Bool
-store o k _f = rsyncSend o k <=< inRepo $ gitAnnexLocation k
+store :: RsyncOpts -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool
+store o k _f p = rsyncSend o k <=< inRepo $ gitAnnexLocation k
-storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> Annex Bool
-storeEncrypted o (cipher, enck) k = withTmp enck $ \tmp -> do
+storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> ProgressCallback -> Annex Bool
+storeEncrypted o (cipher, enck) k p = withTmp enck $ \tmp -> do
src <- inRepo $ gitAnnexLocation k
liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp
rsyncSend o enck tmp
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 4efdb3071..12eb96add 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -115,14 +115,14 @@ s3Setup u c = handlehost $ M.lookup "host" c
-- be human-readable
M.delete "bucket" defaults
-store :: Remote -> Key -> AssociatedFile -> Annex Bool
-store r k _f = s3Action r False $ \(conn, bucket) -> do
+store :: Remote -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool
+store r k _f p = s3Action r False $ \(conn, bucket) -> do
dest <- inRepo $ gitAnnexLocation k
res <- liftIO $ storeHelper (conn, bucket) r k dest
s3Bool res
-storeEncrypted :: Remote -> (Cipher, Key) -> Key -> Annex Bool
-storeEncrypted r (cipher, enck) k = s3Action r False $ \(conn, bucket) ->
+storeEncrypted :: Remote -> (Cipher, Key) -> Key -> ProgressCallback -> Annex Bool
+storeEncrypted r (cipher, enck) k p = s3Action r False $ \(conn, bucket) ->
-- To get file size of the encrypted content, have to use a temp file.
-- (An alternative would be chunking to to a constant size.)
withTmp enck $ \tmp -> do
diff --git a/Remote/Web.hs b/Remote/Web.hs
index 2001e6ce8..58d95f7f1 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -66,8 +66,8 @@ downloadKey key _file dest = get =<< getUrls key
downloadKeyCheap :: Key -> FilePath -> Annex Bool
downloadKeyCheap _ _ = return False
-uploadKey :: Key -> AssociatedFile -> Annex Bool
-uploadKey _ _ = do
+uploadKey :: Key -> AssociatedFile -> ProgressCallback -> Annex Bool
+uploadKey _ _ _ = do
warning "upload to web not supported"
return False
diff --git a/Types/Remote.hs b/Types/Remote.hs
index 5e2e566e5..b89972fdd 100644
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -36,6 +36,10 @@ instance Eq (RemoteTypeA a) where
{- A filename associated with a Key, for display to user. -}
type AssociatedFile = Maybe FilePath
+{- An action that can be run repeatedly, feeding it the number of
+ - bytes sent or retreived so far. -}
+type ProgressCallback = (Integer -> IO ())
+
{- An individual remote. -}
data RemoteA a = Remote {
-- each Remote has a unique uuid
@@ -45,7 +49,7 @@ data RemoteA a = Remote {
-- Remotes have a use cost; higher is more expensive
cost :: Int,
-- Transfers a key to the remote.
- storeKey :: Key -> AssociatedFile -> a Bool,
+ storeKey :: Key -> AssociatedFile -> ProgressCallback -> a Bool,
-- retrieves a key's contents to a file
retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> a Bool,
-- retrieves a key's contents to a tmp file, if it can be done cheaply
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-29 10:13:40 +0000