add filename to progress bar, and display ok/failed at end

This needed plumbing an AssociatedFile through retrieveKeyFileCheap.

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"

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

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

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 :: Maybe MeterUpdate -> Key -> AssociatedFile -> (MeterUpdate -> Annex a) -> Annex a
-metered combinemeterupdate key a = go (keySize key)
+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 _ QuietOutput = nometer
-	go _ = a (const noop)
+	go _ JSONOutput = nometer
-
+	go size _ = do
-{- 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
 		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"
+			, pgFormat = desc ++ " :percent :bar ETA :eta"
-			, pgTotal = fromInteger size
+			, 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,
+		liftIO $ do
-		-- but this just clears the progress bar
+			-- See if the progress bar is complete or not.
-		liftIO $ complete pg
+			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 $

Remote/BitTorrent.hs

@@ -93,8 +93,8 @@ downloadKey key _file dest p =
 				, return False
 				)
 
-downloadKeyCheap :: Key -> FilePath -> Annex Bool
+downloadKeyCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
-downloadKeyCheap _ _ = return False
+downloadKeyCheap _ _ _ = return False
 
 uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool
 uploadKey _ _ _ = do

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 :: BupRepo -> Key -> AssociatedFile -> FilePath -> Annex Bool
-retrieveCheap _ _ _ = return False
+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.

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 :: Key -> AssociatedFile -> FilePath -> Annex Bool
-retrieveCheap _ _ = return False
+retrieveCheap _ _ _ = return False
 
 remove :: DdarRepo -> Remover
 remove ddarrepo key = do

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 _ (UnpaddedChunks _) _ _ _ = return False
-retrieveCheap _ (LegacyChunks _) _ _ = 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

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

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

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

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 :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
-retrieveCheap _ _ _ = return False
+retrieveCheap _ _ _ _ = return False
 
 remove :: Remote -> Remover
 remove r k = glacierAction r

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
 		}

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
+		{ storeKey = \k f p -> cip >>= storeKeyGen k f p
-		, retrieveKeyFile = \k _f d p -> cip >>= retrieveKeyFileGen k d p
+		, retrieveKeyFile = \k f d p -> cip >>= retrieveKeyFileGen k f d p
-		, retrieveKeyFileCheap = \k d -> cip >>= maybe
+		, retrieveKeyFileCheap = \k f d -> cip >>= maybe
-			(retrieveKeyFileCheap baser k d)
+			(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 p k f a
-		| displayProgress cfg = metered (Just p) k a
+		| displayProgress cfg = metered (Just p) k f a
 		| otherwise = a p
 
 {- Sink callback for retrieveChunks. Stores the file content into the

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 :: HookName -> Key -> AssociatedFile -> FilePath -> Annex Bool
-retrieveCheap _ _ _ = return False
+retrieveCheap _ _ _ _ = return False
 
 remove :: HookName -> Remover
 remove h k = runHook h "remove" k Nothing $ return True

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 :: RsyncOpts -> Key -> AssociatedFile -> FilePath -> Annex Bool
-retrieveCheap o k f = ifM (preseedTmp k f) ( rsyncRetrieve o k f Nothing , return False )
+retrieveCheap o k _af f = ifM (preseedTmp k f) ( rsyncRetrieve o k f Nothing , return False )
 
 remove :: RsyncOpts -> Remover
 remove o k = do

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 :: Key -> AssociatedFile -> FilePath -> Annex Bool
-retrieveCheap _ _ = return False
+retrieveCheap _ _ _ = return False
 
 {- Internet Archive doesn't easily allow removing content.
  - While it may remove the file, there are generally other files

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

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 :: Key -> AssociatedFile -> FilePath -> Annex Bool
-downloadKeyCheap _ _ = return False
+downloadKeyCheap _ _ _ = return False
 
 uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool
 uploadKey _ _ _ = do

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 :: Key -> AssociatedFile -> FilePath -> Annex Bool
-retrieveCheap _ _ = return False
+retrieveCheap _ _ _ = return False
 
 retrieve :: ChunkConfig -> Maybe DavHandle -> Retriever
 retrieve _ Nothing = error "unable to connect"

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.