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.
This commit is contained in:
Joey Hess 2014-01-20 04:11:42 -04:00
parent df5e2e3d65
commit 34c8af74ba
79 changed files with 389 additions and 355 deletions

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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 )

View file

@ -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 ->

View file

@ -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

View file

@ -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)

View file

@ -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."

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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
]
seek :: CommandSeek
seek ps = do
from <- getOptionField fromOption Remote.byNameWithUUID
i <- getIncremental
withKeyOptions
(startKey i)
(withFilesInGit $ whenAnnexed $ start from i)
ps
withIncremental :: (Incremental -> CommandSeek) -> CommandSeek
withIncremental = withValue $ do
getIncremental :: Annex Incremental
getIncremental = do
i <- maybe (return False) (checkschedule . parseDuration)
=<< Annex.getField (Option.name incrementalScheduleOption)
starti <- Annex.getFlag (Option.name startIncrementalOption)

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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) =

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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."

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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:[])

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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:
-

View file

@ -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 =

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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. -}

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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"

View file

@ -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,

View file

@ -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

View file

@ -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