plumb MeterUpdate into getKey

No behavior changes, but this shows everywhere that a progress meter
could be displayed when hashing a file to add to the annex.

Many of the places don't make sense to display a progress meter though,
eg when importing the copy of the file probably swamps the hashing of
the file.

Annex/Direct.hs

@@ -40,6 +40,7 @@ import Git.Index
 import Annex.GitOverlay
 import Annex.LockFile
 import Annex.InodeSentinal
+import Utility.Metered
 
 {- Uses git ls-files to find files that need to be committed, and stages
  - them into the index. Returns True if some changes were staged. -}
@@ -130,7 +131,7 @@ addDirect file cache = do
 		, contentLocation = file
 		, inodeCache = Just cache
 		}
-	got =<< genKey source =<< chooseBackend file
+	got =<< genKey source nullMeterUpdate=<< chooseBackend file
   where
 	got Nothing = do
 		showEndFail

Annex/Import.hs

@@ -42,6 +42,7 @@ import Types.Key
 import Types.KeySource
 import Messages.Progress
 import Utility.DataUnits
+import Utility.Metered
 import Logs.Export
 import Logs.Location
 import Logs.PreferredContent
@@ -373,7 +374,7 @@ downloadImport remote importtreeconfig importablecontents = do
 			, contentLocation = tmpfile
 			, inodeCache = Nothing
 			}
-		fmap fst <$> genKey ks backend
+		fmap fst <$> genKey ks nullMeterUpdate backend
 
 	locworktreefilename loc = asTopFilePath $ case importtreeconfig of
 		ImportTree -> fromImportLocation loc

Annex/Ingest.hs

