add startAction parameter for KeySha

I have a use planned for this in Command.Migrate.

Sponsored-by: unqueued on Patreon

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 <id@joeyh.name>
+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>
  -
  - 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

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

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

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
 			}

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
 		}

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)

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
 		}

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
 		}

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
 		}

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
 				}

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
 		}

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
 		}

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

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
 			}

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
 		}

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
 		}

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

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
 			}

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
 	}

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
 		}

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
 		}

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
 		}