diff options
79 files changed, 390 insertions, 356 deletions
@@ -109,6 +109,7 @@ data AnnexState = AnnexState , cleanup :: M.Map String (Annex ()) , inodeschanged :: Maybe Bool , useragent :: Maybe String + , errcounter :: Integer } newState :: GitConfig -> Git.Repo -> AnnexState @@ -143,6 +144,7 @@ newState c r = AnnexState , cleanup = M.empty , inodeschanged = Nothing , useragent = Nothing + , errcounter = 0 } {- Makes an Annex state object for the specified git repo. diff --git a/Annex/Drop.hs b/Annex/Drop.hs index df64895be..3e915c315 100644 --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -92,7 +92,7 @@ handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do checkdrop fs n@(have, numcopies, _untrusted) u a = ifM (allM (wantDrop True u . Just) fs) - ( ifM (safely $ doCommand $ a (Just numcopies)) + ( ifM (safely $ callCommand $ a (Just numcopies)) ( do liftIO $ debugM "drop" $ unwords [ "dropped" diff --git a/CmdLine.hs b/CmdLine.hs index 7c28ecec8..cba403dc2 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -23,7 +23,6 @@ import System.Posix.Signals import Common.Annex import qualified Annex -import qualified Annex.Queue import qualified Git import qualified Git.AutoCorrect import Annex.Content @@ -41,7 +40,7 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do Left e -> maybe (throw e) (\a -> a params) (cmdnorepo cmd) Right g -> do state <- Annex.new g - (actions, state') <- Annex.run state $ do + Annex.eval state $ do checkEnvironment checkfuzzy forM_ fields $ uncurry Annex.setField @@ -50,8 +49,9 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do sequence_ flags whenM (annexDebug <$> Annex.getGitConfig) $ liftIO enableDebugOutput - prepCommand cmd params - tryRun state' cmd $ [startup] ++ actions ++ [shutdown $ cmdnocommit cmd] + startup + performCommand cmd params + shutdown $ cmdnocommit cmd where err msg = msg ++ "\n\n" ++ usage header allcmds cmd = Prelude.head cmds @@ -92,44 +92,19 @@ getOptCmd argv cmd commonoptions = check $ , commandUsage cmd ] -{- Runs a list of Annex actions. Catches IO errors and continues - - (but explicitly thrown errors terminate the whole command). - -} -tryRun :: Annex.AnnexState -> Command -> [CommandCleanup] -> IO () -tryRun = tryRun' 0 -tryRun' :: Integer -> Annex.AnnexState -> Command -> [CommandCleanup] -> IO () -tryRun' errnum _ cmd [] - | errnum > 0 = error $ cmdname cmd ++ ": " ++ show errnum ++ " failed" - | otherwise = noop -tryRun' errnum state cmd (a:as) = do - r <- run - handle $! r - where - run = tryIO $ Annex.run state $ do - Annex.Queue.flushWhenFull - a - handle (Left err) = showerr err >> cont False state - handle (Right (success, state')) = cont success state' - cont success s = do - let errnum' = if success then errnum else errnum + 1 - (tryRun' $! errnum') s cmd as - showerr err = Annex.eval state $ do - showErr err - showEndFail - {- Actions to perform each time ran. -} -startup :: Annex Bool -startup = liftIO $ do +startup :: Annex () +startup = #ifndef mingw32_HOST_OS - void $ installHandler sigINT Default Nothing + liftIO $ void $ installHandler sigINT Default Nothing +#else + return () #endif - return True {- Cleanup actions. -} -shutdown :: Bool -> Annex Bool +shutdown :: Bool -> Annex () shutdown nocommit = do saveState nocommit sequence_ =<< M.elems <$> Annex.getState Annex.cleanup liftIO reapZombies -- zombies from long-running git processes sshCleanup -- ssh connection caching - return True diff --git a/Command.hs b/Command.hs index b6484749e..aeffbbeb8 100644 --- a/Command.hs +++ b/Command.hs @@ -1,10 +1,12 @@ {- git-annex command infrastructure - - - Copyright 2010-2011 Joey Hess <joey@kitenet.net> + - Copyright 2010-2014 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE BangPatterns #-} + module Command ( command, noRepo, @@ -14,8 +16,7 @@ module Command ( next, stop, stopUnless, - prepCommand, - doCommand, + runCommand, whenAnnexed, ifAnnexed, isBareRepo, @@ -35,12 +36,13 @@ import Types.Option as ReExported import Seek as ReExported import Checks as ReExported import Usage as ReExported +import RunCommand as ReExported import Logs.Trust import Config import Annex.CheckAttr {- Generates a normal command -} -command :: String -> String -> [CommandSeek] -> CommandSection -> String -> Command +command :: String -> String -> CommandSeek -> CommandSection -> String -> Command command = Command [] Nothing commonChecks False False {- Indicates that a command doesn't need to commit any changes to @@ -74,25 +76,6 @@ stop = return Nothing stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a) stopUnless c a = ifM c ( a , stop ) -{- Prepares to run a command via the check and seek stages, returning a - - list of actions to perform to run the command. -} -prepCommand :: Command -> [String] -> Annex [CommandCleanup] -prepCommand Command { cmdseek = seek, cmdcheck = c } params = do - mapM_ runCheck c - map doCommand . concat <$> mapM (\s -> s params) seek - -{- Runs a command through the start, perform and cleanup stages -} -doCommand :: CommandStart -> CommandCleanup -doCommand = start - where - start = stage $ maybe skip perform - perform = stage $ maybe failure cleanup - cleanup = stage $ status - stage = (=<<) - skip = return True - failure = showEndFail >> return False - status r = showEndResult r >> return r - {- Modifies an action to only act on files that are already annexed, - and passes the key and backend on to it. -} whenAnnexed :: (FilePath -> (Key, Backend) -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a) diff --git a/Command/Add.hs b/Command/Add.hs index c5035ba1f..ffa27504a 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -41,18 +41,18 @@ def = [notBareRepo $ command "add" paramPaths seek SectionCommon {- Add acts on both files not checked into git yet, and unlocked files. - - In direct mode, it acts on any files that have changed. -} -seek :: [CommandSeek] -seek = - [ go withFilesNotInGit - , whenNotDirect $ go withFilesUnlocked - , whenDirect $ go withFilesMaybeModified - ] - where - go a = withValue largeFilesMatcher $ \matcher -> - a $ \file -> ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force) - ( start file - , stop - ) +seek :: CommandSeek +seek ps = do + matcher <- largeFilesMatcher + let go a = flip a ps $ \file -> ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force) + ( start file + , stop + ) + go withFilesNotInGit + ifM isDirect + ( go withFilesMaybeModified + , go withFilesUnlocked + ) {- The add subcommand annexes a file, generating a key for it using a - backend, and then moving it into the annex directory and setting up diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs index 1a178e8d4..91427e819 100644 --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -18,8 +18,8 @@ def :: [Command] def = [notDirect $ command "addunused" (paramRepeating paramNumRange) seek SectionMaintenance "add back unused files"] -seek :: [CommandSeek] -seek = [withUnusedMaps start] +seek :: CommandSeek +seek = withUnusedMaps start start :: UnusedMaps -> Int -> CommandStart start = startUnused "addunused" perform diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 7f3607b81..8027c4b6b 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -47,11 +47,12 @@ pathdepthOption = Option.field [] "pathdepth" paramNumber "path components to us relaxedOption :: Option relaxedOption = Option.flag [] "relaxed" "skip size check" -seek :: [CommandSeek] -seek = [withField fileOption return $ \f -> - withFlag relaxedOption $ \relaxed -> - withField pathdepthOption (return . maybe Nothing readish) $ \d -> - withStrings $ start relaxed f d] +seek :: CommandSeek +seek ps = do + f <- getOptionField fileOption return + relaxed <- getOptionFlag relaxedOption + d <- getOptionField pathdepthOption (return . maybe Nothing readish) + withStrings (start relaxed f d) ps start :: Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart start relaxed optfile pathdepth s = go $ fromMaybe bad $ parseURI s diff --git a/Command/Assistant.hs b/Command/Assistant.hs index cef4392dc..260d9c69c 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -37,12 +37,13 @@ autoStartOption = Option.flag [] "autostart" "start in known repositories" startDelayOption :: Option startDelayOption = Option.field [] "startdelay" paramNumber "delay before running startup scan" -seek :: [CommandSeek] -seek = [withFlag Command.Watch.stopOption $ \stopdaemon -> - withFlag Command.Watch.foregroundOption $ \foreground -> - withFlag autoStartOption $ \autostart -> - withField startDelayOption (pure . maybe Nothing parseDuration) $ \startdelay -> - withNothing $ start foreground stopdaemon autostart startdelay] +seek :: CommandSeek +seek ps = do + stopdaemon <- getOptionFlag Command.Watch.stopOption + foreground <- getOptionFlag Command.Watch.foregroundOption + autostart <- getOptionFlag autoStartOption + startdelay <- getOptionField startDelayOption (pure . maybe Nothing parseDuration) + withNothing (start foreground stopdaemon autostart startdelay) ps start :: Bool -> Bool -> Bool -> Maybe Duration -> CommandStart start foreground stopdaemon autostart startdelay diff --git a/Command/Commit.hs b/Command/Commit.hs index 6f3f9df28..f5f13d248 100644 --- a/Command/Commit.hs +++ b/Command/Commit.hs @@ -16,8 +16,8 @@ def :: [Command] def = [command "commit" paramNothing seek SectionPlumbing "commits any staged changes to the git-annex branch"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = next $ next $ do diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs index c42480200..58b738864 100644 --- a/Command/ConfigList.hs +++ b/Command/ConfigList.hs @@ -17,8 +17,8 @@ def :: [Command] def = [noCommit $ command "configlist" paramNothing seek SectionPlumbing "outputs relevant git configuration"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = do diff --git a/Command/Copy.hs b/Command/Copy.hs index 9fd97334a..fd16cea29 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -18,13 +18,14 @@ def :: [Command] def = [withOptions Command.Move.moveOptions $ command "copy" paramPaths seek SectionCommon "copy content of files to/from another repository"] -seek :: [CommandSeek] -seek = - [ withField toOption Remote.byNameWithUUID $ \to -> - withField fromOption Remote.byNameWithUUID $ \from -> - withKeyOptions (Command.Move.startKey to from False) $ - withFilesInGit $ whenAnnexed $ start to from - ] +seek :: CommandSeek +seek ps = do + to <- getOptionField toOption Remote.byNameWithUUID + from <- getOptionField fromOption Remote.byNameWithUUID + withKeyOptions + (Command.Move.startKey to from False) + (withFilesInGit $ whenAnnexed $ start to from) + ps {- 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/Dead.hs b/Command/Dead.hs index 180f2fda9..13aa74bff 100644 --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -19,8 +19,8 @@ def :: [Command] def = [command "dead" (paramRepeating paramRemote) seek SectionSetup "hide a lost repository"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start ws = do diff --git a/Command/Describe.hs b/Command/Describe.hs index 18851b172..601b3fcc9 100644 --- a/Command/Describe.hs +++ b/Command/Describe.hs @@ -16,8 +16,8 @@ def :: [Command] def = [command "describe" (paramPair paramRemote paramDesc) seek SectionSetup "change description of a repository"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start (name:description) = do diff --git a/Command/Direct.hs b/Command/Direct.hs index c35bbdaea..47f622a81 100644 --- a/Command/Direct.hs +++ b/Command/Direct.hs @@ -23,8 +23,8 @@ def = [notBareRepo $ noDaemonRunning $ command "direct" paramNothing seek SectionSetup "switch repository to direct mode"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = ifM isDirect ( stop , next perform ) diff --git a/Command/Drop.hs b/Command/Drop.hs index 4c7128603..f5c76f1ce 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -27,9 +27,10 @@ def = [withOptions [fromOption] $ command "drop" paramPaths seek fromOption :: Option fromOption = Option.field ['f'] "from" paramRemote "drop content from a remote" -seek :: [CommandSeek] -seek = [withField fromOption Remote.byNameWithUUID $ \from -> - withFilesInGit $ whenAnnexed $ start from] +seek :: CommandSeek +seek ps = do + from <- getOptionField fromOption Remote.byNameWithUUID + withFilesInGit (whenAnnexed $ start from) ps start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart start from file (key, _) = checkDropAuto from file key $ \numcopies -> diff --git a/Command/DropKey.hs b/Command/DropKey.hs index 624919584..002633e58 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -18,8 +18,8 @@ def :: [Command] def = [noCommit $ command "dropkey" (paramRepeating paramKey) seek SectionPlumbing "drops annexed content for specified keys"] -seek :: [CommandSeek] -seek = [withKeys start] +seek :: CommandSeek +seek = withKeys start start :: Key -> CommandStart start key = stopUnless (inAnnex key) $ do diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index bf2635e00..5d7c5c1d2 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -21,8 +21,8 @@ def = [withOptions [Command.Drop.fromOption] $ command "dropunused" (paramRepeating paramNumRange) seek SectionMaintenance "drop unused file content"] -seek :: [CommandSeek] -seek = [withUnusedMaps start] +seek :: CommandSeek +seek = withUnusedMaps start start :: UnusedMaps -> Int -> CommandStart start = startUnused "dropunused" perform (performOther gitAnnexBadLocation) (performOther gitAnnexTmpLocation) diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs index 1905acd8d..a00046d5a 100644 --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -20,8 +20,8 @@ def = [command "enableremote" (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue) seek SectionSetup "enables use of an existing special remote"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start [] = unknownNameError "Specify the name of the special remote to enable." diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs index 1e8e2cecf..30963287e 100644 --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -10,7 +10,7 @@ module Command.ExamineKey where import Common.Annex import Command import qualified Utility.Format -import Command.Find (formatOption, withFormat, showFormatted, keyVars) +import Command.Find (formatOption, getFormat, showFormatted, keyVars) import Types.Key import GitAnnex.Options @@ -19,8 +19,10 @@ def = [noCommit $ noMessages $ withOptions [formatOption, jsonOption] $ command "examinekey" (paramRepeating paramKey) seek SectionPlumbing "prints information from a key"] -seek :: [CommandSeek] -seek = [withFormat $ \f -> withKeys $ start f] +seek :: CommandSeek +seek ps = do + format <- getFormat + withKeys (start format) ps start :: Maybe Utility.Format.Format -> Key -> CommandStart start format key = do diff --git a/Command/Find.hs b/Command/Find.hs index ddcc4b8c7..e7e5b7986 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -27,8 +27,8 @@ def = [noCommit $ noMessages $ withOptions [formatOption, print0Option, jsonOpti formatOption :: Option formatOption = Option.field [] "format" paramFormat "control format of output" -withFormat :: (Maybe Utility.Format.Format -> CommandSeek) -> CommandSeek -withFormat = withField formatOption $ return . fmap Utility.Format.gen +getFormat :: Annex (Maybe Utility.Format.Format) +getFormat = getOptionField formatOption $ return . fmap Utility.Format.gen print0Option :: Option print0Option = Option.Option [] ["print0"] (Option.NoArg set) @@ -36,8 +36,10 @@ print0Option = Option.Option [] ["print0"] (Option.NoArg set) where set = Annex.setField (Option.name formatOption) "${file}\0" -seek :: [CommandSeek] -seek = [withFormat $ \f -> withFilesInGit $ whenAnnexed $ start f] +seek :: CommandSeek +seek ps = do + format <- getFormat + withFilesInGit (whenAnnexed $ start format) ps start :: Maybe Utility.Format.Format -> FilePath -> (Key, Backend) -> CommandStart start format file (key, _) = do diff --git a/Command/Fix.hs b/Command/Fix.hs index a63a10f8f..9339585d1 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -24,8 +24,8 @@ def :: [Command] def = [notDirect $ noCommit $ command "fix" paramPaths seek SectionMaintenance "fix up symlinks to point to annexed content"] -seek :: [CommandSeek] -seek = [withFilesInGit $ whenAnnexed start] +seek :: CommandSeek +seek = withFilesInGit $ whenAnnexed start {- Fixes the symlink to an annexed file. -} start :: FilePath -> (Key, Backend) -> CommandStart diff --git a/Command/Forget.hs b/Command/Forget.hs index 74bd68ad1..0f247f968 100644 --- a/Command/Forget.hs +++ b/Command/Forget.hs @@ -26,9 +26,10 @@ forgetOptions = [dropDeadOption] dropDeadOption :: Option dropDeadOption = Option.flag [] "drop-dead" "drop references to dead repositories" -seek :: [CommandSeek] -seek = [withFlag dropDeadOption $ \dropdead -> - withNothing $ start dropdead] +seek :: CommandSeek +seek ps = do + dropdead <- getOptionFlag dropDeadOption + withNothing (start dropdead) ps start :: Bool -> CommandStart start dropdead = do diff --git a/Command/FromKey.hs b/Command/FromKey.hs index c3d2daafe..784731ad7 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -20,8 +20,8 @@ def = [notDirect $ notBareRepo $ command "fromkey" (paramPair paramKey paramPath) seek SectionPlumbing "adds a file using a specific key"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start (keyname:file:[]) = do diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 2ab47b562..8b320f209 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -70,16 +70,17 @@ fsckOptions = , incrementalScheduleOption ] ++ keyOptions -seek :: [CommandSeek] -seek = - [ withField fromOption Remote.byNameWithUUID $ \from -> - withIncremental $ \i -> - withKeyOptions (startKey i) $ - withFilesInGit $ whenAnnexed $ start from i - ] - -withIncremental :: (Incremental -> CommandSeek) -> CommandSeek -withIncremental = withValue $ do +seek :: CommandSeek +seek ps = do + from <- getOptionField fromOption Remote.byNameWithUUID + i <- getIncremental + withKeyOptions + (startKey i) + (withFilesInGit $ whenAnnexed $ start from i) + ps + +getIncremental :: Annex Incremental +getIncremental = do i <- maybe (return False) (checkschedule . parseDuration) =<< Annex.getField (Option.name incrementalScheduleOption) starti <- Annex.getFlag (Option.name startIncrementalOption) diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs index 34e74b433..2ed0fed62 100644 --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -25,8 +25,8 @@ def :: [Command] def = [ notBareRepo $ command "fuzztest" paramNothing seek SectionPlumbing "generates fuzz test files"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = do diff --git a/Command/GCryptSetup.hs b/Command/GCryptSetup.hs index bdd770f15..2448467fd 100644 --- a/Command/GCryptSetup.hs +++ b/Command/GCryptSetup.hs @@ -18,8 +18,8 @@ def = [dontCheck repoExists $ noCommit $ command "gcryptsetup" paramValue seek SectionPlumbing "sets up gcrypt repository"] -seek :: [CommandSeek] -seek = [withStrings start] +seek :: CommandSeek +seek = withStrings start start :: String -> CommandStart start gcryptid = next $ next $ do diff --git a/Command/Get.hs b/Command/Get.hs index 52fbd25f9..c83692a8d 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -24,12 +24,13 @@ def = [withOptions getOptions $ command "get" paramPaths seek getOptions :: [Option] getOptions = fromOption : keyOptions -seek :: [CommandSeek] -seek = - [ withField fromOption Remote.byNameWithUUID $ \from -> - withKeyOptions (startKeys from) $ - withFilesInGit $ whenAnnexed $ start from - ] +seek :: CommandSeek +seek ps = do + from <- getOptionField fromOption Remote.byNameWithUUID + withKeyOptions + (startKeys from) + (withFilesInGit $ whenAnnexed $ start from) + ps start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart start from file (key, _) = start' expensivecheck from key (Just file) diff --git a/Command/Group.hs b/Command/Group.hs index 4c0bf4899..b0dbc1465 100644 --- a/Command/Group.hs +++ b/Command/Group.hs @@ -19,8 +19,8 @@ def :: [Command] def = [command "group" (paramPair paramRemote paramDesc) seek SectionSetup "add a repository to a group"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start (name:g:[]) = do diff --git a/Command/Help.hs b/Command/Help.hs index 71e767663..5292c3ca3 100644 --- a/Command/Help.hs +++ b/Command/Help.hs @@ -26,8 +26,8 @@ def :: [Command] def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $ command "help" paramNothing seek SectionQuery "display help"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start params = do diff --git a/Command/Import.hs b/Command/Import.hs index dcf2b0fa0..dda2f3bc4 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -61,8 +61,10 @@ getDuplicateMode = gen gen False False False True = SkipDuplicates gen _ _ _ _ = error "bad combination of --duplicate, --deduplicate, --clean-duplicates, --skip-duplicates" -seek :: [CommandSeek] -seek = [withValue getDuplicateMode $ \mode -> withPathContents $ start mode] +seek :: CommandSeek +seek ps = do + mode <- getDuplicateMode + withPathContents (start mode) ps start :: DuplicateMode -> (FilePath, FilePath) -> CommandStart start mode (srcfile, destfile) = diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs index d16362205..2675b7a54 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -41,11 +41,12 @@ def = [notBareRepo $ withOptions [templateOption, relaxedOption] $ templateOption :: Option templateOption = Option.field [] "template" paramFormat "template for filenames" -seek :: [CommandSeek] -seek = [withField templateOption return $ \tmpl -> - withFlag relaxedOption $ \relaxed -> - withValue (getCache tmpl) $ \cache -> - withStrings $ start relaxed cache] +seek :: CommandSeek +seek ps = do + tmpl <- getOptionField templateOption return + relaxed <- getOptionFlag relaxedOption + cache <- getCache tmpl + withStrings (start relaxed cache) ps start :: Bool -> Cache -> URLString -> CommandStart start relaxed cache url = do diff --git a/Command/InAnnex.hs b/Command/InAnnex.hs index 4410d722d..11cbdb73d 100644 --- a/Command/InAnnex.hs +++ b/Command/InAnnex.hs @@ -15,8 +15,8 @@ def :: [Command] def = [noCommit $ command "inannex" (paramRepeating paramKey) seek SectionPlumbing "checks if keys are present in the annex"] -seek :: [CommandSeek] -seek = [withKeys start] +seek :: CommandSeek +seek = withKeys start start :: Key -> CommandStart start key = inAnnexSafe key >>= dispatch diff --git a/Command/Indirect.hs b/Command/Indirect.hs index a8669fe50..194be6821 100644 --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -31,8 +31,8 @@ def = [notBareRepo $ noDaemonRunning $ command "indirect" paramNothing seek SectionSetup "switch repository to indirect mode"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = ifM isDirect diff --git a/Command/Info.hs b/Command/Info.hs index b623d58e7..fde51968d 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -75,8 +75,8 @@ def = [noCommit $ withOptions [jsonOption] $ command "info" paramPaths seek SectionQuery "shows general information about the annex"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [FilePath] -> CommandStart start [] = do diff --git a/Command/Init.hs b/Command/Init.hs index 3db9a6be3..a076cb486 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -15,8 +15,8 @@ def :: [Command] def = [dontCheck repoExists $ command "init" paramDesc seek SectionSetup "initialize git-annex"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start ws = do diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs index 5a240f800..79fbcf39c 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -24,8 +24,8 @@ def = [command "initremote" (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue) seek SectionSetup "creates a special (non-git) remote"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start [] = error "Specify a name for the remote." diff --git a/Command/List.hs b/Command/List.hs index 663da4500..763908116 100644 --- a/Command/List.hs +++ b/Command/List.hs @@ -31,11 +31,11 @@ def = [noCommit $ withOptions [allrepos] $ command "list" paramPaths seek allrepos :: Option allrepos = Option.flag [] "allrepos" "show all repositories, not only remotes" -seek :: [CommandSeek] -seek = - [ withValue getList $ withWords . startHeader - , withValue getList $ withFilesInGit . whenAnnexed . start - ] +seek :: CommandSeek +seek ps = do + list <- getList + printHeader list + withFilesInGit (whenAnnexed $ start list) ps getList :: Annex [(UUID, RemoteName, TrustLevel)] getList = ifM (Annex.getFlag $ Option.name allrepos) @@ -58,10 +58,8 @@ getList = ifM (Annex.getFlag $ Option.name allrepos) return $ sortBy (comparing snd3) $ filter (\t -> thd3 t /= DeadTrusted) rs3 -startHeader :: [(UUID, RemoteName, TrustLevel)] -> [String] -> CommandStart -startHeader l _ = do - liftIO $ putStrLn $ header $ map (\(_, n, t) -> (n, t)) l - stop +printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex () +printHeader l = liftIO $ putStrLn $ header $ map (\(_, n, t) -> (n, t)) l start :: [(UUID, RemoteName, TrustLevel)] -> FilePath -> (Key, Backend) -> CommandStart start l file (key, _) = do diff --git a/Command/Lock.hs b/Command/Lock.hs index bceba4a91..e6733dcb1 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -16,8 +16,10 @@ def :: [Command] def = [notDirect $ command "lock" paramPaths seek SectionCommon "undo unlock command"] -seek :: [CommandSeek] -seek = [withFilesUnlocked start, withFilesUnlockedToBeCommitted start] +seek :: CommandSeek +seek ps = do + withFilesUnlocked start ps + withFilesUnlockedToBeCommitted start ps start :: FilePath -> CommandStart start file = do diff --git a/Command/Log.hs b/Command/Log.hs index f3a5becb8..b7ad664cf 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -53,12 +53,13 @@ passthruOptions = map odate ["since", "after", "until", "before"] ++ gourceOption :: Option gourceOption = Option.flag [] "gource" "format output for gource" -seek :: [CommandSeek] -seek = [withValue Remote.uuidDescriptions $ \m -> - withValue (liftIO getCurrentTimeZone) $ \zone -> - withValue (concat <$> mapM getoption passthruOptions) $ \os -> - withFlag gourceOption $ \gource -> - withFilesInGit $ whenAnnexed $ start m zone os gource] +seek :: CommandSeek +seek ps = do + m <- Remote.uuidDescriptions + zone <- liftIO getCurrentTimeZone + os <- concat <$> mapM getoption passthruOptions + gource <- getOptionFlag gourceOption + withFilesInGit (whenAnnexed $ start m zone os gource) ps where getoption o = maybe [] (use o) <$> Annex.getField (Option.name o) diff --git a/Command/LookupKey.hs b/Command/LookupKey.hs index aa83266cb..814c5d2d7 100644 --- a/Command/LookupKey.hs +++ b/Command/LookupKey.hs @@ -17,8 +17,8 @@ def = [notBareRepo $ noCommit $ noMessages $ command "lookupkey" (paramRepeating paramFile) seek SectionPlumbing "looks up key used for file"] -seek :: [CommandSeek] -seek = [withStrings start] +seek :: CommandSeek +seek = withStrings start start :: String -> CommandStart start file = do diff --git a/Command/Map.hs b/Command/Map.hs index 575e32122..9b80d2035 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -31,8 +31,8 @@ def = [dontCheck repoExists $ command "map" paramNothing seek SectionQuery "generate map of repositories"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = do diff --git a/Command/Merge.hs b/Command/Merge.hs index 31db7a99f..51a8b9c52 100644 --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -17,11 +17,10 @@ def :: [Command] def = [command "merge" paramNothing seek SectionMaintenance "automatically merge changes from remotes"] -seek :: [CommandSeek] -seek = - [ withNothing mergeBranch - , withNothing mergeSynced - ] +seek :: CommandSeek +seek ps = do + withNothing mergeBranch ps + withNothing mergeSynced ps mergeBranch :: CommandStart mergeBranch = do diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 0fdf0e817..c14c07bdd 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -22,8 +22,8 @@ def = [notDirect $ command "migrate" paramPaths seek SectionUtility "switch data to different backend"] -seek :: [CommandSeek] -seek = [withFilesInGit $ whenAnnexed start] +seek :: CommandSeek +seek = withFilesInGit $ whenAnnexed start start :: FilePath -> (Key, Backend) -> CommandStart start file (key, oldbackend) = do diff --git a/Command/Mirror.hs b/Command/Mirror.hs index fb829bcb0..cf4663cb5 100644 --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -22,13 +22,14 @@ def = [withOptions (fromToOptions ++ keyOptions) $ command "mirror" paramPaths seek SectionCommon "mirror content of files to/from another repository"] -seek :: [CommandSeek] -seek = - [ withField toOption Remote.byNameWithUUID $ \to -> - withField fromOption Remote.byNameWithUUID $ \from -> - withKeyOptions (startKey Nothing to from Nothing) $ - withFilesInGit $ whenAnnexed $ start to from - ] +seek :: CommandSeek +seek ps = do + to <- getOptionField toOption Remote.byNameWithUUID + from <- getOptionField fromOption Remote.byNameWithUUID + withKeyOptions + (startKey Nothing to from Nothing) + (withFilesInGit $ whenAnnexed $ start to from) + ps start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart start to from file (key, _backend) = do diff --git a/Command/Move.hs b/Command/Move.hs index 7d11b5abd..b79e4c929 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -26,13 +26,14 @@ def = [withOptions moveOptions $ command "move" paramPaths seek moveOptions :: [Option] moveOptions = fromToOptions ++ keyOptions -seek :: [CommandSeek] -seek = - [ withField toOption Remote.byNameWithUUID $ \to -> - withField fromOption Remote.byNameWithUUID $ \from -> - withKeyOptions (startKey to from True) $ - withFilesInGit $ whenAnnexed $ start to from True - ] +seek :: CommandSeek +seek ps = do + to <- getOptionField toOption Remote.byNameWithUUID + from <- getOptionField fromOption Remote.byNameWithUUID + withKeyOptions + (startKey to from True) + (withFilesInGit $ whenAnnexed $ start to from True) + ps start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> (Key, Backend) -> CommandStart start to from move file (key, _) = start' to from move (Just file) key diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index eed2f491c..6644f6ffa 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -9,6 +9,7 @@ module Command.PreCommit where import Common.Annex import Command +import Config import qualified Command.Add import qualified Command.Fix import Annex.Direct @@ -17,19 +18,20 @@ def :: [Command] def = [command "pre-commit" paramPaths seek SectionPlumbing "run by git pre-commit hook"] -seek :: [CommandSeek] -seek = - -- fix symlinks to files being committed - [ whenNotDirect $ withFilesToBeCommitted $ whenAnnexed Command.Fix.start - -- inject unlocked files into the annex - , whenNotDirect $ withFilesUnlockedToBeCommitted startIndirect +seek :: CommandSeek +seek ps = ifM isDirect -- update direct mode mappings for committed files - , whenDirect $ withWords startDirect - ] + ( withWords startDirect ps + , do + -- fix symlinks to files being committed + withFilesToBeCommitted (whenAnnexed Command.Fix.start) ps + -- inject unlocked files into the annex + withFilesUnlockedToBeCommitted startIndirect ps + ) startIndirect :: FilePath -> CommandStart startIndirect file = next $ do - unlessM (doCommand $ Command.Add.start file) $ + unlessM (callCommand $ Command.Add.start file) $ error $ "failed to add " ++ file ++ "; canceling commit" next $ return True diff --git a/Command/ReKey.hs b/Command/ReKey.hs index 7448ba97e..805300f9f 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -22,8 +22,8 @@ def = [notDirect $ command "rekey" (paramOptional $ paramRepeating $ paramPair paramPath paramKey) seek SectionPlumbing "change keys used for files"] -seek :: [CommandSeek] -seek = [withPairs start] +seek :: CommandSeek +seek = withPairs start start :: (FilePath, String) -> CommandStart start (file, keyname) = ifAnnexed file go stop diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index 3b2a8c496..6964ea5bd 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -26,8 +26,8 @@ def :: [Command] def = [noCommit $ command "recvkey" paramKey seek SectionPlumbing "runs rsync in server mode to receive content"] -seek :: [CommandSeek] -seek = [withKeys start] +seek :: CommandSeek +seek = withKeys start start :: Key -> CommandStart start key = ifM (inAnnex key) diff --git a/Command/Reinject.hs b/Command/Reinject.hs index c49af0060..1609c6097 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -17,8 +17,8 @@ def :: [Command] def = [command "reinject" (paramPair "SRC" "DEST") seek SectionUtility "sets content of annexed file"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [FilePath] -> CommandStart start (src:dest:[]) diff --git a/Command/Repair.hs b/Command/Repair.hs index 0f02a3ab3..c87317685 100644 --- a/Command/Repair.hs +++ b/Command/Repair.hs @@ -20,8 +20,8 @@ def :: [Command] def = [noCommit $ dontCheck repoExists $ command "repair" paramNothing seek SectionMaintenance "recover broken git repository"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = next $ next $ runRepair =<< Annex.getState Annex.force diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs index d3ded38a3..3f304b76e 100644 --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -16,8 +16,8 @@ def = [notBareRepo $ command "rmurl" (paramPair paramFile paramUrl) seek SectionCommon "record file is not available at url"] -seek :: [CommandSeek] -seek = [withPairs start] +seek :: CommandSeek +seek = withPairs start start :: (FilePath, String) -> CommandStart start (file, url) = flip whenAnnexed file $ \_ (key, _) -> do diff --git a/Command/Schedule.hs b/Command/Schedule.hs index db654f291..a088dbef8 100644 --- a/Command/Schedule.hs +++ b/Command/Schedule.hs @@ -21,8 +21,8 @@ def :: [Command] def = [command "schedule" (paramPair paramRemote (paramOptional paramExpression)) seek SectionSetup "get or set scheduled jobs"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start = parse diff --git a/Command/Semitrust.hs b/Command/Semitrust.hs index e20563672..26ce6961b 100644 --- a/Command/Semitrust.hs +++ b/Command/Semitrust.hs @@ -16,8 +16,8 @@ def :: [Command] def = [command "semitrust" (paramRepeating paramRemote) seek SectionSetup "return repository to default trust level"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start ws = do diff --git a/Command/SendKey.hs b/Command/SendKey.hs index 24b1821c3..488480e0a 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -20,8 +20,8 @@ def :: [Command] def = [noCommit $ command "sendkey" paramKey seek SectionPlumbing "runs rsync in server mode to send content"] -seek :: [CommandSeek] -seek = [withKeys start] +seek :: CommandSeek +seek = withKeys start start :: Key -> CommandStart start key = do diff --git a/Command/Status.hs b/Command/Status.hs index 27127b3ec..462d68e05 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -22,10 +22,8 @@ def = [notBareRepo $ noCommit $ noMessages $ withOptions [jsonOption] $ command "status" paramPaths seek SectionCommon "show the working tree status"] -seek :: [CommandSeek] -seek = - [ withWords start - ] +seek :: CommandSeek +seek = withWords start start :: [FilePath] -> CommandStart start [] = do diff --git a/Command/Sync.hs b/Command/Sync.hs index 1b5082700..25e54a56b 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -47,7 +47,7 @@ import Control.Concurrent.MVar def :: [Command] def = [withOptions syncOptions $ command "sync" (paramOptional (paramRepeating paramRemote)) - [seek] SectionCommon "synchronize local repository with remotes"] + seek SectionCommon "synchronize local repository with remotes"] syncOptions :: [Option] syncOptions = [ contentOption ] @@ -55,7 +55,6 @@ syncOptions = [ contentOption ] contentOption :: Option contentOption = Option.flag [] "content" "also transfer file contents" --- syncing involves several operations, any of which can independently fail seek :: CommandSeek seek rs = do prepMerge @@ -78,20 +77,16 @@ seek rs = do remotes <- syncRemotes rs let gitremotes = filter Remote.gitSyncableRemote remotes - synccontent <- ifM (Annex.getFlag $ Option.name contentOption) - ( withFilesInGit (whenAnnexed $ syncContent remotes) [] - , return [] - ) - - return $ concat - [ [ commit ] - , [ withbranch mergeLocal ] - , map (withbranch . pullRemote) gitremotes - , [ mergeAnnex ] - , synccontent - , [ withbranch pushLocal ] - , map (withbranch . pushRemote) gitremotes - ] + -- Syncing involves many actions, any of which can independently + -- fail, without preventing the others from running. + seekActions $ return [ commit ] + seekActions $ return [ withbranch mergeLocal ] + seekActions $ return $ map (withbranch . pullRemote) gitremotes + seekActions $ return [ mergeAnnex ] + whenM (Annex.getFlag $ Option.name contentOption) $ + withFilesInGit (whenAnnexed $ syncContent remotes) [] + seekActions $ return $ [ withbranch pushLocal ] + seekActions $ return $ map (withbranch . pushRemote) gitremotes {- Merging may delete the current directory, so go to the top - of the repo. This also means that sync always acts on all files in the diff --git a/Command/Test.hs b/Command/Test.hs index be480eeb7..47d72ee44 100644 --- a/Command/Test.hs +++ b/Command/Test.hs @@ -16,8 +16,8 @@ def = [ noRepo startIO $ dontCheck repoExists $ command "test" paramNothing seek SectionPlumbing "run built-in test suite"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start {- We don't actually run the test suite here because of a dependency loop. - The main program notices when the command is test and runs it; this diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs index 93f6c7077..796503133 100644 --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -19,8 +19,8 @@ def :: [Command] def = [noCommit $ command "transferinfo" paramKey seek SectionPlumbing "updates sender on number of bytes of content received"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start {- Security: - diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index 41a207080..f3856eb2e 100644 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -28,11 +28,12 @@ transferKeyOptions = fileOption : fromToOptions fileOption :: Option fileOption = Option.field [] "file" paramFile "the associated file" -seek :: [CommandSeek] -seek = [withField toOption Remote.byNameWithUUID $ \to -> - withField fromOption Remote.byNameWithUUID $ \from -> - withField fileOption return $ \file -> - withKeys $ start to from file] +seek :: CommandSeek +seek ps = do + to <- getOptionField toOption Remote.byNameWithUUID + from <- getOptionField fromOption Remote.byNameWithUUID + file <- getOptionField fileOption return + withKeys (start to from file) ps start :: Maybe Remote -> Maybe Remote -> AssociatedFile -> Key -> CommandStart start to from file key = diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 6d8db4ef2..9c05702be 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -25,8 +25,8 @@ def :: [Command] def = [command "transferkeys" paramNothing seek SectionPlumbing "transfers keys"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = withHandles $ \(readh, writeh) -> do diff --git a/Command/Trust.hs b/Command/Trust.hs index 26993ef77..3898af347 100644 --- a/Command/Trust.hs +++ b/Command/Trust.hs @@ -16,8 +16,8 @@ def :: [Command] def = [command "trust" (paramRepeating paramRemote) seek SectionSetup "trust a repository"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start ws = do diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 5e3c4279a..1f2978430 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -23,8 +23,8 @@ def :: [Command] def = [command "unannex" paramPaths seek SectionUtility "undo accidential add command"] -seek :: [CommandSeek] -seek = [withFilesInGit $ whenAnnexed start] +seek :: CommandSeek +seek = withFilesInGit $ whenAnnexed start start :: FilePath -> (Key, Backend) -> CommandStart start file (key, _) = stopUnless (inAnnex key) $ do diff --git a/Command/Ungroup.hs b/Command/Ungroup.hs index a6557f21d..a88e3f7c8 100644 --- a/Command/Ungroup.hs +++ b/Command/Ungroup.hs @@ -19,8 +19,8 @@ def :: [Command] def = [command "ungroup" (paramPair paramRemote paramDesc) seek SectionSetup "remove a repository from a group"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start (name:g:[]) = do diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 3fbe6758a..f608d03fe 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -34,12 +34,11 @@ check = do revhead = inRepo $ Git.Command.pipeReadStrict [Params "rev-parse --abbrev-ref HEAD"] -seek :: [CommandSeek] -seek = - [ withFilesNotInGit $ whenAnnexed startCheckIncomplete - , withFilesInGit $ whenAnnexed Command.Unannex.start - , withNothing start - ] +seek :: CommandSeek +seek ps = do + withFilesNotInGit (whenAnnexed startCheckIncomplete) ps + withFilesInGit (whenAnnexed Command.Unannex.start) ps + finish {- git annex symlinks that are not checked into git could be left by an - interrupted add. -} @@ -50,8 +49,8 @@ startCheckIncomplete file _ = error $ unlines , "Not continuing with uninit; either delete or git annex add the file and retry." ] -start :: CommandStart -start = next $ next $ do +finish :: Annex () +finish = do annexdir <- fromRepo gitAnnexDir annexobjectdir <- fromRepo gitAnnexObjectDir leftovers <- removeUnannexed =<< getKeysPresent diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 1eba26ff7..9f2c257fb 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -20,8 +20,8 @@ def = where c n = notDirect . command n paramPaths seek SectionCommon -seek :: [CommandSeek] -seek = [withFilesInGit $ whenAnnexed start] +seek :: CommandSeek +seek = withFilesInGit $ whenAnnexed start {- The unlock subcommand replaces the symlink with a copy of the file's - content. -} diff --git a/Command/Untrust.hs b/Command/Untrust.hs index f18637838..cde1eee93 100644 --- a/Command/Untrust.hs +++ b/Command/Untrust.hs @@ -16,8 +16,8 @@ def :: [Command] def = [command "untrust" (paramRepeating paramRemote) seek SectionSetup "do not trust a repository"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start ws = do diff --git a/Command/Unused.hs b/Command/Unused.hs index f99528cfa..19dc82007 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -45,8 +45,8 @@ def = [withOptions [fromOption] $ command "unused" paramNothing seek fromOption :: Option fromOption = Option.field ['f'] "from" paramRemote "remote to check for unused content" -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start {- Finds unused content in the annex. -} start :: CommandStart @@ -326,14 +326,14 @@ data UnusedMaps = UnusedMaps , unusedTmpMap :: UnusedMap } -{- Read unused logs once, and pass the maps to each start action. -} withUnusedMaps :: (UnusedMaps -> Int -> CommandStart) -> CommandSeek withUnusedMaps a params = do unused <- readUnusedLog "" unusedbad <- readUnusedLog "bad" unusedtmp <- readUnusedLog "tmp" let m = unused `M.union` unusedbad `M.union` unusedtmp - return $ map (a $ UnusedMaps unused unusedbad unusedtmp) $ + let unusedmaps = UnusedMaps unused unusedbad unusedtmp + seekActions $ return $ map (a unusedmaps) $ concatMap (unusedSpec m) params unusedSpec :: UnusedMap -> String -> [Int] @@ -349,8 +349,8 @@ unusedSpec m spec _ -> badspec badspec = error $ "Expected number or range, not \"" ++ spec ++ "\"" -{- Start action for unused content. Finds the number in the maps, and - - calls either of 3 actions, depending on the type of unused file. -} +{- Seek action for unused content. Finds the number in the maps, and + - calls one of 3 actions, depending on the type of unused file. -} startUnused :: String -> (Key -> CommandPerform) -> (Key -> CommandPerform) diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs index de34278dd..80876290a 100644 --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -16,8 +16,8 @@ def = [dontCheck repoExists $ -- because an old version may not seem to exist command "upgrade" paramNothing seek SectionMaintenance "upgrade repository layout"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = do diff --git a/Command/Version.hs b/Command/Version.hs index 0326b9ede..526b752f0 100644 --- a/Command/Version.hs +++ b/Command/Version.hs @@ -21,8 +21,8 @@ def :: [Command] def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $ command "version" paramNothing seek SectionQuery "show version info"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = do diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index 22c641408..7608959c2 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -30,8 +30,8 @@ def :: [Command] def = [command "vicfg" paramNothing seek SectionSetup "edit git-annex's configuration"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = do diff --git a/Command/Wanted.hs b/Command/Wanted.hs index 9ea0c211f..bae450d26 100644 --- a/Command/Wanted.hs +++ b/Command/Wanted.hs @@ -20,8 +20,8 @@ def :: [Command] def = [command "wanted" (paramPair paramRemote (paramOptional paramExpression)) seek SectionSetup "get or set preferred content expression"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start = parse diff --git a/Command/Watch.hs b/Command/Watch.hs index a33fc633c..bcfdf14bf 100644 --- a/Command/Watch.hs +++ b/Command/Watch.hs @@ -17,10 +17,11 @@ def :: [Command] def = [notBareRepo $ withOptions [foregroundOption, stopOption] $ command "watch" paramNothing seek SectionCommon "watch for changes"] -seek :: [CommandSeek] -seek = [withFlag stopOption $ \stopdaemon -> - withFlag foregroundOption $ \foreground -> - withNothing $ start False foreground stopdaemon Nothing] +seek :: CommandSeek +seek ps = do + stopdaemon <- getOptionFlag stopOption + foreground <- getOptionFlag foregroundOption + withNothing (start False foreground stopdaemon Nothing) ps foregroundOption :: Option foregroundOption = Option.flag [] "foreground" "do not daemonize" diff --git a/Command/WebApp.hs b/Command/WebApp.hs index a009be15d..a05984c4e 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -48,9 +48,10 @@ listenOption :: Option listenOption = Option.field [] "listen" paramAddress "accept connections to this address" -seek :: [CommandSeek] -seek = [withField listenOption return $ \listenhost -> - withNothing $ start listenhost] +seek :: CommandSeek +seek ps = do + listenhost <- getOptionField listenOption return + withNothing (start listenhost) ps start :: Maybe HostName -> CommandStart start = start' True @@ -107,7 +108,7 @@ startNoRepo _ = do (d:_) -> do setCurrentDirectory d state <- Annex.new =<< Git.CurrentRepo.get - void $ Annex.eval state $ doCommand $ + void $ Annex.eval state $ callCommand $ start' False listenhost {- Run the webapp without a repository, which prompts the user, makes one, diff --git a/Command/Whereis.hs b/Command/Whereis.hs index fcbbbf0d5..4030cf2f8 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -20,9 +20,10 @@ def = [noCommit $ withOptions [jsonOption] $ command "whereis" paramPaths seek SectionQuery "lists repositories that have file content"] -seek :: [CommandSeek] -seek = [withValue (remoteMap id) $ \m -> - withFilesInGit $ whenAnnexed $ start m] +seek :: CommandSeek +seek ps = do + m <- remoteMap id + withFilesInGit (whenAnnexed $ start m) ps start :: M.Map UUID Remote -> FilePath -> (Key, Backend) -> CommandStart start remotemap file (key, _) = do diff --git a/Command/XMPPGit.hs b/Command/XMPPGit.hs index 796e8b4ed..47c2d7ff2 100644 --- a/Command/XMPPGit.hs +++ b/Command/XMPPGit.hs @@ -16,8 +16,8 @@ def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $ command "xmppgit" paramNothing seek SectionPlumbing "git to XMPP relay"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start _ = do diff --git a/GitAnnexShell.hs b/GitAnnexShell.hs index b5f6804e7..7c3893be3 100644 --- a/GitAnnexShell.hs +++ b/GitAnnexShell.hs @@ -104,7 +104,7 @@ builtin cmd dir params = do Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath where addrsyncopts opts seek k = setField "RsyncOptions" opts >> seek k - newcmd opts c = c { cmdseek = map (addrsyncopts opts) (cmdseek c) } + newcmd opts c = c { cmdseek = addrsyncopts opts (cmdseek c) } external :: [String] -> IO () external params = do diff --git a/RunCommand.hs b/RunCommand.hs new file mode 100644 index 000000000..32a9c7d48 --- /dev/null +++ b/RunCommand.hs @@ -0,0 +1,64 @@ +{- git-annex running commands + - + - Copyright 2010-2014 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +module RunCommand where + +import Common.Annex +import qualified Annex +import Types.Command +import qualified Annex.Queue +import Annex.Exception + +{- Runs a command, starting with the check stage, and then + - the seek stage. Finishes by printing the number of commandActions that + - failed. -} +performCommand :: Command -> CmdParams -> Annex () +performCommand Command { cmdseek = seek, cmdcheck = c, cmdname = name } params = do + mapM_ runCheck c + Annex.changeState $ \s -> s { Annex.errcounter = 0 } + seek params + showerrcount =<< Annex.getState Annex.errcounter + where + showerrcount 0 = noop + showerrcount cnt = error $ name ++ ": " ++ show cnt ++ " failed" + +{- Runs one of the actions needed to perform a command. + - Individual actions can fail without stopping the whole command, + - including by throwing IO errors (but other errors terminate the whole + - command). + - + - This should only be run in the seek stage. -} +commandAction :: CommandStart -> Annex () +commandAction a = handle =<< tryAnnexIO go + where + go = do + Annex.Queue.flushWhenFull + callCommand a + handle (Right True) = noop + handle (Right False) = incerr + handle (Left err) = do + showErr err + showEndFail + incerr + incerr = Annex.changeState $ \s -> + let ! c = Annex.errcounter s + 1 + ! s' = s { Annex.errcounter = c } + in s' + +{- Runs a single command action through the start, perform and cleanup stages -} +callCommand :: CommandStart -> CommandCleanup +callCommand = start + where + start = stage $ maybe skip perform + perform = stage $ maybe failure cleanup + cleanup = stage $ status + stage = (=<<) + skip = return True + failure = showEndFail >> return False + status r = showEndResult r >> return r @@ -4,7 +4,7 @@ - the values a user passes to a command, and prepare actions operating - on them. - - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - Copyright 2010-2014 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -23,23 +23,14 @@ import qualified Git.Command import qualified Git.LsFiles as LsFiles import qualified Limit import qualified Option -import Config import Logs.Location import Logs.Unused import Annex.CatFile - -seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath] -seekHelper a params = do - ll <- inRepo $ \g -> - runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) params - {- Show warnings only for files/directories that do not exist. -} - forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p -> - unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $ - fileNotFound p - return $ concat ll +import RunCommand withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek -withFilesInGit a params = prepFiltered a $ seekHelper LsFiles.inRepo params +withFilesInGit a params = seekActions $ prepFiltered a $ + seekHelper LsFiles.inRepo params withFilesNotInGit :: (FilePath -> CommandStart) -> CommandSeek withFilesNotInGit a params = do @@ -47,7 +38,8 @@ withFilesNotInGit a params = do files <- filter (not . dotfile) <$> seekunless (null ps && not (null params)) ps dotfiles <- seekunless (null dotps) dotps - prepFiltered a $ return $ concat $ segmentPaths params (files++dotfiles) + seekActions $ prepFiltered a $ + return $ concat $ segmentPaths params (files++dotfiles) where (dotps, ps) = partition dotfile params seekunless True _ = return [] @@ -57,7 +49,8 @@ withFilesNotInGit a params = do liftIO $ Git.Command.leaveZombie <$> LsFiles.notInRepo force l g withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CommandSeek -withPathContents a params = map a . concat <$> liftIO (mapM get params) +withPathContents a params = seekActions $ + map a . concat <$> liftIO (mapM get params) where get p = ifM (isDirectory <$> getFileStatus p) ( map (\f -> (f, makeRelative (parentDir p) f)) @@ -66,20 +59,20 @@ withPathContents a params = map a . concat <$> liftIO (mapM get params) ) withWords :: ([String] -> CommandStart) -> CommandSeek -withWords a params = return [a params] +withWords a params = seekActions $ return [a params] withStrings :: (String -> CommandStart) -> CommandSeek -withStrings a params = return $ map a params +withStrings a params = seekActions $ return $ map a params withPairs :: ((String, String) -> CommandStart) -> CommandSeek -withPairs a params = return $ map a $ pairs [] params +withPairs a params = seekActions $ return $ map a $ pairs [] params where pairs c [] = reverse c pairs c (x:y:xs) = pairs ((x,y):c) xs pairs _ _ = error "expected pairs" withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek -withFilesToBeCommitted a params = prepFiltered a $ +withFilesToBeCommitted a params = seekActions $ prepFiltered a $ seekHelper LsFiles.stagedNotDeleted params withFilesUnlocked :: (FilePath -> CommandStart) -> CommandSeek @@ -94,7 +87,8 @@ withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged - not some other sort of symlink. -} withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> CommandSeek -withFilesUnlocked' typechanged a params = prepFiltered a unlockedfiles +withFilesUnlocked' typechanged a params = seekActions $ + prepFiltered a unlockedfiles where check f = liftIO (notSymlink f) <&&> (isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f) @@ -102,32 +96,25 @@ withFilesUnlocked' typechanged a params = prepFiltered a unlockedfiles {- Finds files that may be modified. -} withFilesMaybeModified :: (FilePath -> CommandStart) -> CommandSeek -withFilesMaybeModified a params = +withFilesMaybeModified a params = seekActions $ prepFiltered a $ seekHelper LsFiles.modified params withKeys :: (Key -> CommandStart) -> CommandSeek -withKeys a params = return $ map (a . parse) params +withKeys a params = seekActions $ return $ map (a . parse) params where parse p = fromMaybe (error "bad key") $ file2key p -withValue :: Annex v -> (v -> CommandSeek) -> CommandSeek -withValue v a params = do - r <- v - a r params - -{- Modifies a seek action using the value of a field option, which is fed into - - a conversion function, and then is passed into the seek action. - - This ensures that the conversion function only runs once. +{- Gets the value of a field options, which is fed into + - a conversion function. -} -withField :: Option -> (Maybe String -> Annex a) -> (a -> CommandSeek) -> CommandSeek -withField option converter = withValue $ - converter <=< Annex.getField $ Option.name option +getOptionField :: Option -> (Maybe String -> Annex a) -> Annex a +getOptionField option converter = converter <=< Annex.getField $ Option.name option -withFlag :: Option -> (Bool -> CommandSeek) -> CommandSeek -withFlag option = withValue $ Annex.getFlag (Option.name option) +getOptionFlag :: Option -> Annex Bool +getOptionFlag option = Annex.getFlag (Option.name option) withNothing :: CommandStart -> CommandSeek -withNothing a [] = return [a] +withNothing a [] = seekActions $ return [a] withNothing _ _ = error "This command takes no parameters." {- If --all is specified, or in a bare repo, runs an action on all @@ -159,7 +146,7 @@ withKeyOptions keyop fallbackop params = do unless (null params) $ error "Cannot mix --all or --unused with file names." matcher <- Limit.getMatcher - map (process matcher) <$> a + seekActions $ map (process matcher) <$> a process matcher k = ifM (matcher $ MatchingKey k) ( keyop k , return Nothing) @@ -171,11 +158,20 @@ prepFiltered a fs = do process matcher f = ifM (matcher $ MatchingFile $ FileInfo f f) ( a f , return Nothing ) -notSymlink :: FilePath -> IO Bool -notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f +seekActions :: Annex [CommandStart] -> Annex () +seekActions gen = do + as <- gen + mapM_ commandAction as -whenNotDirect :: CommandSeek -> CommandSeek -whenNotDirect a params = ifM isDirect ( return [] , a params ) +seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath] +seekHelper a params = do + ll <- inRepo $ \g -> + runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) params + {- Show warnings only for files/directories that do not exist. -} + forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p -> + unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $ + fileNotFound p + return $ concat ll -whenDirect :: CommandSeek -> CommandSeek -whenDirect a params = ifM isDirect ( a params, return [] ) +notSymlink :: FilePath -> IO Bool +notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f diff --git a/Types/Command.hs b/Types/Command.hs index d012c6e25..ecde75cae 100644 --- a/Types/Command.hs +++ b/Types/Command.hs @@ -18,9 +18,9 @@ import Types data CommandCheck = CommandCheck { idCheck :: Int, runCheck :: Annex () } {- b. The seek stage takes the parameters passed to the command, - looks through the repo to find the ones that are relevant - - to that command (ie, new files to add), and generates - - a list of start stage actions. -} -type CommandSeek = [String] -> Annex [CommandStart] + - to that command (ie, new files to add), and runs commandAction + - to handle all necessary actions. -} +type CommandSeek = [String] -> Annex () {- c. The start stage is run before anything is printed about the - command, is passed some input, and can early abort it - if the input does not make sense. It should run quickly and @@ -42,7 +42,7 @@ data Command = Command , cmdnomessages :: Bool -- don't output normal messages , cmdname :: String , cmdparamdesc :: String -- description of params for usage - , cmdseek :: [CommandSeek] -- seek stage + , cmdseek :: CommandSeek , cmdsection :: CommandSection , cmddesc :: String -- description of command for usage } |