@@ -1,6 +1,6 @@
 {- git-annex content ingestion
  -
- - Copyright 2010-2017 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -44,6 +44,7 @@ import Annex.ReplaceFile
 import Utility.Tmp
 import Utility.CopyFile
 import Utility.Touch
+import Utility.Metered
 import Git.FilePath
 import Annex.InodeSentinal
 import Annex.AdjustedBranch
@@ -123,13 +124,13 @@ lockDown' cfg file = tryIO $ ifM crippledFileSystem
 
 {- Ingests a locked down file into the annex. Updates the work tree and
  - index. -}
-ingestAdd :: Maybe LockedDown -> Annex (Maybe Key)
+ingestAdd :: MeterUpdate -> Maybe LockedDown -> Annex (Maybe Key)
-ingestAdd ld = ingestAdd' ld Nothing
+ingestAdd meterupdate ld = ingestAdd' meterupdate ld Nothing
 
-ingestAdd' :: Maybe LockedDown -> Maybe Key -> Annex (Maybe Key)
+ingestAdd' :: MeterUpdate -> Maybe LockedDown -> Maybe Key -> Annex (Maybe Key)
-ingestAdd' Nothing _ = return Nothing
+ingestAdd' _ Nothing _ = return Nothing
-ingestAdd' ld@(Just (LockedDown cfg source)) mk = do
+ingestAdd' meterupdate ld@(Just (LockedDown cfg source)) mk = do
-	(mk', mic) <- ingest ld mk
+	(mk', mic) <- ingest meterupdate ld mk
 	case mk' of
 		Nothing -> return Nothing
 		Just k -> do
@@ -148,16 +149,16 @@ ingestAdd' ld@(Just (LockedDown cfg source)) mk = do
 
 {- Ingests a locked down file into the annex. Does not update the working
  - tree or the index. -}
-ingest :: Maybe LockedDown -> Maybe Key -> Annex (Maybe Key, Maybe InodeCache)
+ingest :: MeterUpdate -> Maybe LockedDown -> Maybe Key -> Annex (Maybe Key, Maybe InodeCache)
-ingest ld mk = ingest' Nothing ld mk (Restage True)
+ingest meterupdate ld mk = ingest' Nothing meterupdate ld mk (Restage True)
 
-ingest' :: Maybe Backend -> Maybe LockedDown -> Maybe Key -> Restage -> Annex (Maybe Key, Maybe InodeCache)
+ingest' :: Maybe Backend -> MeterUpdate -> Maybe LockedDown -> Maybe Key -> Restage -> Annex (Maybe Key, Maybe InodeCache)
-ingest' _ Nothing _ _ = return (Nothing, Nothing)
+ingest' _ _ Nothing _ _ = return (Nothing, Nothing)
-ingest' preferredbackend (Just (LockedDown cfg source)) mk restage = withTSDelta $ \delta -> do
+ingest' preferredbackend meterupdate (Just (LockedDown cfg source)) mk restage = withTSDelta $ \delta -> do
 	k <- case mk of
 		Nothing -> do
 			backend <- maybe (chooseBackend $ keyFilename source) (return . Just) preferredbackend
-			fmap fst <$> genKey source backend
+			fmap fst <$> genKey source meterupdate backend
 		Just k -> return (Just k)
 	let src = contentLocation source
 	ms <- liftIO $ catchMaybeIO $ getFileStatus src

Assistant/Threads/Committer.hs

@@ -41,6 +41,7 @@ import qualified Database.Keys
 import qualified Command.Sync
 import qualified Git.Branch
 import Utility.Tuple
+import Utility.Metered
 
 import Data.Time.Clock
 import qualified Data.Set as S
@@ -331,7 +332,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do
 		doadd = sanitycheck ks $ do
 			(mkey, mcache) <- liftAnnex $ do
 				showStart "add" $ keyFilename ks
-				ingest (Just $ LockedDown lockdownconfig ks) Nothing
+				ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing
 			maybe (failedingest change) (done change mcache $ keyFilename ks) mkey
 	add _ _ = return Nothing
 

Backend.hs

@@ -22,6 +22,7 @@ import Annex.CheckAttr
 import Types.Key
 import Types.KeySource
 import qualified Types.Backend as B
+import Utility.Metered
 
 -- When adding a new backend, import it here and add it to the list.
 import qualified Backend.Hash
@@ -50,10 +51,10 @@ defaultBackend = maybe cache return =<< Annex.getState Annex.backend
 	lookupname = lookupBackendVariety . parseKeyVariety . encodeBS
 
 {- Generates a key for a file. -}
-genKey :: KeySource -> Maybe Backend -> Annex (Maybe (Key, Backend))
+genKey :: KeySource -> MeterUpdate -> Maybe Backend -> Annex (Maybe (Key, Backend))
-genKey source preferredbackend = do
+genKey source meterupdate preferredbackend = do
 	b <- maybe defaultBackend return preferredbackend
-	B.getKey b source >>= return . \case
+	B.getKey b source meterupdate >>= return . \case
 		Nothing -> Nothing
 		Just k -> Just (makesane k, b)
   where

Backend/Hash.hs

@@ -19,6 +19,7 @@ import Types.Key
 import Types.Backend
 import Types.KeySource
 import Utility.Hash
+import Utility.Metered
 
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as S8
@@ -86,8 +87,8 @@ hashKeyVariety (Blake2spHash size) he = Blake2spKey size he
 #endif
 
 {- A key is a hash of its contents. -}
-keyValue :: Hash -> KeySource -> Annex (Maybe Key)
+keyValue :: Hash -> KeySource -> MeterUpdate -> Annex (Maybe Key)
-keyValue hash source = do
+keyValue hash source meterupate = do
 	let file = contentLocation source
 	filesize <- liftIO $ getFileSize file
 	s <- hashFile hash file
@@ -98,8 +99,9 @@ keyValue hash source = do
 		}
 
 {- Extension preserving keys. -}
-keyValueE :: Hash -> KeySource -> Annex (Maybe Key)
+keyValueE :: Hash -> KeySource -> MeterUpdate -> Annex (Maybe Key)
-keyValueE hash source = keyValue hash source >>= maybe (return Nothing) addE
+keyValueE hash source meterupdate =
+	keyValue hash source meterupdate >>= maybe (return Nothing) addE
   where
 	addE k = do
 		maxlen <- annexMaxExtensionLength <$> Annex.getGitConfig
@@ -286,7 +288,7 @@ md5Hasher = show . md5
 testKeyBackend :: Backend
 testKeyBackend = 
 	let b = genBackendE (SHA2Hash (HashSize 256))
-	in b { getKey = (fmap addE) <$$> getKey b } 
+	in b { getKey = \ks p -> (fmap addE) <$> getKey b ks p } 
   where
 	addE k = k { keyName = keyName k <> longext }
 	longext = ".this-is-a-test-key"

Backend/URL.hs

@@ -21,7 +21,7 @@ backends = [backend]
 backend :: Backend
 backend = Backend
 	{ backendVariety = URLKey
-	, getKey = const $ return Nothing
+	, getKey = \_ _ -> return Nothing
 	, verifyKeyContent = Nothing
 	, canUpgradeKey = Nothing
 	, fastMigrate = Nothing

Backend/WORM.hs

@@ -13,6 +13,7 @@ import Types.Backend
 import Types.KeySource
 import Backend.Utilities
 import Git.FilePath
+import Utility.Metered
 
 import qualified Data.ByteString.Char8 as S8
 
@@ -32,8 +33,8 @@ backend = Backend
 {- The key includes the file size, modification time, and the
  - original filename relative to the top of the git repository.
  -}
-keyValue :: KeySource -> Annex (Maybe Key)
+keyValue :: KeySource -> MeterUpdate -> Annex (Maybe Key)
-keyValue source = do
+keyValue source _ = do
 	let f = contentLocation source
 	stat <- liftIO $ getFileStatus f
 	sz <- liftIO $ getFileSize' f stat

Command/Add.hs

@@ -21,6 +21,7 @@ import Annex.Link
 import Annex.Version
 import Annex.Tmp
 import Git.FilePath
+import Utility.Metered
 
 cmd :: Command
 cmd = notBareRepo $ 
@@ -141,7 +142,7 @@ perform file = withOtherTmp $ \tmpdir -> do
 		{ lockingFile = lockingfile
 		, hardlinkFileTmpDir = Just tmpdir
 		}
-	lockDown cfg file >>= ingestAdd >>= finish
+	lockDown cfg file >>= ingestAdd nullMeterUpdate >>= finish
   where
 	finish (Just key) = next $ cleanup key True
 	finish Nothing = stop

Command/AddUrl.hs

@@ -372,7 +372,7 @@ finishDownloadWith tmp u url file = do
 		, contentLocation = tmp
 		, inodeCache = Nothing
 		}
-	genKey source backend >>= \case
+	genKey source nullMeterUpdate backend >>= \case
 		Nothing -> return Nothing
 		Just (key, _) -> do
 			addWorkTree u url file key (Just tmp)

Command/CalcKey.hs

@@ -10,6 +10,7 @@ module Command.CalcKey where
 import Command
 import Backend (genKey)
 import Types.KeySource
+import Utility.Metered
 
 cmd :: Command
 cmd = noCommit $ noMessages $ dontCheck repoExists $
@@ -19,7 +20,7 @@ cmd = noCommit $ noMessages $ dontCheck repoExists $
 		(batchable run (pure ()))
 
 run :: () -> String -> Annex Bool
-run _ file = genKey (KeySource file file Nothing) Nothing >>= \case
+run _ file = genKey (KeySource file file Nothing) nullMeterUpdate Nothing >>= \case
 	Just (k, _) -> do
 		liftIO $ putStrLn $ serializeKey k
 		return True

Command/Import.hs

@@ -32,6 +32,7 @@ import Git.FilePath
 import Git.Types
 import Git.Branch
 import Types.Import
+import Utility.Metered
 
 import Control.Concurrent.STM
 
@@ -198,7 +199,7 @@ startLocal largematcher mode (srcfile, destfile) =
 				}
 			}
 		ifM (checkFileMatcher largematcher destfile)
