From 329ec5d1e67f3a3ed6110fa4a97ec33ef1fbbdde Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 20 Jan 2014 04:11:42 -0400 Subject: fix inversion of control in CommandSeek (no behavior changes) I've been disliking how the command seek actions were written for some time, with their inversion of control and ugly workarounds. The last straw to fix it was sync --content, which didn't fit the Annex [CommandStart] interface well at all. I have not yet made it take advantage of the changed interface though. The crucial change, and probably why I didn't do it this way from the beginning, is to make each CommandStart action be run with exceptions caught, and if it fails, increment a failure counter in annex state. So I finally remove the very first code I wrote for git-annex, which was before I had exception handling in the Annex monad, and so ran outside that monad, passing state explicitly as it ran each CommandStart action. This was a real slog from 1 to 5 am. Test suite passes. Memory usage is lower than before, sometimes by a couple of megabytes, and remains constant, even when running in a large repo, and even when repeatedly failing and incrementing the error counter. So no accidental laziness space leaks. Wall clock speed is identical, even in large repos. This commit was sponsored by an anonymous bitcoiner. --- Annex.hs | 2 ++ Annex/Drop.hs | 2 +- CmdLine.hs | 45 ++++++--------------------- Command.hs | 29 ++++------------- Command/Add.hs | 24 +++++++-------- Command/AddUnused.hs | 4 +-- Command/AddUrl.hs | 11 ++++--- Command/Assistant.hs | 13 ++++---- Command/Commit.hs | 4 +-- Command/ConfigList.hs | 4 +-- Command/Copy.hs | 15 ++++----- Command/Dead.hs | 4 +-- Command/Describe.hs | 4 +-- Command/Direct.hs | 4 +-- Command/Drop.hs | 7 +++-- Command/DropKey.hs | 4 +-- Command/DropUnused.hs | 4 +-- Command/EnableRemote.hs | 4 +-- Command/ExamineKey.hs | 8 +++-- Command/Find.hs | 10 +++--- Command/Fix.hs | 4 +-- Command/Forget.hs | 7 +++-- Command/FromKey.hs | 4 +-- Command/Fsck.hs | 21 +++++++------ Command/FuzzTest.hs | 4 +-- Command/GCryptSetup.hs | 4 +-- Command/Get.hs | 13 ++++---- Command/Group.hs | 4 +-- Command/Help.hs | 4 +-- Command/Import.hs | 6 ++-- Command/ImportFeed.hs | 11 ++++--- Command/InAnnex.hs | 4 +-- Command/Indirect.hs | 4 +-- Command/Info.hs | 4 +-- Command/Init.hs | 4 +-- Command/InitRemote.hs | 4 +-- Command/List.hs | 16 +++++----- Command/Lock.hs | 6 ++-- Command/Log.hs | 13 ++++---- Command/LookupKey.hs | 4 +-- Command/Map.hs | 4 +-- Command/Merge.hs | 9 +++--- Command/Migrate.hs | 4 +-- Command/Mirror.hs | 15 ++++----- Command/Move.hs | 15 ++++----- Command/PreCommit.hs | 20 ++++++------ Command/ReKey.hs | 4 +-- Command/RecvKey.hs | 4 +-- Command/Reinject.hs | 4 +-- Command/Repair.hs | 4 +-- Command/RmUrl.hs | 4 +-- Command/Schedule.hs | 4 +-- Command/Semitrust.hs | 4 +-- Command/SendKey.hs | 4 +-- Command/Status.hs | 6 ++-- Command/Sync.hs | 27 +++++++--------- Command/Test.hs | 4 +-- Command/TransferInfo.hs | 4 +-- Command/TransferKey.hs | 11 ++++--- Command/TransferKeys.hs | 4 +-- Command/Trust.hs | 4 +-- Command/Unannex.hs | 4 +-- Command/Ungroup.hs | 4 +-- Command/Uninit.hs | 15 +++++---- Command/Unlock.hs | 4 +-- Command/Untrust.hs | 4 +-- Command/Unused.hs | 12 ++++---- Command/Upgrade.hs | 4 +-- Command/Version.hs | 4 +-- Command/Vicfg.hs | 4 +-- Command/Wanted.hs | 4 +-- Command/Watch.hs | 9 +++--- Command/WebApp.hs | 9 +++--- Command/Whereis.hs | 7 +++-- Command/XMPPGit.hs | 4 +-- GitAnnexShell.hs | 2 +- RunCommand.hs | 64 ++++++++++++++++++++++++++++++++++++++ Seek.hs | 82 +++++++++++++++++++++++-------------------------- Types/Command.hs | 8 ++--- 79 files changed, 390 insertions(+), 356 deletions(-) create mode 100644 RunCommand.hs diff --git a/Annex.hs b/Annex.hs index 023ca88e9..d8a2730ba 100644 --- a/Annex.hs +++ b/Annex.hs @@ -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 + - Copyright 2010-2014 Joey Hess - - 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 + - + - 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 diff --git a/Seek.hs b/Seek.hs index 3c84814f5..57bedfc84 100644 --- a/Seek.hs +++ b/Seek.hs @@ -4,7 +4,7 @@ - the values a user passes to a command, and prepare actions operating - on them. - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2014 Joey Hess - - 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 } -- cgit v1.2.3