From 8355dba5cce173ca0b0080cdd0a811465539cd0e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 25 Jun 2019 11:37:52 -0400 Subject: [PATCH] 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 | 3 ++- Annex/Import.hs | 3 ++- Annex/Ingest.hs | 27 ++++++++++++++------------- Assistant/Threads/Committer.hs | 3 ++- Backend.hs | 7 ++++--- Backend/Hash.hs | 12 +++++++----- Backend/URL.hs | 2 +- Backend/WORM.hs | 5 +++-- Command/Add.hs | 3 ++- Command/AddUrl.hs | 2 +- Command/CalcKey.hs | 3 ++- Command/Import.hs | 5 +++-- Command/Migrate.hs | 3 ++- Command/Reinject.hs | 3 ++- Command/Smudge.hs | 3 ++- Command/TestRemote.hs | 2 +- Test/Framework.hs | 13 +++++++------ Types/Backend.hs | 5 +++-- 18 files changed, 60 insertions(+), 44 deletions(-) diff --git a/Annex/Direct.hs b/Annex/Direct.hs index 6c766f6b8e..458f0e5c25 100644 --- a/Annex/Direct.hs +++ b/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 diff --git a/Annex/Import.hs b/Annex/Import.hs index bb15fb7b6b..e6472aa4b4 100644 --- a/Annex/Import.hs +++ b/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 diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs index 41bb15a33e..376aa46c74 100644 --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -1,6 +1,6 @@ {- git-annex content ingestion - - - Copyright 2010-2017 Joey Hess + - Copyright 2010-2019 Joey Hess - - 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 ld = ingestAdd' ld Nothing +ingestAdd :: MeterUpdate -> Maybe LockedDown -> Annex (Maybe Key) +ingestAdd meterupdate ld = ingestAdd' meterupdate ld Nothing -ingestAdd' :: Maybe LockedDown -> Maybe Key -> Annex (Maybe Key) -ingestAdd' Nothing _ = return Nothing -ingestAdd' ld@(Just (LockedDown cfg source)) mk = do - (mk', mic) <- ingest ld mk +ingestAdd' :: MeterUpdate -> Maybe LockedDown -> Maybe Key -> Annex (Maybe Key) +ingestAdd' _ Nothing _ = return Nothing +ingestAdd' meterupdate ld@(Just (LockedDown cfg source)) mk = do + (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 ld mk = ingest' Nothing ld mk (Restage True) +ingest :: MeterUpdate -> Maybe LockedDown -> Maybe Key -> Annex (Maybe Key, Maybe InodeCache) +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' _ Nothing _ _ = return (Nothing, Nothing) -ingest' preferredbackend (Just (LockedDown cfg source)) mk restage = withTSDelta $ \delta -> do +ingest' :: Maybe Backend -> MeterUpdate -> Maybe LockedDown -> Maybe Key -> Restage -> Annex (Maybe Key, Maybe InodeCache) +ingest' _ _ Nothing _ _ = return (Nothing, Nothing) +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 diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 0552557117..865f7b0ca5 100644 --- a/Assistant/Threads/Committer.hs +++ b/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 diff --git a/Backend.hs b/Backend.hs index f198bac9a7..2b2962ff90 100644 --- a/Backend.hs +++ b/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 source preferredbackend = do +genKey :: KeySource -> MeterUpdate -> Maybe Backend -> Annex (Maybe (Key, Backend)) +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 diff --git a/Backend/Hash.hs b/Backend/Hash.hs index 9f2bc55727..1f12f742f0 100644 --- a/Backend/Hash.hs +++ b/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 source = do +keyValue :: Hash -> KeySource -> MeterUpdate -> Annex (Maybe Key) +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 source = keyValue hash source >>= maybe (return Nothing) addE +keyValueE :: Hash -> KeySource -> MeterUpdate -> Annex (Maybe Key) +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" diff --git a/Backend/URL.hs b/Backend/URL.hs index 62a516fcce..aad6c87db8 100644 --- a/Backend/URL.hs +++ b/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 diff --git a/Backend/WORM.hs b/Backend/WORM.hs index a03bbb9293..5455951d9e 100644 --- a/Backend/WORM.hs +++ b/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 source = do +keyValue :: KeySource -> MeterUpdate -> Annex (Maybe Key) +keyValue source _ = do let f = contentLocation source stat <- liftIO $ getFileStatus f sz <- liftIO $ getFileSize' f stat diff --git a/Command/Add.hs b/Command/Add.hs index 73c836f417..3a44a612b1 100644 --- a/Command/Add.hs +++ b/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 diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 71a412438e..2c363148ad 100644 --- a/Command/AddUrl.hs +++ b/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) diff --git a/Command/CalcKey.hs b/Command/CalcKey.hs index f894aee40b..f50006e469 100644 --- a/Command/CalcKey.hs +++ b/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 diff --git a/Command/Import.hs b/Command/Import.hs index ad96fdb56c..0a77642789 100644 --- a/Command/Import.hs +++ b/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" diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 1cdca17800..3bc7c08146 100644 --- a/Command/Migrate.hs +++ b/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 diff --git a/Command/Reinject.hs b/Command/Reinject.hs index 428b9ff988..df975531ce 100644 --- a/Command/Reinject.hs +++ b/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) diff --git a/Command/Smudge.hs b/Command/Smudge.hs index e1cd5917f7..aa6b4d2107 100644 --- a/Command/Smudge.hs +++ b/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 diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 813ae7e048..5232d91bef 100644 --- a/Command/TestRemote.hs +++ b/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 diff --git a/Test/Framework.hs b/Test/Framework.hs index e8421b04bc..f1e90a8f39 100644 --- a/Test/Framework.hs +++ b/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 - Types.KeySource.KeySource - { Types.KeySource.keyFilename = f - , Types.KeySource.contentLocation = f - , Types.KeySource.inodeCache = Nothing - } + go = Types.Backend.getKey b ks Utility.Metered.nullMeterUpdate + ks = Types.KeySource.KeySource + { Types.KeySource.keyFilename = f + , Types.KeySource.contentLocation = f + , Types.KeySource.inodeCache = Nothing + } diff --git a/Types/Backend.hs b/Types/Backend.hs index 704de04981..d1dfe6124e 100644 --- a/Types/Backend.hs +++ b/Types/Backend.hs @@ -2,7 +2,7 @@ - - Most things should not need this, using Types instead - - - Copyright 2010-2017 Joey Hess + - Copyright 2010-2019 Joey Hess - - 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.