-			( ingestAdd' (Just ld') (Just k)
+			( ingestAdd' nullMeterUpdate (Just ld') (Just k)
 				>>= maybe
 					stop
 					(\addedk -> next $ Command.Add.cleanup addedk True)
@@ -219,7 +220,7 @@ startLocal largematcher mode (srcfile, destfile) =
 		case v of
 			Just ld -> do
 				backend <- chooseBackend destfile
-				v' <- genKey (keySource ld) backend
+				v' <- genKey (keySource ld) nullMeterUpdate backend
 				case v' of
 					Just (k, _) -> a (ld, k)
 					Nothing -> giveup "failed to generate a key"

Command/Migrate.hs

@@ -17,6 +17,7 @@ import qualified Command.Fsck
 import qualified Annex
 import Logs.MetaData
 import Logs.Web
+import Utility.Metered
 
 cmd :: Command
 cmd = notDirect $ withGlobalOptions [annexedMatchingOptions] $
@@ -88,7 +89,7 @@ perform file oldkey oldbackend newbackend = go =<< genkey (fastMigrate oldbacken
 			, contentLocation = content
 			, inodeCache = Nothing
 			}
-		v <- genKey source (Just newbackend)
+		v <- genKey source nullMeterUpdate (Just newbackend)
 		return $ case v of
 			Just (newkey, _) -> Just (newkey, False)
 			_ -> Nothing

