summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--BuildFlags.hs2
-rw-r--r--Command/Fsck.hs4
-rw-r--r--Command/TestRemote.hs2
-rw-r--r--Messages/Progress.hs62
-rw-r--r--Remote/BitTorrent.hs4
-rw-r--r--Remote/Bup.hs4
-rw-r--r--Remote/Ddar.hs4
-rw-r--r--Remote/Directory.hs10
-rw-r--r--Remote/External.hs2
-rw-r--r--Remote/GCrypt.hs2
-rw-r--r--Remote/Git.hs13
-rw-r--r--Remote/Glacier.hs4
-rw-r--r--Remote/Helper/Hooks.hs2
-rw-r--r--Remote/Helper/Special.hs20
-rw-r--r--Remote/Hook.hs4
-rw-r--r--Remote/Rsync.hs4
-rw-r--r--Remote/S3.hs4
-rw-r--r--Remote/Tahoe.hs2
-rw-r--r--Remote/Web.hs4
-rw-r--r--Remote/WebDAV.hs4
-rw-r--r--Types/Remote.hs2
21 files changed, 85 insertions, 74 deletions
diff --git a/BuildFlags.hs b/BuildFlags.hs
index 7ae526f63..a0f0ac298 100644
--- a/BuildFlags.hs
+++ b/BuildFlags.hs
@@ -84,7 +84,7 @@ buildFlags = filter (not . null)
#ifdef WITH_TORRENTPARSER
, "TorrentParser"
#else
-#warning Building without haskell torrent library; will instead use btshowmetainfo to parse torrent files.
+
#endif
#ifdef WITH_EKG
, "EKG"
diff --git a/Command/Fsck.hs b/Command/Fsck.hs
index 08753b612..54f20f5e8 100644
--- a/Command/Fsck.hs
+++ b/Command/Fsck.hs
@@ -135,11 +135,11 @@ performRemote key file backend numcopies remote =
cleanup
cleanup `after` a tmp
getfile tmp =
- ifM (Remote.retrieveKeyFileCheap remote key tmp)
+ ifM (Remote.retrieveKeyFileCheap remote key (Just file) tmp)
( return True
, ifM (Annex.getState Annex.fast)
( return False
- , Remote.retrieveKeyFile remote key Nothing tmp dummymeter
+ , Remote.retrieveKeyFile remote key (Just file) tmp dummymeter
)
)
dummymeter _ = noop
diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs
index 4a65aa4ec..b0f2c28bb 100644
--- a/Command/TestRemote.hs
+++ b/Command/TestRemote.hs
@@ -171,7 +171,7 @@ testUnavailable st r k =
Remote.retrieveKeyFile r k Nothing dest nullMeterUpdate
, check (== Right False) "retrieveKeyFileCheap" $
getViaTmp k $ \dest ->
- Remote.retrieveKeyFileCheap r k dest
+ Remote.retrieveKeyFileCheap r k Nothing dest
]
where
check checkval desc a = testCase desc $ do
diff --git a/Messages/Progress.hs b/Messages/Progress.hs
index 70ed96c5a..20c713e06 100644
--- a/Messages/Progress.hs
+++ b/Messages/Progress.hs
@@ -20,40 +20,38 @@ import Control.Concurrent
{- Shows a progress meter while performing a transfer of a key.
- The action is passed a callback to use to update the meter. -}
-metered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a
-metered combinemeterupdate key a = go (keySize key)
+metered :: Maybe MeterUpdate -> Key -> AssociatedFile -> (MeterUpdate -> Annex a) -> Annex a
+metered combinemeterupdate key af a = case keySize key of
+ Nothing -> nometer
+ Just size -> withOutputType (go $ fromInteger size)
where
- go (Just size) = meteredBytes combinemeterupdate size a
- go _ = a (const noop)
-
-{- Use when the progress meter is only desired for parallel
- - mode; as when a command's own progress output is preferred. -}
-parallelMetered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a
-parallelMetered combinemeterupdate key a = withOutputType go
- where
- go (ParallelOutput _) = metered combinemeterupdate key a
- go _ = a (fromMaybe (const noop) combinemeterupdate)
-
-{- Shows a progress meter while performing an action on a given number
- - of bytes. -}
-meteredBytes :: Maybe MeterUpdate -> Integer -> (MeterUpdate -> Annex a) -> Annex a
-meteredBytes combinemeterupdate size a = withOutputType go
- where
- go QuietOutput = nometer
- go JSONOutput = nometer
- go _ = do
+ go _ QuietOutput = nometer
+ go _ JSONOutput = nometer
+ go size _ = do
showOutput
liftIO $ putStrLn ""
+
+ let desc = truncatepretty 79 $ fromMaybe (key2file key) af
+
+ result <- liftIO newEmptyMVar
pg <- liftIO $ newProgressBar def
{ pgWidth = 79
- , pgFormat = ":percent :bar ETA :eta"
- , pgTotal = fromInteger size
+ , pgFormat = desc ++ " :percent :bar ETA :eta"
+ , pgTotal = size
+ , pgOnCompletion = do
+ ok <- takeMVar result
+ putStrLn $ desc ++ " " ++
+ if ok then "ok" else "failed"
}
r <- a $ liftIO . pupdate pg
- -- may not be actually complete if the action failed,
- -- but this just clears the progress bar
- liftIO $ complete pg
+ liftIO $ do
+ -- See if the progress bar is complete or not.
+ sofar <- stCompleted <$> getProgressStats pg
+ putMVar result (sofar >= size)
+ -- May not be actually complete if the action failed,
+ -- but this just clears the progress bar.
+ complete pg
return r
@@ -67,6 +65,18 @@ meteredBytes combinemeterupdate size a = withOutputType go
nometer = a (const noop)
+ truncatepretty n s
+ | length s > n = take (n-2) s ++ ".."
+ | otherwise = s
+
+{- Use when the progress meter is only desired for parallel
+ - mode; as when a command's own progress output is preferred. -}
+parallelMetered :: Maybe MeterUpdate -> Key -> AssociatedFile -> (MeterUpdate -> Annex a) -> Annex a
+parallelMetered combinemeterupdate key af a = withOutputType go
+ where
+ go (ParallelOutput _) = metered combinemeterupdate key af a
+ go _ = a (fromMaybe (const noop) combinemeterupdate)
+
{- Progress dots. -}
showProgressDots :: Annex ()
showProgressDots = handleMessage q $
diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs
index baba2e23e..05326e390 100644
--- a/Remote/BitTorrent.hs
+++ b/Remote/BitTorrent.hs
@@ -93,8 +93,8 @@ downloadKey key _file dest p =
, return False
)
-downloadKeyCheap :: Key -> FilePath -> Annex Bool
-downloadKeyCheap _ _ = return False
+downloadKeyCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
+downloadKeyCheap _ _ _ = return False
uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool
uploadKey _ _ _ = do
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 42f17e921..b3152afcf 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -148,8 +148,8 @@ retrieve buprepo = byteRetriever $ \k sink -> do
liftIO (hClose h >> forceSuccessProcess p pid)
`after` (sink =<< liftIO (L.hGetContents h))
-retrieveCheap :: BupRepo -> Key -> FilePath -> Annex Bool
-retrieveCheap _ _ _ = return False
+retrieveCheap :: BupRepo -> Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieveCheap _ _ _ _ = return False
{- Cannot revert having stored a key in bup, but at least the data for the
- key will be used for deltaing data of other keys stored later.
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index 7495fcd42..a24960935 100644
--- a/Remote/Ddar.hs
+++ b/Remote/Ddar.hs
@@ -142,8 +142,8 @@ retrieve ddarrepo = byteRetriever $ \k sink -> do
liftIO (hClose h >> forceSuccessProcess p pid)
`after` (sink =<< liftIO (L.hGetContents h))
-retrieveCheap :: Key -> FilePath -> Annex Bool
-retrieveCheap _ _ = return False
+retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieveCheap _ _ _ = return False
remove :: DdarRepo -> Remover
remove ddarrepo key = do
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 2eeb79317..f210f557d 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -156,17 +156,17 @@ retrieve d (LegacyChunks _) = Legacy.retrieve locations d
retrieve d _ = simplyPrepare $ byteRetriever $ \k sink ->
sink =<< liftIO (L.readFile =<< getLocation d k)
-retrieveCheap :: FilePath -> ChunkConfig -> Key -> FilePath -> Annex Bool
+retrieveCheap :: FilePath -> ChunkConfig -> Key -> AssociatedFile -> FilePath -> Annex Bool
-- no cheap retrieval possible for chunks
-retrieveCheap _ (UnpaddedChunks _) _ _ = return False
-retrieveCheap _ (LegacyChunks _) _ _ = return False
+retrieveCheap _ (UnpaddedChunks _) _ _ _ = return False
+retrieveCheap _ (LegacyChunks _) _ _ _ = return False
#ifndef mingw32_HOST_OS
-retrieveCheap d NoChunks k f = liftIO $ catchBoolIO $ do
+retrieveCheap d NoChunks k _af f = liftIO $ catchBoolIO $ do
file <- getLocation d k
createSymbolicLink file f
return True
#else
-retrieveCheap _ _ _ _ = return False
+retrieveCheap _ _ _ _ _ = return False
#endif
remove :: FilePath -> Remover
diff --git a/Remote/External.hs b/Remote/External.hs
index adfd79113..d09e1f9b3 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -56,7 +56,7 @@ gen r u c gc = do
, name = Git.repoDescribe r
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
- , retrieveKeyFileCheap = \_ _ -> return False
+ , retrieveKeyFileCheap = \_ _ _ -> return False
, removeKey = removeKeyDummy
, checkPresent = checkPresentDummy
, checkPresentCheap = False
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index c27519825..7685418b0 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -108,7 +108,7 @@ gen' r u c gc = do
, name = Git.repoDescribe r
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
- , retrieveKeyFileCheap = \_ _ -> return False
+ , retrieveKeyFileCheap = \_ _ _ -> return False
, removeKey = removeKeyDummy
, checkPresent = checkPresentDummy
, checkPresentCheap = repoCheap r
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 373299c2d..2807c62fb 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -355,7 +355,7 @@ dropKey r key
{- Tries to copy a key's content from a remote's annex to a file. -}
copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
-copyFromRemote r key file dest p = parallelMetered (Just p) key $
+copyFromRemote r key file dest p = parallelMetered (Just p) key file $
copyFromRemote' r key file dest
copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
@@ -447,26 +447,27 @@ copyFromRemote' r key file dest meterupdate
=<< tryTakeMVar pidv
bracketIO noop (const cleanup) (const $ a feeder)
-copyFromRemoteCheap :: Remote -> Key -> FilePath -> Annex Bool
+copyFromRemoteCheap :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
#ifndef mingw32_HOST_OS
-copyFromRemoteCheap r key file
+copyFromRemoteCheap r key af file
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ do
loc <- liftIO $ gitAnnexLocation key (repo r) $
fromJust $ remoteGitConfig $ gitconfig r
liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True
| Git.repoIsSsh (repo r) =
ifM (Annex.Content.preseedTmp key file)
- ( parallelMetered Nothing key $ copyFromRemote' r key Nothing file
+ ( parallelMetered Nothing key af $
+ copyFromRemote' r key af file
, return False
)
| otherwise = return False
#else
-copyFromRemoteCheap _ _ _ = return False
+copyFromRemoteCheap _ _ _ _ = return False
#endif
{- Tries to copy a key's content to a remote's annex. -}
copyToRemote :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
-copyToRemote r key file p = parallelMetered (Just p) key $ copyToRemote' r key file
+copyToRemote r key file p = parallelMetered (Just p) key file $ copyToRemote' r key file
copyToRemote' :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
copyToRemote' r key file p
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index 289008266..75b264bac 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -162,8 +162,8 @@ retrieve r k sink = go =<< glacierEnv c u
showLongNote "Recommend you wait up to 4 hours, and then run this command again."
return ok
-retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
-retrieveCheap _ _ _ = return False
+retrieveCheap :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieveCheap _ _ _ _ = return False
remove :: Remote -> Remover
remove r k = glacierAction r
diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs
index 3765281be..53bb370a6 100644
--- a/Remote/Helper/Hooks.hs
+++ b/Remote/Helper/Hooks.hs
@@ -36,7 +36,7 @@ addHooks' r starthook stophook = r'
r' = r
{ storeKey = \k f p -> wrapper $ storeKey r k f p
, retrieveKeyFile = \k f d p -> wrapper $ retrieveKeyFile r k f d p
- , retrieveKeyFileCheap = \k f -> wrapper $ retrieveKeyFileCheap r k f
+ , retrieveKeyFileCheap = \k af f -> wrapper $ retrieveKeyFileCheap r k af f
, removeKey = wrapper . removeKey r
, checkPresent = wrapper . checkPresent r
}
diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs
index 696a43a7a..c11584bb8 100644
--- a/Remote/Helper/Special.hs
+++ b/Remote/Helper/Special.hs
@@ -157,10 +157,10 @@ specialRemote' :: SpecialRemoteCfg -> RemoteModifier
specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckpresent baser = encr
where
encr = baser
- { storeKey = \k _f p -> cip >>= storeKeyGen k p
- , retrieveKeyFile = \k _f d p -> cip >>= retrieveKeyFileGen k d p
- , retrieveKeyFileCheap = \k d -> cip >>= maybe
- (retrieveKeyFileCheap baser k d)
+ { storeKey = \k f p -> cip >>= storeKeyGen k f p
+ , retrieveKeyFile = \k f d p -> cip >>= retrieveKeyFileGen k f d p
+ , retrieveKeyFileCheap = \k f d -> cip >>= maybe
+ (retrieveKeyFileCheap baser k f d)
-- retrieval of encrypted keys is never cheap
(\_ -> return False)
, removeKey = \k -> cip >>= removeKeyGen k
@@ -182,10 +182,10 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
safely a = catchNonAsync a (\e -> warning (show e) >> return False)
-- chunk, then encrypt, then feed to the storer
- storeKeyGen k p enc = safely $ preparestorer k $ safely . go
+ storeKeyGen k f p enc = safely $ preparestorer k $ safely . go
where
go (Just storer) = sendAnnex k rollback $ \src ->
- displayprogress p k $ \p' ->
+ displayprogress p k f $ \p' ->
storeChunks (uuid baser) chunkconfig k src p'
(storechunk enc storer)
(checkPresent baser)
@@ -200,10 +200,10 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
storer (enck k) (ByteContent encb) p
-- call retrieve-r to get chunks; decrypt them; stream to dest file
- retrieveKeyFileGen k dest p enc =
+ retrieveKeyFileGen k f dest p enc =
safely $ prepareretriever k $ safely . go
where
- go (Just retriever) = displayprogress p k $ \p' ->
+ go (Just retriever) = displayprogress p k f $ \p' ->
retrieveChunks retriever (uuid baser) chunkconfig
enck k dest p' (sink dest enc)
go Nothing = return False
@@ -223,8 +223,8 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
chunkconfig = chunkConfig cfg
- displayprogress p k a
- | displayProgress cfg = metered (Just p) k a
+ displayprogress p k f a
+ | displayProgress cfg = metered (Just p) k f a
| otherwise = a p
{- Sink callback for retrieveChunks. Stores the file content into the
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 6df326295..9abc4e303 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -130,8 +130,8 @@ retrieve h = fileRetriever $ \d k _p ->
unlessM (runHook h "retrieve" k (Just d) $ return True) $
error "failed to retrieve content"
-retrieveCheap :: HookName -> Key -> FilePath -> Annex Bool
-retrieveCheap _ _ _ = return False
+retrieveCheap :: HookName -> Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieveCheap _ _ _ _ = return False
remove :: HookName -> Remover
remove h k = runHook h "remove" k Nothing $ return True
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index a882e081d..2c8b17884 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -191,8 +191,8 @@ retrieve o f k p =
unlessM (rsyncRetrieve o k f (Just p)) $
error "rsync failed"
-retrieveCheap :: RsyncOpts -> Key -> FilePath -> Annex Bool
-retrieveCheap o k f = ifM (preseedTmp k f) ( rsyncRetrieve o k f Nothing , return False )
+retrieveCheap :: RsyncOpts -> Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieveCheap o k _af f = ifM (preseedTmp k f) ( rsyncRetrieve o k f Nothing , return False )
remove :: RsyncOpts -> Remover
remove o k = do
diff --git a/Remote/S3.hs b/Remote/S3.hs
index b0c1de114..83d35035e 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -241,8 +241,8 @@ retrieve h = fileRetriever $ \f k p -> liftIO $ runResourceT $ do
S.hPut fh bs
sinkprogressfile fh meterupdate sofar'
-retrieveCheap :: Key -> FilePath -> Annex Bool
-retrieveCheap _ _ = return False
+retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieveCheap _ _ _ = return False
{- Internet Archive doesn't easily allow removing content.
- While it may remove the file, there are generally other files
diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs
index 56bf66427..ca822d4fd 100644
--- a/Remote/Tahoe.hs
+++ b/Remote/Tahoe.hs
@@ -70,7 +70,7 @@ gen r u c gc = do
, name = Git.repoDescribe r
, storeKey = store u hdl
, retrieveKeyFile = retrieve u hdl
- , retrieveKeyFileCheap = \_ _ -> return False
+ , retrieveKeyFileCheap = \_ _ _ -> return False
, removeKey = remove
, checkPresent = checkKey u hdl
, checkPresentCheap = False
diff --git a/Remote/Web.hs b/Remote/Web.hs
index a4a484ca3..102972b02 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -90,8 +90,8 @@ downloadKey key _file dest _p = get =<< getWebUrls key
#endif
_ -> downloadUrl [u'] dest
-downloadKeyCheap :: Key -> FilePath -> Annex Bool
-downloadKeyCheap _ _ = return False
+downloadKeyCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
+downloadKeyCheap _ _ _ = return False
uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool
uploadKey _ _ _ = do
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index aaebecf41..3c414f003 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -116,8 +116,8 @@ finalizeStore baseurl tmp dest = do
maybe noop (void . mkColRecursive) (locationParent dest)
moveDAV baseurl tmp dest
-retrieveCheap :: Key -> FilePath -> Annex Bool
-retrieveCheap _ _ = return False
+retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieveCheap _ _ _ = return False
retrieve :: ChunkConfig -> Maybe DavHandle -> Retriever
retrieve _ Nothing = error "unable to connect"
diff --git a/Types/Remote.hs b/Types/Remote.hs
index 5df08c775..87a964ca7 100644
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -67,7 +67,7 @@ data RemoteA a = Remote {
-- directly to the file, and not to an intermediate file.)
retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> a Bool,
-- retrieves a key's contents to a tmp file, if it can be done cheaply
- retrieveKeyFileCheap :: Key -> FilePath -> a Bool,
+ retrieveKeyFileCheap :: Key -> AssociatedFile -> FilePath -> a Bool,
-- removes a key's contents (succeeds if the contents are not present)
removeKey :: Key -> a Bool,
-- Checks if a key is present in the remote.
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-28 20:34:47 +0000