From b55efc179a32fc62901722c825fa3aa78b5ef8e5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 6 Dec 2023 13:04:32 -0400 Subject: [PATCH] add startAction parameter for KeySha I have a use planned for this in Command.Migrate. Sponsored-by: unqueued on Patreon --- CmdLine/Seek.hs | 23 +++++++++++++---------- Command/Copy.hs | 2 +- Command/Drop.hs | 2 +- Command/FilterBranch.hs | 2 +- Command/Find.hs | 2 +- Command/FindKeys.hs | 2 +- Command/Fix.hs | 2 +- Command/Fsck.hs | 2 +- Command/Get.hs | 2 +- Command/Inprogress.hs | 2 +- Command/List.hs | 2 +- Command/Lock.hs | 2 +- Command/Log.hs | 2 +- Command/MetaData.hs | 2 +- Command/Migrate.hs | 2 +- Command/Mirror.hs | 2 +- Command/Move.hs | 2 +- Command/Sync.hs | 2 +- Command/Unannex.hs | 2 +- Command/Unlock.hs | 2 +- Command/WhereUsed.hs | 2 +- Command/Whereis.hs | 2 +- 22 files changed, 34 insertions(+), 31 deletions(-) diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index 30aa5e4adb..620ff81da3 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -4,7 +4,7 @@ - the values a user passes to a command, and prepare actions operating - on them. - - - Copyright 2010-2022 Joey Hess + - Copyright 2010-2023 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -58,11 +58,14 @@ import System.PosixCompat.Files (isDirectory, isSymbolicLink, deviceID, fileID) import qualified System.FilePath.ByteString as P data AnnexedFileSeeker = AnnexedFileSeeker - { startAction :: SeekInput -> RawFilePath -> Key -> CommandStart + { startAction :: Maybe KeySha -> SeekInput -> RawFilePath -> Key -> CommandStart , checkContentPresent :: Maybe Bool , usesLocationLog :: Bool } +-- The Sha that was read to get the Key. +newtype KeySha = KeySha Git.Sha + withFilesInGitAnnex :: WarnUnmatchWhen -> AnnexedFileSeeker -> WorkTreeItems -> CommandSeek withFilesInGitAnnex ww a l = seekFilteredKeys a $ seekHelper fst3 ww LsFiles.inRepoDetails l @@ -375,9 +378,9 @@ seekFilteredKeys seeker listfs = do propagateLsFilesError cleanup where finisher mi oreader checktimelimit = liftIO oreader >>= \case - Just ((si, f), content) -> checktimelimit (liftIO discard) $ do - keyaction f mi content $ - commandAction . startAction seeker si f + Just ((si, f, keysha), content) -> checktimelimit (liftIO discard) $ do + keyaction f mi content $ + commandAction . startAction seeker keysha si f finisher mi oreader checktimelimit Nothing -> return () where @@ -386,12 +389,12 @@ seekFilteredKeys seeker listfs = do Just _ -> discard precachefinisher mi lreader checktimelimit = liftIO lreader >>= \case - Just ((logf, (si, f), k), logcontent) -> checktimelimit (liftIO discard) $ do + Just ((logf, (si, f, keysha), k), logcontent) -> checktimelimit (liftIO discard) $ do maybe noop (Annex.Branch.precache logf) logcontent checkMatcherWhen mi (matcherNeedsLocationLog mi && not (matcherNeedsFileName mi)) (MatchingFile $ FileInfo f f (Just k)) - (commandAction $ startAction seeker si f k) + (commandAction $ startAction seeker keysha si f k) precachefinisher mi lreader checktimelimit Nothing -> return () where @@ -400,11 +403,11 @@ seekFilteredKeys seeker listfs = do Just _ -> discard precacher mi config oreader lfeeder lcloser = liftIO oreader >>= \case - Just ((si, f), content) -> do + Just ((si, f, keysha), content) -> do keyaction f mi content $ \k -> let logf = locationLogFile config k ref = Git.Ref.branchFileRef Annex.Branch.fullname logf - in liftIO $ lfeeder ((logf, (si, f), k), ref) + in liftIO $ lfeeder ((logf, (si, f, keysha), k), ref) precacher mi config oreader lfeeder lcloser Nothing -> liftIO $ void lcloser @@ -415,7 +418,7 @@ seekFilteredKeys seeker listfs = do (not ((matcherNeedsKey mi || matcherNeedsLocationLog mi) && not (matcherNeedsFileName mi))) (MatchingFile $ FileInfo f f Nothing) - (liftIO $ ofeeder ((si, f), sha)) + (liftIO $ ofeeder ((si, f, Just (KeySha sha)), sha)) keyaction f mi content a = case parseLinkTargetOrPointerLazy =<< content of diff --git a/Command/Copy.hs b/Command/Copy.hs index 67971af2f4..8fe19e2ff9 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -63,7 +63,7 @@ seek' o fto = startConcurrency (Command.Move.stages fto) $ do ww = WarnUnmatchLsFiles "copy" seeker = AnnexedFileSeeker - { startAction = start o fto + { startAction = const $ start o fto , checkContentPresent = case fto of FromOrToRemote (FromRemote _) -> Just False FromOrToRemote (ToRemote _) -> Just True diff --git a/Command/Drop.hs b/Command/Drop.hs index 0de97c72e0..2fcb5d6ebb 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -60,7 +60,7 @@ seek o = startConcurrency commandStages $ do then pure Nothing else pure (Just remote) let seeker = AnnexedFileSeeker - { startAction = start o from + { startAction = const $ start o from , checkContentPresent = case from of Nothing -> Just True Just _ -> Nothing diff --git a/Command/FilterBranch.hs b/Command/FilterBranch.hs index 0e1b0a7514..10f03cccda 100644 --- a/Command/FilterBranch.hs +++ b/Command/FilterBranch.hs @@ -157,7 +157,7 @@ seek o = withOtherTmp $ \tmpdir -> do =<< Annex.Branch.get f next (return True) let seeker = AnnexedFileSeeker - { startAction = \_ _ k -> addkeyinfo k + { startAction = \_ _ _ k -> addkeyinfo k , checkContentPresent = Nothing , usesLocationLog = True } diff --git a/Command/Find.hs b/Command/Find.hs index d5971e3875..3a1fabe5e2 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -63,7 +63,7 @@ seek o = do checkNotBareRepo isterminal <- liftIO $ checkIsTerminal stdout seeker <- contentPresentUnlessLimited $ AnnexedFileSeeker - { startAction = start o isterminal + { startAction = const (start o isterminal) , checkContentPresent = Nothing , usesLocationLog = False } diff --git a/Command/FindKeys.hs b/Command/FindKeys.hs index e24075dacb..f105d7f8b9 100644 --- a/Command/FindKeys.hs +++ b/Command/FindKeys.hs @@ -33,7 +33,7 @@ seek o = do , usesLocationLog = False -- startAction is not actually used since this -- is not used to seek files - , startAction = \_ _ key -> start' o isterminal key + , startAction = \_ _ _ key -> start' o isterminal key } withKeyOptions (Just WantAllKeys) False seeker (commandAction . start o isterminal) diff --git a/Command/Fix.hs b/Command/Fix.hs index 6ca5f5b2b7..862853a861 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -37,7 +37,7 @@ seek ps = unlessM crippledFileSystem $ where ww = WarnUnmatchLsFiles "fix" seeker = AnnexedFileSeeker - { startAction = start FixAll + { startAction = const $ start FixAll , checkContentPresent = Nothing , usesLocationLog = False } diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 748f77ab01..545f0996b2 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -102,7 +102,7 @@ seek o = startConcurrency commandStages $ do checkDeadRepo u i <- prepIncremental u (incrementalOpt o) let seeker = AnnexedFileSeeker - { startAction = start from i + { startAction = const $ start from i , checkContentPresent = Nothing , usesLocationLog = True } diff --git a/Command/Get.hs b/Command/Get.hs index 2dd48456f4..c8f76568ed 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -41,7 +41,7 @@ seek :: GetOptions -> CommandSeek seek o = startConcurrency transferStages $ do from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o) let seeker = AnnexedFileSeeker - { startAction = start o from + { startAction = const $ start o from , checkContentPresent = Just False , usesLocationLog = True } diff --git a/Command/Inprogress.hs b/Command/Inprogress.hs index 8ab920242f..7b5f1482ea 100644 --- a/Command/Inprogress.hs +++ b/Command/Inprogress.hs @@ -42,7 +42,7 @@ seek o = do _ -> do let s = S.fromList ts let seeker = AnnexedFileSeeker - { startAction = start isterminal s + { startAction = const $ start isterminal s , checkContentPresent = Nothing , usesLocationLog = False } diff --git a/Command/List.hs b/Command/List.hs index b14c55d707..46185e6092 100644 --- a/Command/List.hs +++ b/Command/List.hs @@ -50,7 +50,7 @@ seek o = do list <- getList o printHeader list let seeker = AnnexedFileSeeker - { startAction = start list + { startAction = const $ start list , checkContentPresent = Nothing , usesLocationLog = True } diff --git a/Command/Lock.hs b/Command/Lock.hs index 7aace76c9b..cfd0846cd5 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -34,7 +34,7 @@ seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps where ww = WarnUnmatchLsFiles "lock" seeker = AnnexedFileSeeker - { startAction = start + { startAction = const start , checkContentPresent = Nothing , usesLocationLog = False } diff --git a/Command/Log.hs b/Command/Log.hs index 8605d5c3e7..e7f4de1bcf 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -138,7 +138,7 @@ seek o = ifM (null <$> Annex.Branch.getUnmergedRefs) zone <- liftIO getCurrentTimeZone outputter <- mkOutputter m zone o <$> jsonOutputEnabled let seeker = AnnexedFileSeeker - { startAction = start o outputter + { startAction = const $ start o outputter , checkContentPresent = Nothing -- the way this uses the location log would not be -- helped by precaching the current value diff --git a/Command/MetaData.hs b/Command/MetaData.hs index e07e5e99f2..e0a16c9249 100644 --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -77,7 +77,7 @@ seek o = case batchOption o of c <- currentVectorClock let ww = WarnUnmatchLsFiles "metadata" let seeker = AnnexedFileSeeker - { startAction = start c o + { startAction = const $ start c o , checkContentPresent = Nothing , usesLocationLog = False } diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 67cf69c2a8..9afa883df0 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -43,7 +43,7 @@ seek o = withFilesInGitAnnex ww seeker =<< workTreeItems ww (migrateThese o) where ww = WarnUnmatchLsFiles "migrate" seeker = AnnexedFileSeeker - { startAction = start o + { startAction = const $ start o , checkContentPresent = Nothing , usesLocationLog = False } diff --git a/Command/Mirror.hs b/Command/Mirror.hs index 8ec97e467f..d32a06790e 100644 --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -52,7 +52,7 @@ seek o = startConcurrency stages $ ToRemote _ -> commandStages ww = WarnUnmatchLsFiles "mirror" seeker = AnnexedFileSeeker - { startAction = start o + { startAction = const $ start o , checkContentPresent = Nothing , usesLocationLog = True } diff --git a/Command/Move.hs b/Command/Move.hs index 0bc707df85..056a7ca738 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -75,7 +75,7 @@ seek' o fto = startConcurrency (stages fto) $ do batchAnnexed fmt seeker keyaction where seeker = AnnexedFileSeeker - { startAction = start fto (removeWhen o) + { startAction = const $ start fto (removeWhen o) , checkContentPresent = case fto of FromOrToRemote (FromRemote _) -> Nothing FromOrToRemote (ToRemote _) -> Just True diff --git a/Command/Sync.hs b/Command/Sync.hs index 3a3d039a89..7feb796f91 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -842,7 +842,7 @@ seekSyncContent o rs currbranch = do where seekworktree mvar l bloomfeeder = do let seeker = AnnexedFileSeeker - { startAction = gofile bloomfeeder mvar + { startAction = const $ gofile bloomfeeder mvar , checkContentPresent = Nothing , usesLocationLog = True } diff --git a/Command/Unannex.hs b/Command/Unannex.hs index c6cb70793a..8eeae06d28 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -34,7 +34,7 @@ seek ps = withFilesInGitAnnex ww (seeker False) =<< workTreeItems ww ps seeker :: Bool -> AnnexedFileSeeker seeker fast = AnnexedFileSeeker - { startAction = start fast + { startAction = const $ start fast , checkContentPresent = Just True , usesLocationLog = False } diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 25e4d9aa04..c8faa7532f 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -35,7 +35,7 @@ seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps where ww = WarnUnmatchLsFiles "unlock" seeker = AnnexedFileSeeker - { startAction = start + { startAction = const start , checkContentPresent = Nothing , usesLocationLog = False } diff --git a/Command/WhereUsed.hs b/Command/WhereUsed.hs index 5f01c9c2a6..2119c02a66 100644 --- a/Command/WhereUsed.hs +++ b/Command/WhereUsed.hs @@ -49,7 +49,7 @@ seek o = withKeyOptions (Just (keyOptions o)) False dummyfileseeker (commandAction . start o) dummyfilecommandseek (WorkTreeItems []) where dummyfileseeker = AnnexedFileSeeker - { startAction = \_ _ _ -> return Nothing + { startAction = \_ _ _ _ -> return Nothing , checkContentPresent = Nothing , usesLocationLog = False } diff --git a/Command/Whereis.hs b/Command/Whereis.hs index c8ca119ed6..7c7edd1f4b 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -51,7 +51,7 @@ seek :: WhereisOptions -> CommandSeek seek o = do m <- remoteMap id let seeker = AnnexedFileSeeker - { startAction = start o m + { startAction = const $ start o m , checkContentPresent = Nothing , usesLocationLog = True } -- 2.30.2