Command/Reinject.hs

@@ -12,6 +12,7 @@ import Logs.Location
 import Annex.Content
 import Backend
 import Types.KeySource
+import Utility.Metered
 
 cmd :: Command
 cmd = command "reinject" SectionUtility 
@@ -53,7 +54,7 @@ startSrcDest _ = giveup "specify a src file and a dest file"
 startKnown :: FilePath -> CommandStart
 startKnown src = notAnnexed src $
 	starting "reinject" (ActionItemOther (Just src)) $ do
-		mkb <- genKey (KeySource src src Nothing) Nothing
+		mkb <- genKey (KeySource src src Nothing) nullMeterUpdate Nothing
 		case mkb of
 			Nothing -> error "Failed to generate key"
 			Just (key, _) -> ifM (isKnownKey key)

Command/Smudge.hs

@@ -21,6 +21,7 @@ import Git.FilePath
 import qualified Git
 import qualified Git.Ref
 import Backend
+import Utility.Metered
 
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
@@ -122,7 +123,7 @@ clean file = do
 		let norestage = Restage False
 		liftIO . emitPointer
 			=<< postingest
-			=<< (\ld -> ingest' oldbackend ld Nothing norestage)
+			=<< (\ld -> ingest' oldbackend nullMeterUpdate ld Nothing norestage)
 			=<< lockDown cfg file
 
 	postingest (Just k, _) = do

Command/TestRemote.hs

@@ -320,7 +320,7 @@ randKey sz = withTmpFile "randkey" $ \f h -> do
 		, inodeCache = Nothing
 		}
 	k <- fromMaybe (error "failed to generate random key")
-		<$> Backend.getKey Backend.Hash.testKeyBackend ks
+		<$> Backend.getKey Backend.Hash.testKeyBackend ks nullMeterUpdate
 	_ <- moveAnnex k f
 	return k
 

Test/Framework.hs

@@ -41,6 +41,7 @@ import qualified Utility.Env.Set
 import qualified Utility.Exception
 import qualified Utility.ThreadScheduler
 import qualified Utility.Tmp.Dir
+import qualified Utility.Metered
 import qualified Command.Uninit
 import qualified CmdLine.GitAnnex as GitAnnex
 
@@ -567,9 +568,9 @@ backend_ = Backend.lookupBackendVariety . Types.Key.parseKeyVariety . encodeBS
 getKey :: Types.Backend -> FilePath -> IO Types.Key
 getKey b f = fromJust <$> annexeval go
   where
-	go = Types.Backend.getKey b
+	go = Types.Backend.getKey b ks Utility.Metered.nullMeterUpdate
-		Types.KeySource.KeySource
+	ks = Types.KeySource.KeySource
-			{ Types.KeySource.keyFilename = f
+		{ Types.KeySource.keyFilename = f
-			, Types.KeySource.contentLocation = f
+		, Types.KeySource.contentLocation = f
-			, Types.KeySource.inodeCache = Nothing
+		, Types.KeySource.inodeCache = Nothing
-			}
+		}

Types/Backend.hs

@@ -2,7 +2,7 @@
  -
  - Most things should not need this, using Types instead
  -
- - Copyright 2010-2017 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -12,11 +12,12 @@ module Types.Backend where
 import Types.Key
 import Types.KeySource
 
+import Utility.Metered
 import Utility.FileSystemEncoding
 
 data BackendA a = Backend
 	{ backendVariety :: KeyVariety
-	, getKey :: KeySource -> a (Maybe Key) 
+	, getKey :: KeySource -> MeterUpdate -> a (Maybe Key) 
 	-- Verifies the content of a key.
 	, verifyKeyContent :: Maybe (Key -> FilePath -> a Bool)
 	-- Checks if a key can be upgraded to a better form.