diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs index e42c2a8c7b..f1d9eda298 100644 --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -43,9 +43,6 @@ performCommandAction Command { cmdcheck = c, cmdname = name } seek cont = do commandActions :: [CommandStart] -> Annex () commandActions = mapM_ commandAction -commandAction' :: (a -> b -> CommandStart) -> a -> b -> Annex () -commandAction' start a b = commandAction $ start a b - {- Runs one of the actions needed to perform a command. - Individual actions can fail without stopping the whole command, - including by throwing non-async exceptions. diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs index 4218cec086..14c8409193 100644 --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -1,6 +1,6 @@ {- git-annex batch commands - - - Copyright 2015 Joey Hess + - Copyright 2015-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -11,10 +11,13 @@ import Annex.Common import Types.Command import CmdLine.Action import CmdLine.GitAnnex.Options +import CmdLine.Seek import Options.Applicative import Limit import Types.FileMatcher import Annex.BranchState +import Annex.WorkTree +import Annex.Content data BatchMode = Batch BatchFormat | NoBatch @@ -110,12 +113,22 @@ batchStart fmt a = batchInput fmt (Right <$$> liftIO . relPathCwdToFile) $ -- Like batchStart, but checks the file matching options -- and skips non-matching files. -batchFilesMatching :: BatchFormat -> (FilePath -> CommandStart) -> Annex () +batchFilesMatching :: BatchFormat -> (RawFilePath -> CommandStart) -> Annex () batchFilesMatching fmt a = do matcher <- getMatcher batchStart fmt $ \f -> let f' = toRawFilePath f in ifM (matcher $ MatchingFile $ FileInfo f' f') - ( a f + ( a f' , return Nothing ) + +batchAnnexedFilesMatching :: BatchFormat -> AnnexedFileSeeker -> Annex () +batchAnnexedFilesMatching fmt seeker = batchFilesMatching fmt $ + whenAnnexed $ \f k -> case checkContentPresent seeker of + Just v -> do + present <- inAnnex k + if (present == v) + then startAction seeker f k + else return Nothing + Nothing -> startAction seeker f k diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index f6a74ec25f..b289569606 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -44,12 +44,13 @@ import qualified Annex.BranchState import qualified Database.Keys import qualified Utility.RawFilePath as R import Utility.Tuple +import CmdLine.Action import Control.Concurrent.Async import System.Posix.Types data AnnexedFileSeeker = AnnexedFileSeeker - { seekAction :: RawFilePath -> Key -> CommandSeek + { startAction :: RawFilePath -> Key -> CommandStart , checkContentPresent :: Maybe Bool , usesLocationLog :: Bool } @@ -305,7 +306,8 @@ seekFilteredKeys seeker listfs = do Just (f, content) -> do case parseLinkTargetOrPointerLazy =<< content of Just k -> checkpresence k $ - seekAction seeker f k + commandAction $ + startAction seeker f k Nothing -> noop finisher oreader Nothing -> return () @@ -313,7 +315,7 @@ seekFilteredKeys seeker listfs = do precachefinisher lreader = liftIO lreader >>= \case Just ((logf, f, k), logcontent) -> do maybe noop (Annex.BranchState.setCache logf) logcontent - seekAction seeker f k + commandAction $ startAction seeker f k precachefinisher lreader Nothing -> return () diff --git a/Command/Add.hs b/Command/Add.hs index 4e33727b25..858fd4821f 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -80,7 +80,7 @@ seek o = startConcurrency commandStages $ do Batch fmt | updateOnly o -> giveup "--update --batch is not supported" - | otherwise -> batchFilesMatching fmt (gofile . toRawFilePath) + | otherwise -> batchFilesMatching fmt gofile NoBatch -> do -- Avoid git ls-files complaining about files that -- are not known to git yet, since this will add diff --git a/Command/Copy.hs b/Command/Copy.hs index e58573b42b..cd3a781c80 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -45,22 +45,21 @@ instance DeferredParseClass CopyOptions where seek :: CopyOptions -> CommandSeek seek o = startConcurrency commandStages $ do - let go = start o - let seeker = AnnexedFileSeeker - { seekAction = commandAction' go - , checkContentPresent = Nothing - , usesLocationLog = False - } case batchOption o of - Batch fmt -> batchFilesMatching fmt - (whenAnnexed go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) (autoMode o) (commandAction . Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever) (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (copyFiles o) + Batch fmt -> batchAnnexedFilesMatching fmt seeker where ww = WarnUnmatchLsFiles + + seeker = AnnexedFileSeeker + { startAction = start o + , checkContentPresent = Nothing + , usesLocationLog = False + } {- A copy is just a move that does not delete the source file. - However, auto mode avoids unnecessary copies, and avoids getting or diff --git a/Command/Drop.hs b/Command/Drop.hs index e8b80554ac..9b0f2aa6fe 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -54,18 +54,16 @@ parseDropFromOption = parseRemoteOption <$> strOption seek :: DropOptions -> CommandSeek seek o = startConcurrency commandStages $ case batchOption o of - Batch fmt -> batchFilesMatching fmt - (whenAnnexed go . toRawFilePath) + Batch fmt -> batchAnnexedFilesMatching fmt seeker NoBatch -> withKeyOptions (keyOptions o) (autoMode o) (commandAction . startKeys o) (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (dropFiles o) where - go = start o ww = WarnUnmatchLsFiles seeker = AnnexedFileSeeker - { seekAction = commandAction' go + { startAction = start o , checkContentPresent = Nothing , usesLocationLog = False } diff --git a/Command/Find.hs b/Command/Find.hs index 337ad110fd..2a6b171fc4 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -18,7 +18,6 @@ import Types.Key import Git.FilePath import qualified Utility.Format import Utility.DataUnits -import Annex.Content cmd :: Command cmd = notBareRepo $ withGlobalOptions [annexedMatchingOptions] $ mkCommand $ @@ -54,27 +53,24 @@ parseFormatOption = ) seek :: FindOptions -> CommandSeek -seek o = case batchOption o of - NoBatch -> do - islimited <- limited - let seeker = AnnexedFileSeeker - { seekAction = commandAction' go - -- only files with content present are shown, unless - -- the user has requested others via a limit - , checkContentPresent = if islimited - then Nothing - else Just True - , usesLocationLog = False - } - withKeyOptions (keyOptions o) False +seek o = do + islimited <- limited + let seeker = AnnexedFileSeeker + { startAction = start o + -- only files with content present are shown, unless + -- the user has requested others via a limit + , checkContentPresent = if islimited + then Nothing + else Just True + , usesLocationLog = False + } + case batchOption o of + NoBatch -> withKeyOptions (keyOptions o) False (commandAction . startKeys o) (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (findThese o) - Batch fmt -> batchFilesMatching fmt - (whenAnnexed gobatch . toRawFilePath) + Batch fmt -> batchAnnexedFilesMatching fmt seeker where - go = start o - gobatch f k = stopUnless (limited <||> inAnnex k) (go f k) ww = WarnUnmatchLsFiles start :: FindOptions -> RawFilePath -> Key -> CommandStart diff --git a/Command/Fix.hs b/Command/Fix.hs index f1e44d6e57..697888bbe2 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -36,7 +36,7 @@ seek ps = unlessM crippledFileSystem $ where ww = WarnUnmatchLsFiles seeker = AnnexedFileSeeker - { seekAction = commandAction' (start FixAll) + { startAction = start FixAll , checkContentPresent = Nothing , usesLocationLog = False } diff --git a/Command/Fsck.hs b/Command/Fsck.hs index db8e94d48b..e38abd40db 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -93,7 +93,7 @@ seek o = startConcurrency commandStages $ do checkDeadRepo u i <- prepIncremental u (incrementalOpt o) let seeker = AnnexedFileSeeker - { seekAction = commandAction' (start from i) + { startAction = start from i , checkContentPresent = Nothing , usesLocationLog = True } diff --git a/Command/Get.hs b/Command/Get.hs index 71301e9963..1d46704b21 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -40,19 +40,17 @@ optParser desc = GetOptions seek :: GetOptions -> CommandSeek seek o = startConcurrency downloadStages $ do from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o) - let go = start o from let seeker = AnnexedFileSeeker - { seekAction = commandAction' go + { startAction = start o from , checkContentPresent = Just False , usesLocationLog = True } case batchOption o of - Batch fmt -> batchFilesMatching fmt - (whenAnnexed go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) (autoMode o) (commandAction . startKeys from) (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (getFiles o) + Batch fmt -> batchAnnexedFilesMatching fmt seeker where ww = WarnUnmatchLsFiles diff --git a/Command/Inprogress.hs b/Command/Inprogress.hs index 466291ba0c..696611c9b5 100644 --- a/Command/Inprogress.hs +++ b/Command/Inprogress.hs @@ -39,7 +39,7 @@ seek o = do _ -> do let s = S.fromList ts let seeker = AnnexedFileSeeker - { seekAction = commandAction' (start s) + { startAction = start s , checkContentPresent = Nothing , usesLocationLog = False } diff --git a/Command/List.hs b/Command/List.hs index d4660fc8df..7370ca0994 100644 --- a/Command/List.hs +++ b/Command/List.hs @@ -45,7 +45,7 @@ seek o = do list <- getList o printHeader list let seeker = AnnexedFileSeeker - { seekAction = commandAction' (start list) + { startAction = start list , checkContentPresent = Nothing , usesLocationLog = True } diff --git a/Command/Lock.hs b/Command/Lock.hs index 9e17ab76f2..1e88f65825 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -32,7 +32,7 @@ seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps where ww = WarnUnmatchLsFiles seeker = AnnexedFileSeeker - { seekAction = commandAction' start + { startAction = start , checkContentPresent = Nothing , usesLocationLog = False } diff --git a/Command/Log.hs b/Command/Log.hs index 973b44d70e..2ddea1aa87 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -86,7 +86,7 @@ seek o = do zone <- liftIO getCurrentTimeZone let outputter = mkOutputter m zone o let seeker = AnnexedFileSeeker - { seekAction = commandAction' (start o outputter) + { startAction = 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 b293fb9f8d..d11a570f8c 100644 --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -77,7 +77,7 @@ seek o = case batchOption o of c <- liftIO currentVectorClock let ww = WarnUnmatchLsFiles let seeker = AnnexedFileSeeker - { seekAction = commandAction' (start c o) + { startAction = start c o , checkContentPresent = Nothing , usesLocationLog = False } diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 7906de263e..50b32d264a 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -30,7 +30,7 @@ seek = withFilesInGitAnnex ww seeker <=< workTreeItems ww where ww = WarnUnmatchLsFiles seeker = AnnexedFileSeeker - { seekAction = commandAction' start + { startAction = start , checkContentPresent = Nothing , usesLocationLog = False } diff --git a/Command/Mirror.hs b/Command/Mirror.hs index 6a677ec0ec..022ea82ca0 100644 --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -52,7 +52,7 @@ seek o = startConcurrency stages $ ToRemote _ -> commandStages ww = WarnUnmatchLsFiles seeker = AnnexedFileSeeker - { seekAction = commandAction' (start o) + { startAction = start o , checkContentPresent = Nothing , usesLocationLog = False } diff --git a/Command/Move.hs b/Command/Move.hs index 2ba004d7bc..ac042ce75b 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -55,19 +55,17 @@ data RemoveWhen = RemoveSafe | RemoveNever seek :: MoveOptions -> CommandSeek seek o = startConcurrency stages $ do - let go = start (fromToOptions o) (removeWhen o) let seeker = AnnexedFileSeeker - { seekAction = commandAction' go + { startAction = start (fromToOptions o) (removeWhen o) , checkContentPresent = Nothing , usesLocationLog = False } case batchOption o of - Batch fmt -> batchFilesMatching fmt - (whenAnnexed go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) False (commandAction . startKey (fromToOptions o) (removeWhen o)) (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (moveFiles o) + Batch fmt -> batchAnnexedFilesMatching fmt seeker where stages = case fromToOptions o of Right (FromRemote _) -> downloadStages diff --git a/Command/Sync.hs b/Command/Sync.hs index 190fcbba83..6d7c54a2ff 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -646,7 +646,7 @@ seekSyncContent o rs currbranch = do seekworktree mvar l (const noop) pure Nothing withKeyOptions' (keyOptions o) False - (return (gokey mvar bloom)) + (return (commandAction . gokey mvar bloom)) (const noop) [] waitForAllRunningCommandActions @@ -654,7 +654,7 @@ seekSyncContent o rs currbranch = do where seekworktree mvar l bloomfeeder = do let seeker = AnnexedFileSeeker - { seekAction = gofile bloomfeeder mvar + { startAction = gofile bloomfeeder mvar , checkContentPresent = Nothing , usesLocationLog = True } @@ -662,7 +662,7 @@ seekSyncContent o rs currbranch = do seekHelper fst3 ww LsFiles.inRepoDetails l seekincludinghidden origbranch mvar l bloomfeeder = - seekFiltered (\f -> ifAnnexed f (gofile bloomfeeder mvar f) noop) $ + seekFiltered (\f -> ifAnnexed f (commandAction . gofile bloomfeeder mvar f) noop) $ seekHelper id ww (LsFiles.inRepoOrBranch origbranch) l ww = WarnUnmatchLsFiles @@ -677,7 +677,7 @@ seekSyncContent o rs currbranch = do -- Run syncFile as a command action so file transfers run -- concurrently. let ai = OnlyActionOn k (ActionItemKey k) - commandAction $ startingNoMessage ai $ do + startingNoMessage ai $ do whenM (syncFile ebloom rs af k) $ void $ liftIO $ tryPutMVar mvar () next $ return True diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 5308140e33..c17967175c 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -28,7 +28,7 @@ seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps seeker :: AnnexedFileSeeker seeker = AnnexedFileSeeker - { seekAction = commandAction' start + { startAction = start , checkContentPresent = Just True , usesLocationLog = False } diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 06195833ea..95177825fc 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -31,7 +31,7 @@ seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps where ww = WarnUnmatchLsFiles seeker = AnnexedFileSeeker - { seekAction = commandAction' start + { startAction = start , checkContentPresent = Nothing , usesLocationLog = False } diff --git a/Command/Whereis.hs b/Command/Whereis.hs index 17546d866c..cf23661546 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -51,20 +51,18 @@ parseFormatOption = option (Utility.Format.gen <$> str) seek :: WhereisOptions -> CommandSeek seek o = do m <- remoteMap id - let go = start o m + let seeker = AnnexedFileSeeker + { startAction = start o m + , checkContentPresent = Nothing + , usesLocationLog = True + } case batchOption o of - Batch fmt -> batchFilesMatching fmt - (whenAnnexed go . toRawFilePath) NoBatch -> do - let seeker = AnnexedFileSeeker - { seekAction = commandAction' go - , checkContentPresent = Nothing - , usesLocationLog = True - } withKeyOptions (keyOptions o) False (commandAction . startKeys o m) (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (whereisFiles o) + Batch fmt -> batchAnnexedFilesMatching fmt seeker where ww = WarnUnmatchLsFiles diff --git a/doc/todo/precache_logs_for_speed_with_cat-file_--buffer.mdwn b/doc/todo/precache_logs_for_speed_with_cat-file_--buffer.mdwn index 264617877e..d0cd632d8a 100644 --- a/doc/todo/precache_logs_for_speed_with_cat-file_--buffer.mdwn +++ b/doc/todo/precache_logs_for_speed_with_cat-file_--buffer.mdwn @@ -37,9 +37,6 @@ and precache them. > > > Still todo: > > > > > > * move, copy, drop, and mirror were left not using the location log caching yet -> > > * find has a bit of ugliness around batch mode, and this shows it -> > > would be worth making the batch mode take the same AnnexedFileSeeker, -> > > to reunify the batch and non-batch code > > > * get is left with an unncessary inAnnex check so could be sped up > > > a little bit more. Above improvements to batch mode would allow > > > fixing this.