diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs index f1d9eda298..e42c2a8c7b 100644 --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -43,6 +43,9 @@ 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/Seek.hs b/CmdLine/Seek.hs index 943e391eb2..43912ecc40 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -53,18 +53,18 @@ withFilesInGitAnnex :: WarnUnmatchWhen -> (RawFilePath -> Key -> CommandSeek) -> withFilesInGitAnnex ww a l = seekFilteredKeys a $ seekHelper fst3 ww LsFiles.inRepoDetails l -withFilesInGitNonRecursive :: WarnUnmatchWhen -> String -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek -withFilesInGitNonRecursive ww needforce a l = ifM (Annex.getState Annex.force) - ( withFilesInGit ww a l +withFilesInGitAnnexNonRecursive :: WarnUnmatchWhen -> String -> (RawFilePath -> Key -> CommandSeek) -> [WorkTreeItem] -> CommandSeek +withFilesInGitAnnexNonRecursive ww needforce a l = ifM (Annex.getState Annex.force) + ( withFilesInGitAnnex ww a l , if null l then giveup needforce - else seekFiltered a (getfiles [] l) + else seekFilteredKeys a (getfiles [] l) ) where getfiles c [] = return (reverse c) getfiles c ((WorkTreeItem p):ps) = do os <- seekOptions ww - (fs, cleanup) <- inRepo $ LsFiles.inRepo os [toRawFilePath p] + (fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toRawFilePath p] case fs of [f] -> do void $ liftIO $ cleanup diff --git a/Command/Copy.hs b/Command/Copy.hs index 13bfc30915..222081600c 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -45,13 +45,14 @@ instance DeferredParseClass CopyOptions where seek :: CopyOptions -> CommandSeek seek o = startConcurrency commandStages $ do - let go = whenAnnexed $ start o + let go = start o case batchOption o of - Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) + Batch fmt -> batchFilesMatching fmt + (whenAnnexed go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) (autoMode o) (commandAction . Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever) - (withFilesInGit ww $ commandAction . go) + (withFilesInGitAnnex ww (commandAction' go)) =<< workTreeItems ww (copyFiles o) where ww = WarnUnmatchLsFiles diff --git a/Command/Drop.hs b/Command/Drop.hs index ba9ade8c0c..f7c1be0ab5 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -54,13 +54,14 @@ parseDropFromOption = parseRemoteOption <$> strOption seek :: DropOptions -> CommandSeek seek o = startConcurrency commandStages $ case batchOption o of - Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) + Batch fmt -> batchFilesMatching fmt + (whenAnnexed go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) (autoMode o) (commandAction . startKeys o) - (withFilesInGit ww (commandAction . go)) + (withFilesInGitAnnex ww (commandAction' go)) =<< workTreeItems ww (dropFiles o) where - go = whenAnnexed $ start o + go = start o ww = WarnUnmatchLsFiles start :: DropOptions -> RawFilePath -> Key -> CommandStart diff --git a/Command/Find.hs b/Command/Find.hs index 0e2d35c18b..0e4bc80ab3 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -57,11 +57,12 @@ seek :: FindOptions -> CommandSeek seek o = case batchOption o of NoBatch -> withKeyOptions (keyOptions o) False (commandAction . startKeys o) - (withFilesInGit ww (commandAction . go)) + (withFilesInGitAnnex ww (commandAction' go)) =<< workTreeItems ww (findThese o) - Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) + Batch fmt -> batchFilesMatching fmt + (whenAnnexed go . toRawFilePath) where - go = whenAnnexed $ start o + go = start o ww = WarnUnmatchLsFiles -- only files inAnnex are shown, unless the user has requested diff --git a/Command/Fix.hs b/Command/Fix.hs index 94d40a0eb9..347c538fe5 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -31,9 +31,8 @@ cmd = noCommit $ withGlobalOptions [annexedMatchingOptions] $ paramPaths (withParams seek) seek :: CmdParams -> CommandSeek -seek ps = unlessM crippledFileSystem $ do - withFilesInGit ww - (commandAction . (whenAnnexed $ start FixAll)) +seek ps = unlessM crippledFileSystem $ + withFilesInGitAnnex ww (commandAction' (start FixAll)) =<< workTreeItems ww ps where ww = WarnUnmatchLsFiles diff --git a/Command/Get.hs b/Command/Get.hs index 36156a49b4..cf1fcc9fc1 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -46,7 +46,7 @@ seek o = startConcurrency downloadStages $ do (whenAnnexed go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) (autoMode o) (commandAction . startKeys from) - (withFilesInGitAnnex ww (\f k -> commandAction (go f k))) + (withFilesInGitAnnex ww (commandAction' go)) =<< workTreeItems ww (getFiles o) where ww = WarnUnmatchLsFiles diff --git a/Command/Inprogress.hs b/Command/Inprogress.hs index d2fb04a2a5..17d4f9239a 100644 --- a/Command/Inprogress.hs +++ b/Command/Inprogress.hs @@ -38,8 +38,8 @@ seek o = do | otherwise -> commandAction stop _ -> do let s = S.fromList ts - withFilesInGit ww - (commandAction . (whenAnnexed (start s))) + withFilesInGitAnnex ww + (commandAction' (start s)) =<< workTreeItems ww (inprogressFiles o) where ww = WarnUnmatchLsFiles diff --git a/Command/List.hs b/Command/List.hs index 92e18b654c..59bafb39ce 100644 --- a/Command/List.hs +++ b/Command/List.hs @@ -44,7 +44,7 @@ seek :: ListOptions -> CommandSeek seek o = do list <- getList o printHeader list - withFilesInGit ww (commandAction . (whenAnnexed $ start list)) + withFilesInGitAnnex ww (commandAction' (start list)) =<< workTreeItems ww (listThese o) where ww = WarnUnmatchLsFiles diff --git a/Command/Lock.hs b/Command/Lock.hs index a32adb56bf..b3e56f0121 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -8,7 +8,6 @@ module Command.Lock where import Command -import qualified Annex.Queue import qualified Annex import Annex.Content import Annex.Link @@ -31,12 +30,12 @@ cmd = withGlobalOptions [jsonOptions, annexedMatchingOptions] $ seek :: CmdParams -> CommandSeek seek ps = do l <- workTreeItems ww ps - withFilesInGit ww (commandAction . (whenAnnexed startNew)) l + withFilesInGitAnnex ww (commandAction' start) l where ww = WarnUnmatchLsFiles -startNew :: RawFilePath -> Key -> CommandStart -startNew file key = ifM (isJust <$> isAnnexLink file) +start :: RawFilePath -> Key -> CommandStart +start file key = ifM (isJust <$> isAnnexLink file) ( stop , starting "lock" (mkActionItem (key, file)) $ go =<< liftIO (isPointerFile file) @@ -53,14 +52,14 @@ startNew file key = ifM (isJust <$> isAnnexLink file) , errorModified ) ) - cont = performNew file key + cont = perform file key -performNew :: RawFilePath -> Key -> CommandPerform -performNew file key = do +perform :: RawFilePath -> Key -> CommandPerform +perform file key = do lockdown =<< calcRepo (gitAnnexLocation key) addLink (fromRawFilePath file) key =<< withTSDelta (liftIO . genInodeCache file) - next $ cleanupNew file key + next $ cleanup file key where lockdown obj = do ifM (isUnmodified key obj) @@ -96,22 +95,10 @@ performNew file key = do lostcontent = logStatus key InfoMissing -cleanupNew :: RawFilePath -> Key -> CommandCleanup -cleanupNew file key = do +cleanup :: RawFilePath -> Key -> CommandCleanup +cleanup file key = do Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file) return True -startOld :: RawFilePath -> CommandStart -startOld file = do - unlessM (Annex.getState Annex.force) - errorModified - starting "lock" (ActionItemWorkTreeFile file) $ - performOld file - -performOld :: RawFilePath -> CommandPerform -performOld file = do - Annex.Queue.addCommand "checkout" [Param "--"] [fromRawFilePath file] - next $ return True - errorModified :: a errorModified = giveup "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)" diff --git a/Command/Log.hs b/Command/Log.hs index 5ca6160671..48e5ec5bc2 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -86,8 +86,8 @@ seek o = do zone <- liftIO getCurrentTimeZone let outputter = mkOutputter m zone o case (logFiles o, allOption o) of - (fs, False) -> withFilesInGit ww - (commandAction . (whenAnnexed $ start o outputter)) + (fs, False) -> withFilesInGitAnnex ww + (commandAction' (start o outputter)) =<< workTreeItems ww fs ([], True) -> commandAction (startAll o outputter) (_, True) -> giveup "Cannot specify both files and --all" diff --git a/Command/MetaData.hs b/Command/MetaData.hs index 29229ac9c2..9f23da3295 100644 --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -77,13 +77,13 @@ seek o = case batchOption o of c <- liftIO currentVectorClock let ww = WarnUnmatchLsFiles let seeker = case getSet o of - Get _ -> withFilesInGit ww - GetAll -> withFilesInGit ww - Set _ -> withFilesInGitNonRecursive ww + Get _ -> withFilesInGitAnnex ww + GetAll -> withFilesInGitAnnex ww + Set _ -> withFilesInGitAnnexNonRecursive ww "Not recursively setting metadata. Use --force to do that." withKeyOptions (keyOptions o) False (commandAction . startKeys c o) - (seeker (commandAction . (whenAnnexed (start c o)))) + (seeker (commandAction' (start c o))) =<< workTreeItems ww (forFiles o) Batch fmt -> withMessageState $ \s -> case outputType s of JSONOutput _ -> ifM limited diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 33b7d4d2c8..49ae1e7ec9 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -26,7 +26,7 @@ cmd = withGlobalOptions [annexedMatchingOptions] $ paramPaths (withParams seek) seek :: CmdParams -> CommandSeek -seek = withFilesInGit ww (commandAction . (whenAnnexed start)) +seek = withFilesInGitAnnex ww (commandAction' start) <=< workTreeItems ww where ww = WarnUnmatchLsFiles diff --git a/Command/Mirror.hs b/Command/Mirror.hs index eef184ed81..97295e7a8f 100644 --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -44,7 +44,7 @@ seek :: MirrorOptions -> CommandSeek seek o = startConcurrency stages $ withKeyOptions (keyOptions o) False (commandAction . startKey o (AssociatedFile Nothing)) - (withFilesInGit ww (commandAction . (whenAnnexed $ start o))) + (withFilesInGitAnnex ww (commandAction' (start o))) =<< workTreeItems ww (mirrorFiles o) where stages = case fromToOptions o of diff --git a/Command/Move.hs b/Command/Move.hs index e754372763..d612275a89 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -55,12 +55,13 @@ data RemoveWhen = RemoveSafe | RemoveNever seek :: MoveOptions -> CommandSeek seek o = startConcurrency stages $ do - let go = whenAnnexed $ start (fromToOptions o) (removeWhen o) + let go = start (fromToOptions o) (removeWhen o) case batchOption o of - Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) + Batch fmt -> batchFilesMatching fmt + (whenAnnexed go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) False (commandAction . startKey (fromToOptions o) (removeWhen o)) - (withFilesInGit ww (commandAction . go)) + (withFilesInGitAnnex ww (commandAction' go)) =<< workTreeItems ww (moveFiles o) where stages = case fromToOptions o of diff --git a/Command/Unannex.hs b/Command/Unannex.hs index b41a053597..ef26afc1f1 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -23,7 +23,7 @@ cmd = withGlobalOptions [annexedMatchingOptions] $ paramPaths (withParams seek) seek :: CmdParams -> CommandSeek -seek ps = (withFilesInGit ww $ commandAction . whenAnnexed start) +seek ps = (withFilesInGitAnnex ww (commandAction' start)) =<< workTreeItems ww ps where ww = WarnUnmatchLsFiles diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 925fbc7086..b9eeaaf814 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -44,7 +44,7 @@ seek ps = do l <- workTreeItems ww ps withFilesNotInGit (commandAction . whenAnnexed (startCheckIncomplete . fromRawFilePath)) l Annex.changeState $ \s -> s { Annex.fast = True } - withFilesInGit ww (commandAction . whenAnnexed Command.Unannex.start) l + withFilesInGitAnnex ww (commandAction' Command.Unannex.start) l finish where ww = WarnUnmatchLsFiles diff --git a/Command/Unlock.hs b/Command/Unlock.hs index a1fa559669..7f2f26df6d 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -27,7 +27,7 @@ mkcmd n d = withGlobalOptions [jsonOptions, annexedMatchingOptions] $ command n SectionCommon d paramPaths (withParams seek) seek :: CmdParams -> CommandSeek -seek ps = withFilesInGit ww (commandAction . whenAnnexed start) +seek ps = withFilesInGitAnnex ww (commandAction' start) =<< workTreeItems ww ps where ww = WarnUnmatchLsFiles diff --git a/Command/Whereis.hs b/Command/Whereis.hs index fda4825c32..bb28b4af05 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -51,13 +51,14 @@ parseFormatOption = option (Utility.Format.gen <$> str) seek :: WhereisOptions -> CommandSeek seek o = do m <- remoteMap id - let go = whenAnnexed $ start o m + let go = start o m case batchOption o of - Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) + Batch fmt -> batchFilesMatching fmt + (whenAnnexed go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) False (commandAction . startKeys o m) - (withFilesInGit ww (commandAction . go)) + (withFilesInGitAnnex ww (commandAction' go)) =<< workTreeItems ww (whereisFiles o) where ww = WarnUnmatchLsFiles