mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

make CommandStart return a StartMessage

Browse source 
The goal is to be able to run CommandStart in the main thread when -J is
used, rather than unncessarily passing it off to a worker thread, which
incurs overhead that is signficant when the CommandStart is going to
quickly decide to stop.

To do that, the message it displays needs to be displayed in the worker
thread, after the CommandStart has run.

Also, the change will mean that CommandStart will no longer necessarily
run with the same Annex state as CommandPerform. While its docs already
said it should avoid modifying Annex state, I audited all the
CommandStart code as part of the conversion. (Note that CommandSeek
already sometimes runs with a different Annex state, and that has not been
a source of any problems, so I am not too worried that this change will
lead to breakage going forward.)

The only modification of Annex state I found was it calling
allowMessages in some Commands that default to noMessages. Dealt with
that by adding a startCustomOutput and a startingUsualMessages.
This lets a command start with noMessages and then select the output it
wants for each CommandStart.

One bit of breakage: onlyActionOn has been removed from commands that used it.
The plan is that, since a StartMessage contains an ActionItem,
when a Key can be extracted from that, the parallel job runner can
run onlyActionOn' automatically. Then commands won't need to worry about
this detail. Future work.

Otherwise, this was a fairly straightforward process of making each
CommandStart compile again. Hopefully other behavior changes were mostly
avoided.

In a few cases, a command had a CommandStart that called a CommandPerform
that then called showStart multiple times. I have collapsed those
down to a single start action. The main command to perhaps suffer from it
is Command.Direct, which used to show a start for each file, and no
longer does.

Another minor behavior change is that some commands used showStart
before, but had an associated file and a Key available, so were changed
to ShowStart with an ActionItemAssociatedFile. That will not change the
normal output or behavior, but --json output will now include the key.
This should not break it for anyone using a real json parser.
This commit is contained in:
Joey Hess 2019-06-06 15:42:30 -04:00
parent 258a7c5cd1
commit 436f107715
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
76 changed files with 522 additions and 566 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
Annex/Import.hs
View file

@ -326,11 +326,11 @@ downloadImport remote importtreeconfig importablecontents = do
(k:_) -> return $ Left $ Just (loc, k)
[] -> do
job <- liftIO $ newEmptyTMVarIO
let downloadaction = do
showStart ("import " ++ Remote.name remote) (fromImportLocation loc)
let ai = ActionItemOther (Just (fromImportLocation loc))
let downloadaction = starting ("import " ++ Remote.name remote) ai $ do
when oldversion $
showNote "old version"
next $ tryNonAsync (download cidmap db i) >>= \case
tryNonAsync (download cidmap db i) >>= \case
Left e -> next $ do
warning (show e)
liftIO $ atomically $

25
CmdLine/Action.hs
View file

@ -196,17 +196,16 @@ callCommandAction' a = callCommandActionQuiet a >>= \case
Just r -> implicitMessage (showEndResult r) >> return (Just r)
callCommandActionQuiet :: CommandStart -> Annex (Maybe Bool)
callCommandActionQuiet = start
where
start = stage $ maybe skip perform
perform = stage $ maybe failure $ \a -> do
changeStageTo CleanupStage
cleanup a
cleanup = stage $ status
stage = (=<<)
skip = return Nothing
failure = return (Just False)
status = return . Just
callCommandActionQuiet start =
start >>= \case
Nothing -> return Nothing
Just (startmsg, perform) -> do
showStartMessage startmsg
perform >>= \case
Nothing -> return (Just False)
Just cleanup -> do
changeStageTo CleanupStage
Just <$> cleanup
{- Do concurrent output when that has been requested. -}
allowConcurrentOutput :: Annex a -> Annex a
@ -255,6 +254,7 @@ allowConcurrentOutput a = do
{- Ensures that only one thread processes a key at a time.
- Other threads will block until it's done. -}
{-
onlyActionOn :: Key -> CommandStart -> CommandStart
onlyActionOn k a = onlyActionOn' k run
where
@ -263,7 +263,10 @@ onlyActionOn k a = onlyActionOn' k run
run = callCommandActionQuiet a >>= \case
Nothing -> return Nothing
Just r' -> return $ Just $ return $ Just $ return r'
-}
{- Ensures that only one thread processes a key at a time.
- Other threads will block until it's done. -}
onlyActionOn' :: Key -> Annex a -> Annex a
onlyActionOn' k a = go =<< Annex.getState Annex.concurrency
where

1
CmdLine/Seek.hs
View file

@ -24,7 +24,6 @@ import qualified Limit
import CmdLine.GitAnnex.Options
import Logs.Location
import Logs.Unused
import Types.ActionItem
import Types.Transfer
import Logs.Transfer
import Remote.List

32
Command.hs
View file

@ -22,14 +22,12 @@ import CmdLine.GlobalSetter as ReExported
import CmdLine.GitAnnex.Options as ReExported
import CmdLine.Batch as ReExported
import Options.Applicative as ReExported hiding (command)
import qualified Annex
import qualified Git
import Annex.Init
import Config
import Utility.Daemon
import Types.Transfer
import Types.ActionItem
import Types.Messages
{- Generates a normal Command -}
command :: String -> CommandSection -> String -> CmdParamsDesc -> (CmdParamsDesc -> CommandParser) -> Command
@ -61,19 +59,11 @@ noCommit c = c { cmdnocommit = True }
- starting or stopping processing a file or other item. Unless --json mode
- is enabled, this also enables quiet output mode, so only things
- explicitly output by the command are shown and not progress messages
- etc. -}
- etc.
-}
noMessages :: Command -> Command
noMessages c = c { cmdnomessages = True }
{- Undoes noMessages -}
allowMessages :: Annex ()
allowMessages = do
outputType <$> Annex.getState Annex.output >>= \case
QuietOutput -> Annex.setOutput NormalOutput
_ -> noop
Annex.changeState $ \s -> s
{ Annex.output = (Annex.output s) { implicitMessages = True } }
{- Adds a fallback action to a command, that will be run if it's used
- outside a git repository. -}
noRepo :: (String -> Parser (IO ())) -> Command -> Command
@ -83,11 +73,25 @@ noRepo a c = c { cmdnorepo = Just (a (cmdparamdesc c)) }
withGlobalOptions :: [[GlobalOption]] -> Command -> Command
withGlobalOptions os c = c { cmdglobaloptions = cmdglobaloptions c ++ concat os }
{- For start and perform stages to indicate what step to run next. -}
{- For start stage to indicate what will be done. -}
starting:: MkActionItem t => String -> t -> CommandPerform -> CommandStart
starting msg t a = next (StartMessage msg (mkActionItem t), a)
{- Use when noMessages was used but the command is going to output
- usual messages after all. -}
startingUsualMessages :: MkActionItem t => String -> t -> CommandPerform -> CommandStart
startingUsualMessages msg t a = next (StartUsualMessages msg (mkActionItem t), a)
{- For commands that do not display usual start or end messages,
- but have some other custom output. -}
startingCustomOutput :: CommandPerform -> CommandStart
startingCustomOutput a = next (CustomOutput, a)
{- For perform stage to indicate what step to run next. -}
next :: a -> Annex (Maybe a)
next a = return $ Just a
{- Or to indicate nothing needs to be done. -}
{- For start and perform stage to indicate nothing needs to be done. -}
stop :: Annex (Maybe a)
stop = return Nothing

25
Command/Add.hs
View file

@ -78,9 +78,8 @@ seek o = allowConcurrentOutput $ do
{- Pass file off to git-add. -}
startSmall :: FilePath -> CommandStart
startSmall file = do
showStart "add" file
next $ next $ addSmall file
startSmall file = starting "add" (ActionItemWorkTreeFile file) $
next $ addSmall file
addSmall :: FilePath -> Annex Bool
addSmall file = do
@ -107,11 +106,11 @@ start file = do
Nothing -> stop
Just s
| not (isRegularFile s) && not (isSymbolicLink s) -> stop
| otherwise -> do
showStart "add" file
next $ if isSymbolicLink s
then next $ addFile file
else perform file
| otherwise ->
starting "add" (ActionItemWorkTreeFile file) $
if isSymbolicLink s
then next $ addFile file
else perform file
addpresent key = ifM versionSupportsUnlockedPointers
( liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case
Just s | isSymbolicLink s -> fixuplink key
@ -124,18 +123,16 @@ start file = do
, fixuplink key
)
)
fixuplink key = do
fixuplink key = starting "add" (ActionItemWorkTreeFile file) $ do
-- the annexed symlink is present but not yet added to git
showStart "add" file
liftIO $ removeFile file
addLink file key Nothing
next $ next $
next $
cleanup key =<< inAnnex key
fixuppointer key = do
fixuppointer key = starting "add" (ActionItemWorkTreeFile file) $ do
-- the pointer file is present, but not yet added to git
showStart "add" file
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
next $ next $ addFile file
next $ addFile file
perform :: FilePath -> CommandPerform
perform file = withOtherTmp $ \tmpdir -> do

24
Command/AddUrl.hs
View file

@ -124,10 +124,9 @@ checkUrl r o u = do
(Remote.checkUrl r)
where
go _ (Left e) = void $ commandAction $ do
showStartAddUrl u o
go _ (Left e) = void $ commandAction $ startingAddUrl u o $ do
warning (show e)
next $ next $ return False
next $ return False
go deffile (Right (UrlContents sz mf)) = do
let f = adjustFile o (fromMaybe (maybe deffile fromSafeFilePath mf) (fileOption (downloadOptions o)))
void $ commandAction $ startRemote r o f u sz
@ -151,10 +150,10 @@ startRemote :: Remote -> AddUrlOptions -> FilePath -> URLString -> Maybe Integer
startRemote r o file uri sz = do
pathmax <- liftIO $ fileNameLengthLimit "."
let file' = joinPath $ map (truncateFilePath pathmax) $ splitDirectories file
showStartAddUrl uri o
showNote $ "from " ++ Remote.name r
showDestinationFile file'
next $ performRemote r o uri file' sz
startingAddUrl uri o $ do
showNote $ "from " ++ Remote.name r
showDestinationFile file'
performRemote r o uri file' sz
performRemote :: Remote -> AddUrlOptions -> URLString -> FilePath -> Maybe Integer -> CommandPerform
performRemote r o uri file sz = ifAnnexed file adduri geturi
@ -194,8 +193,7 @@ startWeb o urlstring = go $ fromMaybe bad $ parseURI urlstring
where
bad = fromMaybe (giveup $ "bad url " ++ urlstring) $
Url.parseURIRelaxed $ urlstring
go url = do
showStartAddUrl urlstring o
go url = startingAddUrl urlstring o $ do
pathmax <- liftIO $ fileNameLengthLimit "."
urlinfo <- if relaxedOption (downloadOptions o)
then pure Url.assumeUrlExists
@ -212,7 +210,7 @@ startWeb o urlstring = go $ fromMaybe bad $ parseURI urlstring
( pure $ url2file url (pathdepthOption o) pathmax
, pure f
)
next $ performWeb o urlstring file urlinfo
performWeb o urlstring file urlinfo
performWeb :: AddUrlOptions -> URLString -> FilePath -> Url.UrlInfo -> CommandPerform
performWeb o url file urlinfo = ifAnnexed file addurl geturl
@ -323,12 +321,12 @@ downloadWeb o url urlinfo file =
{- The destination file is not known at start time unless the user provided
- a filename. It's not displayed then for output consistency,
- but is added to the json when available. -}
showStartAddUrl :: URLString -> AddUrlOptions -> Annex ()
showStartAddUrl url o = do
showStart' "addurl" (Just url)
startingAddUrl :: URLString -> AddUrlOptions -> CommandPerform -> CommandStart
startingAddUrl url o p = starting "addurl" (ActionItemOther (Just url)) $ do
case fileOption (downloadOptions o) of
Nothing -> noop
Just file -> maybeShowJSON $ JSONChunk [("file", file)]
p
showDestinationFile :: FilePath -> Annex ()
showDestinationFile file = do

4
Command/Adjust.hs
View file

@ -47,5 +47,5 @@ seek = commandAction . start
start :: Adjustment -> CommandStart
start adj = do
checkVersionSupported
showStart' "adjust" Nothing
next $ next $ enterAdjustedBranch adj
starting "adjust" (ActionItemOther Nothing) $
next $ enterAdjustedBranch adj

8
Command/Commit.hs
View file

@ -20,10 +20,10 @@ seek :: CmdParams -> CommandSeek
seek = withNothing (commandAction start)
start :: CommandStart
start = next $ next $ do
Annex.Branch.commit =<< Annex.Branch.commitMessage
_ <- runhook <=< inRepo $ Git.hookPath "annex-content"
return True
start = starting "commit" (ActionItemOther (Just "git-annex")) $ do
Annex.Branch.commit =<< Annex.Branch.commitMessage
_ <- runhook <=< inRepo $ Git.hookPath "annex-content"
next $ return True
where
runhook (Just hook) = liftIO $ boolSystem hook []
runhook Nothing = return True

26
Command/Config.hs
View file

@ -48,23 +48,19 @@ optParser _ = setconfig <|> getconfig <|> unsetconfig
)
seek :: Action -> CommandSeek
seek (SetConfig name val) = commandAction $ do
allowMessages
showStart' name (Just val)
next $ next $ do
seek (SetConfig name val) = commandAction $
startingUsualMessages name (ActionItemOther (Just val)) $ do
setGlobalConfig name val
setConfig (ConfigKey name) val
return True
seek (UnsetConfig name) = commandAction $ do
allowMessages
showStart' name (Just "unset")
next $ next $ do
next $ return True
seek (UnsetConfig name) = commandAction $
startingUsualMessages name (ActionItemOther (Just "unset")) $do
unsetGlobalConfig name
unsetConfig (ConfigKey name)
return True
next $ return True
seek (GetConfig name) = commandAction $
getGlobalConfig name >>= \case
Nothing -> stop
Just v -> do
liftIO $ putStrLn v
stop
startingCustomOutput $ do
getGlobalConfig name >>= \case
Nothing -> return ()
Just v -> liftIO $ putStrLn v
next $ return True

5
Command/Dead.hs
View file

@ -32,10 +32,9 @@ seek (DeadRemotes rs) = trustCommand "dead" DeadTrusted rs
seek (DeadKeys ks) = commandActions $ map startKey ks
startKey :: Key -> CommandStart
startKey key = do
showStart' "dead" (Just $ serializeKey key)
startKey key = starting "dead" (mkActionItem key) $
keyLocations key >>= \case
[] -> next $ performKey key
[] -> performKey key
_ -> giveup "This key is still known to be present in some locations; not marking as dead."
performKey :: Key -> CommandPerform

4
Command/Describe.hs
View file

@ -22,9 +22,9 @@ seek = withWords (commandAction . start)
start :: [String] -> CommandStart
start (name:description) | not (null description) = do
showStart' "describe" (Just name)
u <- Remote.nameToUUID name
next $ perform u $ unwords description
starting "describe" (ActionItemOther (Just name)) $
perform u $ unwords description
start _ = giveup "Specify a repository and a description."
perform :: UUID -> String -> CommandPerform

30
Command/Direct.hs
View file

@ -25,44 +25,38 @@ seek = withNothing (commandAction start)
start :: CommandStart
start = ifM versionSupportsDirectMode
( ifM isDirect ( stop , next perform )
( ifM isDirect
( stop
, starting "direct" (ActionItemOther Nothing)
perform
)
, giveup "Direct mode is not supported by this repository version. Use git-annex unlock instead."
)
perform :: CommandPerform
perform = do
showStart' "commit" Nothing
showOutput
_ <- inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit
[ Param "-a"
, Param "-m"
, Param "commit before switching to direct mode"
]
showEndOk
top <- fromRepo Git.repoPath
(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
forM_ l go
void $ liftIO clean
next cleanup
next $ return True
where
go = whenAnnexed $ \f k -> do
toDirectGen k f >>= \case
Nothing -> noop
Just a -> do
showStart "direct" f
tryNonAsync a >>= \case
Left e -> warnlocked e
Right _ -> showEndOk
Just a -> tryNonAsync a >>= \case
Left e -> warnlocked f e
Right _ -> return ()
return Nothing
warnlocked :: SomeException -> Annex ()
warnlocked e = do
warning $ show e
warnlocked :: FilePath -> SomeException -> Annex ()
warnlocked f e = do
warning $ f ++ ": " ++ show e
warning "leaving this file as-is; correct this problem and run git annex fsck on it"
cleanup :: CommandCleanup
cleanup = do
showStart' "direct" Nothing
setDirect True
return True

15
Command/Drop.hs
View file

@ -69,7 +69,7 @@ start o file key = start' o key afile ai
ai = mkActionItem (key, afile)
start' :: DropOptions -> Key -> AssociatedFile -> ActionItem -> CommandStart
start' o key afile ai = onlyActionOn key $ do
start' o key afile ai = do
from <- maybe (pure Nothing) (Just <$$> getParsed) (dropFrom o)
checkDropAuto (autoMode o) from afile key $ \numcopies ->
stopUnless (want from) $
@ -89,14 +89,15 @@ startKeys :: DropOptions -> (Key, ActionItem) -> CommandStart
startKeys o (key, ai) = start' o key (AssociatedFile Nothing) ai
startLocal :: AssociatedFile -> ActionItem -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart
startLocal afile ai numcopies key preverified = stopUnless (inAnnex key) $ do
showStartKey "drop" key ai
next $ performLocal key afile numcopies preverified
startLocal afile ai numcopies key preverified =
stopUnless (inAnnex key) $
starting "drop" ai $
performLocal key afile numcopies preverified
startRemote :: AssociatedFile -> ActionItem -> NumCopies -> Key -> Remote -> CommandStart
startRemote afile ai numcopies key remote = do
showStartKey ("drop " ++ Remote.name remote) key ai
next $ performRemote key afile numcopies remote
startRemote afile ai numcopies key remote =
starting ("drop " ++ Remote.name remote) ai $
performRemote key afile numcopies remote
performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform
performLocal key afile numcopies preverified = lockContentForRemoval key $ \contentlock -> do

5
Command/DropKey.hs
View file

@ -41,9 +41,8 @@ seek o = do
parsekey = maybe (Left "bad key") Right . deserializeKey
start :: Key -> CommandStart
start key = do
showStartKey "dropkey" key (mkActionItem key)
next $ perform key
start key = starting "dropkey" (mkActionItem key) $
perform key
perform :: Key -> CommandPerform
perform key = ifM (inAnnex key)

28
Command/EnableRemote.hs
View file

@ -54,13 +54,11 @@ start (name:rest) = go =<< filter matchingname <$> Annex.getGitRemotes
-- the remote uuid.
startNormalRemote :: Git.RemoteName -> [String] -> Git.Repo -> CommandStart
startNormalRemote name restparams r
| null restparams = do
showStart' "enableremote" (Just name)
next $ next $ do
setRemoteIgnore r False
r' <- Remote.Git.configRead False r
u <- getRepoUUID r'
return $ u /= NoUUID
| null restparams = starting "enableremote" (ActionItemOther (Just name)) $ do
setRemoteIgnore r False
r' <- Remote.Git.configRead False r
u <- getRepoUUID r'
next $ return $ u /= NoUUID
| otherwise = giveup $
"That is a normal git remote; passing these parameters does not make sense: " ++ unwords restparams
@ -73,14 +71,14 @@ startSpecialRemote name config Nothing = do
startSpecialRemote name config $
Just (u, fromMaybe M.empty (M.lookup u confm))
_ -> unknownNameError "Unknown remote name."
startSpecialRemote name config (Just (u, c)) = do
let fullconfig = config `M.union` c
t <- either giveup return (Annex.SpecialRemote.findType fullconfig)
showStart' "enableremote" (Just name)
gc <- maybe (liftIO dummyRemoteGitConfig)
(return . Remote.gitconfig)
=<< Remote.byUUID u
next $ performSpecialRemote t u c fullconfig gc
startSpecialRemote name config (Just (u, c)) =
starting "enableremote" (ActionItemOther (Just name)) $ do
let fullconfig = config `M.union` c
t <- either giveup return (Annex.SpecialRemote.findType fullconfig)
gc <- maybe (liftIO dummyRemoteGitConfig)
(return . Remote.gitconfig)
=<< Remote.byUUID u
performSpecialRemote t u c fullconfig gc
performSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> CommandPerform
performSpecialRemote t u oldc c gc = do

5
Command/EnableTor.hs
View file

@ -51,15 +51,14 @@ start os = do
then case readish =<< headMaybe os of
Nothing -> giveup "Need user-id parameter."
Just userid -> go uuid userid
else do
showStart' "enable-tor" Nothing
else starting "enable-tor" (ActionItemOther Nothing) $ do
gitannex <- liftIO readProgramFile
let ps = [Param (cmdname cmd), Param (show curruserid)]
sucommand <- liftIO $ mkSuCommand gitannex ps
maybe noop showLongNote
(describePasswordPrompt' sucommand)
ifM (liftIO $ runSuCommand sucommand)
( next $ next checkHiddenService
( next checkHiddenService
, giveup $ unwords $
[ "Failed to run as root:" , gitannex ] ++ toCommand ps
)

29
Command/Expire.hs
View file

@ -58,16 +58,18 @@ seek o = do
start :: Expire -> Bool -> Log Activity -> UUIDDescMap -> UUID -> CommandStart
start (Expire expire) noact actlog descs u =
case lastact of
Just ent | notexpired ent -> checktrust (== DeadTrusted) $ do
showStart' "unexpire" (Just desc)
showNote =<< whenactive
unless noact $
trustSet u SemiTrusted
_ -> checktrust (/= DeadTrusted) $ do
showStart' "expire" (Just desc)
showNote =<< whenactive
unless noact $
trustSet u DeadTrusted
Just ent | notexpired ent -> checktrust (== DeadTrusted) $
starting "unexpire" (ActionItemOther (Just desc)) $ do
showNote =<< whenactive
unless noact $
trustSet u SemiTrusted
next $ return True
_ -> checktrust (/= DeadTrusted) $
starting "expire" (ActionItemOther (Just desc)) $ do
showNote =<< whenactive
unless noact $
trustSet u DeadTrusted
next $ return True
where
lastact = changed <$> M.lookup u actlog
whenactive = case lastact of
@ -83,12 +85,7 @@ start (Expire expire) noact actlog descs u =
_ -> True
lookupexpire = headMaybe $ catMaybes $
map (`M.lookup` expire) [Just u, Nothing]
checktrust want a = ifM (want <$> lookupTrust u)
( do
void a
next $ next $ return True
, stop
)
checktrust want = stopUnless (want <$> lookupTrust u)
data Expire = Expire (M.Map (Maybe UUID) (Maybe POSIXTime))

44
Command/Export.hs
View file

@ -249,14 +249,14 @@ fillExport r db (PreferredFiltered newtree) mtbcommitsha = do
startExport :: Remote -> ExportHandle -> MVar FileUploaded -> MVar AllFilled -> Git.LsTree.TreeItem -> CommandStart
startExport r db cvar allfilledvar ti = do
ek <- exportKey (Git.LsTree.sha ti)
stopUnless (notrecordedpresent ek) $ do
showStart ("export " ++ name r) f
ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc))
( next $ next $ cleanupExport r db ek loc False
, do
liftIO $ modifyMVar_ cvar (pure . const (FileUploaded True))
next $ performExport r db ek af (Git.LsTree.sha ti) loc allfilledvar
)
stopUnless (notrecordedpresent ek) $
starting ("export " ++ name r) (ActionItemOther (Just f)) $
ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc))
( next $ cleanupExport r db ek loc False
, do
liftIO $ modifyMVar_ cvar (pure . const (FileUploaded True))
performExport r db ek af (Git.LsTree.sha ti) loc allfilledvar
)
where
loc = mkExportLocation f
f = getTopFilePath (Git.LsTree.file ti)
@ -313,17 +313,15 @@ startUnexport r db f shas = do
eks <- forM (filter (/= nullSha) shas) exportKey
if null eks
then stop
else do
showStart ("unexport " ++ name r) f'
next $ performUnexport r db eks loc
else starting ("unexport " ++ name r) (ActionItemOther (Just f')) $
performUnexport r db eks loc
where
loc = mkExportLocation f'
f' = getTopFilePath f
startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
startUnexport' r db f ek = do
showStart ("unexport " ++ name r) f'
next $ performUnexport r db [ek] loc
startUnexport' r db f ek = starting ("unexport " ++ name r) (ActionItemOther (Just f')) $
performUnexport r db [ek] loc
where
loc = mkExportLocation f'
f' = getTopFilePath f
@ -365,17 +363,17 @@ startRecoverIncomplete r db sha oldf
| otherwise = do
ek <- exportKey sha
let loc = exportTempName ek
showStart ("unexport " ++ name r) (fromExportLocation loc)
liftIO $ removeExportedLocation db (asKey ek) oldloc
next $ performUnexport r db [ek] loc
starting ("unexport " ++ name r) (ActionItemOther (Just (fromExportLocation loc))) $ do
liftIO $ removeExportedLocation db (asKey ek) oldloc
performUnexport r db [ek] loc
where
oldloc = mkExportLocation oldf'
oldf' = getTopFilePath oldf
startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
startMoveToTempName r db f ek = do
showStart ("rename " ++ name r) (f' ++ " -> " ++ fromExportLocation tmploc)
next $ performRename r db ek loc tmploc
startMoveToTempName r db f ek = starting ("rename " ++ name r)
(ActionItemOther $ Just $ f' ++ " -> " ++ fromExportLocation tmploc)
(performRename r db ek loc tmploc)
where
loc = mkExportLocation f'
f' = getTopFilePath f
@ -384,9 +382,9 @@ startMoveToTempName r db f ek = do
startMoveFromTempName :: Remote -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart
startMoveFromTempName r db ek f = do
let tmploc = exportTempName ek
stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $ do
showStart ("rename " ++ name r) (fromExportLocation tmploc ++ " -> " ++ f')
next $ performRename r db ek tmploc loc
stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $
starting ("rename " ++ name r) (ActionItemOther (Just (fromExportLocation tmploc ++ " -> " ++ f'))) $
performRename r db ek tmploc loc
where
loc = mkExportLocation f'
f' = getTopFilePath f

12
Command/Find.hs
View file

@ -14,7 +14,6 @@ import Command
import Annex.Content
import Limit
import Types.Key
import Types.ActionItem
import Git.FilePath
import qualified Utility.Format
import Utility.DataUnits
@ -65,12 +64,11 @@ seek o = case batchOption o of
-- only files inAnnex are shown, unless the user has requested
-- others via a limit
start :: FindOptions -> FilePath -> Key -> CommandStart
start o file key = ifM (limited <||> inAnnex key)
( do
showFormatted (formatOption o) file $ ("file", file) : keyVars key
next $ next $ return True
, stop
)
start o file key =
stopUnless (limited <||> inAnnex key) $
startingCustomOutput $ do
showFormatted (formatOption o) file $ ("file", file) : keyVars key
next $ return True
startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart
startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) =

4
Command/Fix.hs
View file

@ -54,9 +54,7 @@ start fixwhat file key = do
FixAll -> fixthin
FixSymlinks -> stop
where
fixby a = do
showStart "fix" file
next a
fixby = starting "fix" (mkActionItem (key, file))
fixthin = do
obj <- calcRepo $ gitAnnexLocation key
stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do

5
Command/Forget.hs
View file

@ -33,14 +33,13 @@ seek :: ForgetOptions -> CommandSeek
seek = commandAction . start
start :: ForgetOptions -> CommandStart
start o = do
showStart' "forget" (Just "git-annex")
start o = starting "forget" (ActionItemOther (Just "git-annex")) $ do
c <- liftIO currentVectorClock
let basets = addTransition c ForgetGitHistory noTransitions
let ts = if dropDead o
then addTransition c ForgetDeadRemotes basets
else basets
next $ perform ts =<< Annex.getState Annex.force
perform ts =<< Annex.getState Annex.force
perform :: Transitions -> Bool -> CommandPerform
perform ts True = do

9
Command/FromKey.hs
View file

@ -51,9 +51,8 @@ seekBatch fmt = batchInput fmt parse commandAction
in if not (null keyname) && not (null file)
then Right $ go file (mkKey keyname)
else Left "Expected pairs of key and filename"
go file key = do
showStart "fromkey" file
next $ perform key file
go file key = starting "fromkey" (mkActionItem (key, file)) $
perform key file
start :: Bool -> (String, FilePath) -> CommandStart
start force (keyname, file) = do
@ -62,8 +61,8 @@ start force (keyname, file) = do
inbackend <- inAnnex key
unless inbackend $ giveup $
"key ("++ keyname ++") is not present in backend (use --force to override this sanity check)"
showStart "fromkey" file
next $ perform key file
starting "fromkey" (mkActionItem (key, file)) $
perform key file
-- From user input to a Key.
-- User can input either a serialized key, or an url.

16
Command/Fsck.hs
View file

@ -586,16 +586,12 @@ badContentRemote remote localcopy key = do
(_, False) -> "failed to drop from" ++ Remote.name remote
runFsck :: Incremental -> ActionItem -> Key -> Annex Bool -> CommandStart
runFsck inc ai key a = ifM (needFsck inc key)
( do
showStartKey "fsck" key ai
next $ do
ok <- a
when ok $
recordFsckTime inc key
next $ return ok
, stop
)
runFsck inc ai key a = stopUnless (needFsck inc key) $
starting "fsck" ai $ do
ok <- a
when ok $
recordFsckTime inc key
next $ return ok
{- Check if a key needs to be fscked, with support for incremental fscks. -}
needFsck :: Incremental -> Key -> Annex Bool

4
Command/GCryptSetup.hs
View file

@ -22,7 +22,7 @@ seek :: CmdParams -> CommandSeek
seek = withStrings (commandAction . start)
start :: String -> CommandStart
start gcryptid = next $ next $ do
start gcryptid = starting "gcryptsetup" (ActionItemOther Nothing) $ do
u <- getUUID
when (u /= NoUUID) $
giveup "gcryptsetup refusing to run; this repository already has a git-annex uuid!"
@ -34,6 +34,6 @@ start gcryptid = next $ next $ do
then if Git.repoIsLocalBare g
then do
void $ Remote.GCrypt.setupRepo gcryptid g
return True
next $ return True
else giveup "cannot use gcrypt in a non-bare repository"
else giveup "gcryptsetup uuid mismatch"

6
Command/Get.hs
View file

@ -63,7 +63,7 @@ startKeys from (key, ai) = checkFailedTransferDirection ai Download $
start' (return True) from key (AssociatedFile Nothing) ai
start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart
start' expensivecheck from key afile ai = onlyActionOn key $
start' expensivecheck from key afile ai =
stopUnless (not <$> inAnnex key) $ stopUnless expensivecheck $
case from of
Nothing -> go $ perform key afile
@ -71,9 +71,7 @@ start' expensivecheck from key afile ai = onlyActionOn key $
stopUnless (Command.Move.fromOk src key) $
go $ Command.Move.fromPerform src Command.Move.RemoveNever key afile
where
go a = do
showStartKey "get" key ai
next a
go = starting "get" ai
perform :: Key -> AssociatedFile -> CommandPerform
perform key afile = stopUnless (getKey key afile) $

11
Command/Group.hs
View file

@ -23,14 +23,15 @@ seek = withWords (commandAction . start)
start :: [String] -> CommandStart
start (name:g:[]) = do
allowMessages
showStart' "group" (Just name)
u <- Remote.nameToUUID name
next $ setGroup u (toGroup g)
startingUsualMessages "group" (ActionItemOther (Just name)) $
setGroup u (toGroup g)
start (name:[]) = do
u <- Remote.nameToUUID name
liftIO . putStrLn . unwords . map fmt . S.toList =<< lookupGroups u
stop
startingCustomOutput $ do
liftIO . putStrLn . unwords . map fmt . S.toList
=<< lookupGroups u
next $ return True
where
fmt (Group g) = decodeBS g
start _ = giveup "Specify a repository and a group."

9
Command/GroupWanted.hs
View file

@ -22,9 +22,8 @@ seek :: CmdParams -> CommandSeek
seek = withWords (commandAction . start)
start :: [String] -> CommandStart
start (g:[]) = next $ performGet groupPreferredContentMapRaw (toGroup g)
start (g:expr:[]) = do
allowMessages
showStart' "groupwanted" (Just g)
next $ performSet groupPreferredContentSet expr (toGroup g)
start (g:[]) = startingCustomOutput $
performGet groupPreferredContentMapRaw (toGroup g)
start (g:expr:[]) = startingUsualMessages "groupwanted" (ActionItemOther (Just g)) $
performSet groupPreferredContentSet expr (toGroup g)
start _ = giveup "Specify a group."

15
Command/Import.hs
View file

@ -117,9 +117,8 @@ seek o@(RemoteImportOptions {}) = allowConcurrentOutput $ do
startLocal :: GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart
startLocal largematcher mode (srcfile, destfile) =
ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile)
( do
showStart "import" destfile
next pickaction
( starting "import" (ActionItemWorkTreeFile destfile)
pickaction
, stop
)
where
@ -289,9 +288,8 @@ seekRemote remote branch msubdir = do
fromtrackingbranch a = inRepo $ a (fromRemoteTrackingBranch tb)
listContents :: Remote -> TVar (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize))) -> CommandStart
listContents remote tvar = do
showStart' "list" (Just (Remote.name remote))
next $ listImportableContents remote >>= \case
listContents remote tvar = starting "list" (ActionItemOther (Just (Remote.name remote))) $
listImportableContents remote >>= \case
Nothing -> giveup $ "Unable to list contents of " ++ Remote.name remote
Just importable -> do
importable' <- makeImportMatcher remote >>= \case
@ -302,9 +300,8 @@ listContents remote tvar = do
return True
commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> ImportableContents Key -> CommandStart
commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable = do
showStart' "update" (Just $ fromRef $ fromRemoteTrackingBranch tb)
next $ do
commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable =
starting "update" (ActionItemOther (Just $ fromRef $ fromRemoteTrackingBranch tb)) $ do
importcommit <- buildImportCommit remote importtreeconfig importcommitconfig importable
next $ updateremotetrackingbranch importcommit

45
Command/ImportFeed.hs
View file

@ -66,32 +66,27 @@ optParser desc = ImportFeedOptions
seek :: ImportFeedOptions -> CommandSeek
seek o = do
cache <- getCache (templateOption o)
withStrings (commandAction . start o cache) (feedUrls o)
forM_ (feedUrls o) (getFeed o cache)
start :: ImportFeedOptions -> Cache -> URLString -> CommandStart
start opts cache url = do
showStart' "importfeed" (Just url)
next $ perform opts cache url
perform :: ImportFeedOptions -> Cache -> URLString -> CommandPerform
perform opts cache url = go =<< downloadFeed url
where
go Nothing = next $ feedProblem url "downloading the feed failed"
go (Just feedcontent) = case parseFeedString feedcontent of
Nothing -> next $ feedProblem url "parsing the feed failed"
Just f -> case findDownloads url f of
[] -> next $
feedProblem url "bad feed content; no enclosures to download"
l -> do
showOutput
ok <- and <$> mapM (performDownload opts cache) l
next $ cleanup url ok
cleanup :: URLString -> Bool -> CommandCleanup
cleanup url True = do
clearFeedProblem url
return True
cleanup url False = feedProblem url "problem downloading some item(s) from feed"
getFeed :: ImportFeedOptions -> Cache -> URLString -> CommandSeek
getFeed opts cache url = do
showStart "importfeed" url
downloadFeed url >>= \case
Nothing -> showEndResult =<< feedProblem url
"downloading the feed failed"
Just feedcontent -> case parseFeedString feedcontent of
Nothing -> showEndResult =<< feedProblem url
"parsing the feed failed"
Just f -> case findDownloads url f of
[] -> showEndResult =<< feedProblem url
"bad feed content; no enclosures to download"
l -> do
showEndOk
ifM (and <$> mapM (performDownload opts cache) l)
( clearFeedProblem url
, void $ feedProblem url
"problem downloading some item(s) from feed"
)
data ToDownload = ToDownload
{ feed :: Feed

15
Command/Indirect.hs
View file

@ -36,20 +36,19 @@ start = ifM isDirect
giveup "Git is configured to not use symlinks, so you must use direct mode."
whenM probeCrippledFileSystem $
giveup "This repository seems to be on a crippled filesystem, you must use direct mode."
next perform
starting "indirect" (ActionItemOther Nothing)
perform
, stop
)
perform :: CommandPerform
perform = do
showStart' "commit" Nothing
whenM stageDirect $ do
showOutput
void $ inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit
[ Param "-m"
, Param "commit before switching to indirect mode"
]
showEndOk
-- Note that we set indirect mode early, so that we can use
-- moveAnnex in indirect mode.
@ -59,7 +58,7 @@ perform = do
(l, clean) <- inRepo $ Git.LsFiles.stagedOthersDetails [top]
forM_ l go
void $ liftIO clean
next cleanup
next $ return True
where
{- Walk tree from top and move all present direct mode files into
- the annex, replacing with symlinks. Also delete direct mode
@ -80,7 +79,6 @@ perform = do
go _ = noop
fromdirect f k = do
showStart "indirect" f
removeInodeCache k
removeAssociatedFiles k
whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do
@ -92,14 +90,7 @@ perform = do
Right False -> warnlocked "Failed to move file to annex"
Left e -> catchNonAsync (restoreFile f k e) $
warnlocked . show
showEndOk
warnlocked msg = do
warning msg
warning "leaving this file as-is; correct this problem and run git annex add on it"
cleanup :: CommandCleanup
cleanup = do
showStart' "indirect" Nothing
showEndOk
return True

5
Command/Init.hs
View file

@ -46,9 +46,8 @@ seek :: InitOptions -> CommandSeek
seek = commandAction . start
start :: InitOptions -> CommandStart
start os = do
showStart' "init" (Just $ initDesc os)
next $ perform os
start os = starting "init" (ActionItemOther (Just $ initDesc os)) $
perform os
perform :: InitOptions -> CommandPerform
perform os = do

5
Command/InitRemote.hs
View file

@ -37,9 +37,8 @@ start (name:ws) = ifM (isJust <$> findExisting name)
, do
let c = newConfig name
t <- either giveup return (findType config)
showStart' "initremote" (Just name)
next $ perform t name $ M.union config c
starting "initremote" (ActionItemOther (Just name)) $
perform t name $ M.union config c
)
)
where

16
Command/Inprogress.hs
View file

@ -45,17 +45,11 @@ seek o = do
start :: S.Set Key -> FilePath -> Key -> CommandStart
start s _file k
| S.member k s = start' k
| otherwise = notInprogress
| otherwise = stop
start' :: Key -> CommandStart
start' k = do
start' k = startingCustomOutput $ do
tmpf <- fromRepo $ gitAnnexTmpObjectLocation k
ifM (liftIO $ doesFileExist tmpf)
( next $ next $ do
liftIO $ putStrLn tmpf
return True
, notInprogress
)
notInprogress :: CommandStart
notInprogress = stop
whenM (liftIO $ doesFileExist tmpf) $
liftIO $ putStrLn tmpf
next $ return True

9
Command/Lock.hs
View file

@ -41,8 +41,7 @@ seek ps = do
startNew :: FilePath -> Key -> CommandStart
startNew file key = ifM (isJust <$> isAnnexLink file)
( stop
, do
showStart "lock" file
, starting "lock" (mkActionItem (key, file)) $
go =<< liftIO (isPointerFile file)
)
where
@ -57,7 +56,7 @@ startNew file key = ifM (isJust <$> isAnnexLink file)
, errorModified
)
)
cont = next $ performNew file key
cont = performNew file key
performNew :: FilePath -> Key -> CommandPerform
performNew file key = do
@ -106,10 +105,10 @@ cleanupNew file key = do
startOld :: FilePath -> CommandStart
startOld file = do
showStart "lock" file
unlessM (Annex.getState Annex.force)
errorModified
next $ performOld file
starting "lock" (ActionItemWorkTreeFile file) $
performOld file
performOld :: FilePath -> CommandPerform
performOld file = do

4
Command/Map.hs
View file

@ -40,7 +40,7 @@ seek :: CmdParams -> CommandSeek
seek = withNothing (commandAction start)
start :: CommandStart
start = do
start = starting "map" (ActionItemOther Nothing) $ do
rs <- combineSame <$> (spider =<< gitRepo)
umap <- uuidDescMap
@ -49,7 +49,7 @@ start = do
file <- (</>) <$> fromRepo gitAnnexDir <*> pure "map.dot"
liftIO $ writeFile file (drawMap rs trustmap umap)
next $ next $
next $
ifM (Annex.getState Annex.fast)
( runViewer file []
, runViewer file

12
Command/Merge.hs
View file

@ -23,13 +23,11 @@ seek _ = do
commandAction mergeSynced
mergeBranch :: CommandStart
mergeBranch = do
showStart' "merge" (Just "git-annex")
next $ do
Annex.Branch.update
-- commit explicitly, in case no remote branches were merged
Annex.Branch.commit =<< Annex.Branch.commitMessage
next $ return True
mergeBranch = starting "merge" (ActionItemOther (Just "git-annex")) $ do
Annex.Branch.update
-- commit explicitly, in case no remote branches were merged
Annex.Branch.commit =<< Annex.Branch.commitMessage
next $ return True
mergeSynced :: CommandStart
mergeSynced = do

14
Command/MetaData.hs
View file

@ -99,14 +99,13 @@ start c o file k = startKeys c o (k, mkActionItem (k, afile))
startKeys :: VectorClock -> MetaDataOptions -> (Key, ActionItem) -> CommandStart
startKeys c o (k, ai) = case getSet o of
Get f -> do
Get f -> startingCustomOutput $ do
l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k
liftIO $ forM_ l $
B8.putStrLn . fromMetaValue
stop
_ -> do
showStartKey "metadata" k ai
next $ perform c o k
next $ return True
_ -> starting "metadata" ai $
perform c o k
perform :: VectorClock -> MetaDataOptions -> Key -> CommandPerform
perform c o k = case getSet o of
@ -168,8 +167,7 @@ startBatch (i, (MetaData m)) = case i of
Nothing -> giveup $ "not an annexed file: " ++ f
Right k -> go k (mkActionItem k)
where
go k ai = do
showStartKey "metadata" k ai
go k ai = starting "metadata" ai $ do
let o = MetaDataOptions
{ forFiles = []
, getSet = if MetaData m == emptyMetaData
@ -187,7 +185,7 @@ startBatch (i, (MetaData m)) = case i of
-- probably less expensive than cleaner methods,
-- such as taking from a list of increasing timestamps.
liftIO $ threadDelay 1
next $ perform t o k
perform t o k
mkModMeta (f, s)
| S.null s = DelMeta f Nothing
| otherwise = SetMeta f s

5
Command/Migrate.hs
View file

@ -38,9 +38,8 @@ start file key = do
newbackend <- maybe defaultBackend return
=<< chooseBackend file
if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists
then do
showStart "migrate" file
next $ perform file key oldbackend newbackend
then starting "migrate" (mkActionItem (key, file)) $
perform file key oldbackend newbackend
else stop
{- Checks if a key is upgradable to a newer representation.

2
Command/Mirror.hs
View file

@ -54,7 +54,7 @@ start o file k = startKey o afile (k, ai)
ai = mkActionItem (k, afile)
startKey :: MirrorOptions -> AssociatedFile -> (Key, ActionItem) -> CommandStart
startKey o afile (key, ai) = onlyActionOn key $ case fromToOptions o of
startKey o afile (key, ai) = case fromToOptions o of
ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key)
( Command.Move.toStart Command.Move.RemoveNever afile key ai =<< getParsed r
, do

25
Command/Move.hs
View file

@ -74,7 +74,7 @@ startKey fromto removewhen =
uncurry $ start' fromto removewhen (AssociatedFile Nothing)
start' :: FromToHereOptions -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart
start' fromto removewhen afile key ai = onlyActionOn key $
start' fromto removewhen afile key ai =
case fromto of
Right (FromRemote src) ->
checkFailedTransferDirection ai Download $
@ -86,9 +86,9 @@ start' fromto removewhen afile key ai = onlyActionOn key $
checkFailedTransferDirection ai Download $
toHereStart removewhen afile key ai
showMoveAction :: RemoveWhen -> Key -> ActionItem -> Annex ()
showMoveAction RemoveNever = showStartKey "copy"
showMoveAction _ = showStartKey "move"
describeMoveAction :: RemoveWhen -> String
describeMoveAction RemoveNever = "copy"
describeMoveAction _ = "move"
toStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart
toStart removewhen afile key ai dest = do
@ -108,9 +108,8 @@ toStart' dest removewhen afile key ai = do
)
else go False (Remote.hasKey dest key)
where
go fastcheck isthere = do
showMoveAction removewhen key ai
next $ toPerform dest removewhen key afile fastcheck =<< isthere
go fastcheck isthere = starting (describeMoveAction removewhen) ai $
toPerform dest removewhen key afile fastcheck =<< isthere
expectedPresent :: Remote -> Key -> Annex Bool
expectedPresent dest key = do
@ -182,9 +181,9 @@ fromStart removewhen afile key ai src = case removewhen of
RemoveNever -> stopUnless (not <$> inAnnex key) go
RemoveSafe -> go
where
go = stopUnless (fromOk src key) $ do
showMoveAction removewhen key ai
next $ fromPerform src removewhen key afile
go = stopUnless (fromOk src key) $
starting (describeMoveAction removewhen) ai $
fromPerform src removewhen key afile
fromOk :: Remote -> Key -> Annex Bool
fromOk src key
@ -250,9 +249,9 @@ toHereStart removewhen afile key ai = case removewhen of
go = do
rs <- Remote.keyPossibilities key
forM_ rs $ \r ->
includeCommandAction $ do
showMoveAction removewhen key ai
next $ fromPerform r removewhen key afile
includeCommandAction $
starting (describeMoveAction removewhen) ai $
fromPerform r removewhen key afile
stop
{- The goal of this command is to allow the user maximum freedom to move

83
Command/Multicast.hs
View file

@ -79,8 +79,7 @@ seek (MultiCastOptions Receive ups []) = commandAction $ receive ups
seek (MultiCastOptions Receive _ _) = giveup "Cannot specify list of files with --receive; this receives whatever files the sender chooses to send."
genAddress :: CommandStart
genAddress = do
showStart' "gen-address" Nothing
genAddress = starting "gen-address" (ActionItemOther Nothing) $ do
k <- uftpKey
(s, ok) <- case k of
KeyContainer s -> liftIO $ genkey (Param s)
@ -91,7 +90,7 @@ genAddress = do
case (ok, parseFingerprint s) of
(False, _) -> giveup $ "uftp_keymgt failed: " ++ s
(_, Nothing) -> giveup $ "Failed to find fingerprint in uftp_keymgt output: " ++ s
(True, Just fp) -> next $ next $ do
(True, Just fp) -> next $ do
recordFingerprint fp =<< getUUID
return True
where
@ -123,7 +122,7 @@ parseFingerprint = Fingerprint <$$> lastMaybe . filter isfingerprint . words
in length os == 20
send :: [CommandParam] -> [FilePath] -> CommandStart
send ups fs = withTmpFile "send" $ \t h -> do
send ups fs = do
-- Need to be able to send files with the names of git-annex
-- keys, and uftp does not allow renaming the files that are sent.
-- In a direct mode repository, the annex objects do not have
@ -131,47 +130,43 @@ send ups fs = withTmpFile "send" $ \t h -> do
-- expensive.
whenM isDirect $
giveup "Sorry, multicast send cannot be done from a direct mode repository."
showStart' "generating file list" Nothing
fs' <- seekHelper LsFiles.inRepo =<< workTreeItems fs
matcher <- Limit.getMatcher
let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $
liftIO $ hPutStrLn h o
forM_ fs' $ \f -> do
mk <- lookupFile f
case mk of
Nothing -> noop
Just k -> withObjectLoc k (addlist f) (const noop)
liftIO $ hClose h
showEndOk
showStart' "sending files" Nothing
showOutput
serverkey <- uftpKey
u <- getUUID
withAuthList $ \authlist -> do
let ps =
-- Force client authentication.
[ Param "-c"
, Param "-Y", Param "aes256-cbc"
, Param "-h", Param "sha512"
-- Picked ecdh_ecdsa for perfect forward secrecy,
-- and because a EC key exchange algorithm is
-- needed since all keys are EC.
, Param "-e", Param "ecdh_ecdsa"
, Param "-k", uftpKeyParam serverkey
, Param "-U", Param (uftpUID u)
-- only allow clients on the authlist
, Param "-H", Param ("@"++authlist)
-- pass in list of files to send
, Param "-i", File t
] ++ ups
liftIO (boolSystem "uftp" ps) >>= showEndResult
stop
starting "sending files" (ActionItemOther Nothing) $
withTmpFile "send" $ \t h -> do
fs' <- seekHelper LsFiles.inRepo =<< workTreeItems fs
matcher <- Limit.getMatcher
let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $
liftIO $ hPutStrLn h o
forM_ fs' $ \f -> do
mk <- lookupFile f
case mk of
Nothing -> noop
Just k -> withObjectLoc k (addlist f) (const noop)
liftIO $ hClose h
serverkey <- uftpKey
u <- getUUID
withAuthList $ \authlist -> do
let ps =
-- Force client authentication.
[ Param "-c"
, Param "-Y", Param "aes256-cbc"
, Param "-h", Param "sha512"
-- Picked ecdh_ecdsa for perfect forward secrecy,
-- and because a EC key exchange algorithm is
-- needed since all keys are EC.
, Param "-e", Param "ecdh_ecdsa"
, Param "-k", uftpKeyParam serverkey
, Param "-U", Param (uftpUID u)
-- only allow clients on the authlist
, Param "-H", Param ("@"++authlist)
-- pass in list of files to send
, Param "-i", File t
] ++ ups
liftIO (boolSystem "uftp" ps) >>= showEndResult
next $ return True
receive :: [CommandParam] -> CommandStart
receive ups = do
showStart' "receiving multicast files" Nothing
receive ups = starting "receiving multicast files" (ActionItemOther Nothing) $ do
showNote "Will continue to run until stopped by ctrl-c"
showOutput
@ -204,7 +199,7 @@ receive ups = do
`after` boolSystemEnv "uftpd" ps (Just environ)
mapM_ storeReceived . lines =<< liftIO (hGetContents statush)
showEndResult =<< liftIO (wait runner)
stop
next $ return True
storeReceived :: FilePath -> Annex ()
storeReceived f = do

11
Command/NumCopies.hs
View file

@ -33,7 +33,7 @@ start [s] = case readish s of
start _ = giveup "Specify a single number."
startGet :: CommandStart
startGet = next $ next $ do
startGet = startingCustomOutput $ next $ do
v <- getGlobalNumCopies
case v of
Just n -> liftIO $ putStrLn $ show $ fromNumCopies n
@ -46,9 +46,6 @@ startGet = next $ next $ do
return True
startSet :: Int -> CommandStart
startSet n = do
allowMessages
showStart' "numcopies" (Just $ show n)
next $ next $ do
setGlobalNumCopies $ NumCopies n
return True
startSet n = startingUsualMessages "numcopies" (ActionItemOther (Just $ show n)) $ do
setGlobalNumCopies $ NumCopies n
next $ return True

16
Command/P2P.hs
View file

@ -96,9 +96,8 @@ genAddresses addrs = do
-- Address is read from stdin, to avoid leaking it in shell history.
linkRemote :: RemoteName -> CommandStart
linkRemote remotename = do
showStart' "p2p link" (Just remotename)
next $ next promptaddr
linkRemote remotename = starting "p2p link" (ActionItemOther (Just remotename)) $
next promptaddr
where
promptaddr = do
liftIO $ putStrLn ""
@ -122,12 +121,11 @@ linkRemote remotename = do
startPairing :: RemoteName -> [P2PAddress] -> CommandStart
startPairing _ [] = giveup "No P2P networks are currrently available."
startPairing remotename addrs = do
showStart' "p2p pair" (Just remotename)
ifM (liftIO Wormhole.isInstalled)
( next $ performPairing remotename addrs
, giveup "Magic Wormhole is not installed, and is needed for pairing. Install it from your distribution or from https://github.com/warner/magic-wormhole/"
)
startPairing remotename addrs = ifM (liftIO Wormhole.isInstalled)
( starting "p2p pair" (ActionItemOther (Just remotename)) $
performPairing remotename addrs
, giveup "Magic Wormhole is not installed, and is needed for pairing. Install it from your distribution or from https://github.com/warner/magic-wormhole/"
)
performPairing :: RemoteName -> [P2PAddress] -> CommandPerform
performPairing remotename addrs = do

4
Command/P2PStdIO.hs
View file

@ -27,7 +27,7 @@ seek [u] = commandAction $ start $ toUUID u
seek _ = giveup "missing UUID parameter"
start :: UUID -> CommandStart
start theiruuid = do
start theiruuid = startingCustomOutput $ do
servermode <- liftIO $ do
ro <- Checks.checkEnvSet Checks.readOnlyEnv
ao <- Checks.checkEnvSet Checks.appendOnlyEnv
@ -47,4 +47,4 @@ start theiruuid = do
Left (ProtoFailureIOError e) | isEOFError e -> done
Left e -> giveup (describeProtoFailure e)
where
done = next $ next $ return True
done = next $ return True

14
Command/PreCommit.hs
View file

@ -84,23 +84,21 @@ seek ps = lockPreCommitHook $ ifM isDirect
startInjectUnlocked :: FilePath -> CommandStart
startInjectUnlocked f = next $ do
startInjectUnlocked f = startingCustomOutput $ do
unlessM (callCommandAction $ Command.Add.start f) $
error $ "failed to add " ++ f ++ "; canceling commit"
next $ return True
startDirect :: [String] -> CommandStart
startDirect _ = next $ next preCommitDirect
startDirect _ = startingCustomOutput $ next preCommitDirect
addViewMetaData :: View -> ViewedFile -> Key -> CommandStart
addViewMetaData v f k = do
showStart "metadata" f
next $ next $ changeMetaData k $ fromView v f
addViewMetaData v f k = starting "metadata" (mkActionItem (k, f)) $
next $ changeMetaData k $ fromView v f
removeViewMetaData :: View -> ViewedFile -> Key -> CommandStart
removeViewMetaData v f k = do
showStart "metadata" f
next $ next $ changeMetaData k $ unsetMetaData $ fromView v f
removeViewMetaData v f k = starting "metadata" (mkActionItem (k, f)) $
next $ changeMetaData k $ unsetMetaData $ fromView v f
changeMetaData :: Key -> MetaData -> CommandCleanup
changeMetaData k metadata = do

5
Command/ReKey.hs
View file

@ -60,9 +60,8 @@ start (file, newkey) = ifAnnexed file go stop
where
go oldkey
| oldkey == newkey = stop
| otherwise = do
showStart "rekey" file
next $ perform file oldkey newkey
| otherwise = starting "rekey" (ActionItemWorkTreeFile file) $
perform file oldkey newkey
perform :: FilePath -> Key -> Key -> CommandPerform
perform file oldkey newkey = do

14
Command/RegisterUrl.hs
View file

@ -39,16 +39,16 @@ seek o = case (batchOption o, keyUrlPairs o) of
(NoBatch, ps) -> withWords (commandAction . start) ps
start :: [String] -> CommandStart
start (keyname:url:[]) = do
let key = mkKey keyname
showStart' "registerurl" (Just url)
next $ perform key url
start (keyname:url:[]) =
starting "registerurl" (ActionItemOther (Just url)) $ do
let key = mkKey keyname
perform key url
start _ = giveup "specify a key and an url"
startMass :: BatchFormat -> CommandStart
startMass fmt = do
showStart' "registerurl" (Just "stdin")
next (massAdd fmt)
startMass fmt =
starting "registerurl" (ActionItemOther (Just "stdin")) $
massAdd fmt
massAdd :: BatchFormat -> CommandPerform
massAdd fmt = go True =<< map (separate (== ' ')) <$> batchLines fmt

5
Command/Reinit.hs
View file

@ -24,9 +24,8 @@ seek :: CmdParams -> CommandSeek
seek = withWords (commandAction . start)
start :: [String] -> CommandStart
start ws = do
showStart' "reinit" (Just s)
next $ perform s
start ws = starting "reinit" (ActionItemOther (Just s)) $
perform s
where
s = unwords ws

35
Command/Reinject.hs
View file

@ -41,28 +41,27 @@ seek os
startSrcDest :: [FilePath] -> CommandStart
startSrcDest (src:dest:[])
| src == dest = stop
| otherwise = notAnnexed src $ do
showStart "reinject" dest
next $ ifAnnexed dest go stop
| otherwise = notAnnexed src $ ifAnnexed dest go stop
where
go key = ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src)
( perform src key
, giveup $ src ++ " does not have expected content of " ++ dest
)
go key = starting "reinject" (ActionItemOther (Just src)) $
ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src)
( perform src key
, giveup $ src ++ " does not have expected content of " ++ dest
)
startSrcDest _ = giveup "specify a src file and a dest file"
startKnown :: FilePath -> CommandStart
startKnown src = notAnnexed src $ do
showStart "reinject" src
mkb <- genKey (KeySource src src Nothing) Nothing
case mkb of
Nothing -> error "Failed to generate key"
Just (key, _) -> ifM (isKnownKey key)
( next $ perform src key
, do
warning "Not known content; skipping"
next $ next $ return True
)
startKnown src = notAnnexed src $
starting "reinject" (ActionItemOther (Just src)) $ do
mkb <- genKey (KeySource src src Nothing) Nothing
case mkb of
Nothing -> error "Failed to generate key"
Just (key, _) -> ifM (isKnownKey key)
( perform src key
, do
warning "Not known content; skipping"
next $ return True
)
notAnnexed :: FilePath -> CommandStart -> CommandStart
notAnnexed src = ifAnnexed src $

5
Command/RenameRemote.hs
View file

@ -40,9 +40,8 @@ start (oldname:newname:[]) = Annex.SpecialRemote.findExisting oldname >>= \case
Nothing -> giveup "That is not a special remote."
Just cfg -> go u cfg
where
go u cfg = do
showStart' "rename" Nothing
next $ perform u cfg newname
go u cfg = starting "rename" (ActionItemOther Nothing) $
perform u cfg newname
start _ = giveup "Specify an old name (or uuid or description) and a new name."
perform :: UUID -> R.RemoteConfig -> String -> CommandPerform

3
Command/Repair.hs
View file

@ -25,7 +25,8 @@ seek :: CmdParams -> CommandSeek
seek = withNothing (commandAction start)
start :: CommandStart
start = next $ next $ runRepair =<< Annex.getState Annex.force
start = starting "repair" (ActionItemOther Nothing) $
next $ runRepair =<< Annex.getState Annex.force
runRepair :: Bool -> Annex Bool
runRepair forced = do

5
Command/ResolveMerge.hs
View file

@ -22,8 +22,7 @@ seek :: CmdParams -> CommandSeek
seek = withNothing (commandAction start)
start :: CommandStart
start = do
showStart' "resolvemerge" Nothing
start = starting "resolvemerge" (ActionItemOther Nothing) $ do
us <- fromMaybe nobranch <$> inRepo Git.Branch.current
d <- fromRepo Git.localGitDir
let merge_head = d </> "MERGE_HEAD"
@ -32,7 +31,7 @@ start = do
ifM (resolveMerge (Just us) them False)
( do
void $ commitResolvedMerge Git.Branch.ManualCommit
next $ next $ return True
next $ return True
, giveup "Merge conflict could not be automatically resolved."
)
where

6
Command/RmUrl.hs
View file

@ -42,9 +42,9 @@ batchParser s = case separate (== ' ') (reverse s) of
| otherwise -> Right (reverse rf, reverse ru)
start :: (FilePath, URLString) -> CommandStart
start (file, url) = flip whenAnnexed file $ \_ key -> do
showStart "rmurl" file
next $ next $ cleanup url key
start (file, url) = flip whenAnnexed file $ \_ key ->
starting "rmurl" (mkActionItem (key, AssociatedFile (Just file))) $
next $ cleanup url key
cleanup :: String -> Key -> CommandCleanup
cleanup url key = do

17
Command/Schedule.hs
View file

@ -25,16 +25,15 @@ seek = withWords (commandAction . start)
start :: [String] -> CommandStart
start = parse
where
parse (name:[]) = go name performGet
parse (name:expr:[]) = go name $ \uuid -> do
allowMessages
showStart' "schedule" (Just name)
performSet expr uuid
parse _ = giveup "Specify a repository."
go name a = do
parse (name:[]) = do
u <- Remote.nameToUUID name
next $ a u
startingCustomOutput $
performGet u
parse (name:expr:[]) = do
u <- Remote.nameToUUID name
startingUsualMessages "schedule" (ActionItemOther (Just name)) $
performSet expr u
parse _ = giveup "Specify a repository."
performGet :: UUID -> CommandPerform
performGet uuid = do

5
Command/SetKey.hs
View file

@ -20,9 +20,8 @@ seek :: CmdParams -> CommandSeek
seek = withWords (commandAction . start)
start :: [String] -> CommandStart
start (keyname:file:[]) = do
showStart "setkey" file
next $ perform file (mkKey keyname)
start (keyname:file:[]) = starting "setkey" (ActionItemOther (Just file)) $
perform file (mkKey keyname)
start _ = giveup "specify a key and a content file"
mkKey :: String -> Key

5
Command/SetPresentKey.hs
View file

@ -47,9 +47,8 @@ parseKeyStatus (ks:us:vs:[]) = do
parseKeyStatus _ = Left "Bad input. Expected: key uuid value"
start :: KeyStatus -> CommandStart
start (KeyStatus k u s) = do
showStartKey "setpresentkey" k (mkActionItem k)
next $ perform k u s
start (KeyStatus k u s) = starting "setpresentkey" (mkActionItem k) $
perform k u s
perform :: Key -> UUID -> LogStatus -> CommandPerform
perform k u s = next $ do

72
Command/Sync.hs
View file

@ -280,11 +280,10 @@ syncRemotes' ps available =
fastest = fromMaybe [] . headMaybe . Remote.byCost
commit :: SyncOptions -> CommandStart
commit o = stopUnless shouldcommit $ next $ next $ do
commit o = stopUnless shouldcommit $ starting "commit" (ActionItemOther Nothing) $ do
commitmessage <- maybe commitMsg return (messageOption o)
showStart' "commit" Nothing
Annex.Branch.commit =<< Annex.Branch.commitMessage
ifM isDirect
next $ ifM isDirect
( do
void stageDirect
void preCommitDirect
@ -321,20 +320,19 @@ commitStaged commitmode commitmessage = do
mergeLocal :: [Git.Merge.MergeConfig] -> ResolveMergeOverride -> CurrBranch -> CommandStart
mergeLocal mergeconfig resolvemergeoverride currbranch@(Just _, _) =
go =<< needMerge currbranch
where
go Nothing = stop
go (Just syncbranch) = do
showStart' "merge" (Just $ Git.Ref.describe syncbranch)
next $ next $ merge currbranch mergeconfig resolvemergeoverride Git.Branch.ManualCommit syncbranch
needMerge currbranch >>= \case
Nothing -> stop
Just syncbranch ->
starting "merge" (ActionItemOther (Just $ Git.Ref.describe syncbranch)) $
next $ merge currbranch mergeconfig resolvemergeoverride Git.Branch.ManualCommit syncbranch
mergeLocal _ _ (Nothing, madj) = do
b <- inRepo Git.Branch.currentUnsafe
ifM (isJust <$> needMerge (b, madj))
( do
warning $ "There are no commits yet in the currently checked out branch, so cannot merge any remote changes into it."
next $ next $ return False
, stop
)
needMerge (b, madj) >>= \case
Nothing -> stop
Just syncbranch ->
starting "merge" (ActionItemOther (Just $ Git.Ref.describe syncbranch)) $ do
warning $ "There are no commits yet in the currently checked out branch, so cannot merge any remote changes into it."
next $ return False
-- Returns the branch that should be merged, if any.
needMerge :: CurrBranch -> Annex (Maybe Git.Branch)
@ -395,12 +393,13 @@ updateBranch syncbranch updateto g =
] g
pullRemote :: SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch -> CommandStart
pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && wantpull) $ do
showStart' "pull" (Just (Remote.name remote))
next $ do
pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && wantpull) $
starting "pull" (ActionItemOther (Just (Remote.name remote))) $ do
showOutput
stopUnless fetch $
next $ mergeRemote remote branch mergeconfig (resolveMergeOverride o)
ifM fetch
( next $ mergeRemote remote branch mergeconfig (resolveMergeOverride o)
, next $ return True
)
where
fetch = do
repo <- Remote.getRepo remote
@ -451,9 +450,8 @@ mergeRemote remote currbranch mergeconfig resolvemergeoverride = ifM isBareRepo
pushRemote :: SyncOptions -> Remote -> CurrBranch -> CommandStart
pushRemote _o _remote (Nothing, _) = stop
pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> needpush) $ do
showStart' "push" (Just (Remote.name remote))
next $ next $ do
pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> needpush) $
starting "push" (ActionItemOther (Just (Remote.name remote))) $ next $ do
repo <- Remote.getRepo remote
showOutput
ok <- inRepoWithSshOptionsTo repo gc $
@ -689,9 +687,8 @@ syncFile ebloom rs af k = onlyActionOn' k $ do
( return [ get have ]
, return []
)
get have = includeCommandAction $ do
showStartKey "get" k ai
next $ next $ getKey' k af have
get have = includeCommandAction $ starting "get" ai $
next $ getKey' k af have
wantput r
| Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False
@ -764,24 +761,23 @@ seekExportContent o rs (currbranch, _) = or <$> forM rs go
cleanupLocal :: CurrBranch -> CommandStart
cleanupLocal (Nothing, _) = stop
cleanupLocal (Just currb, _) = do
showStart' "cleanup" (Just "local")
next $ next $ do
delbranch $ syncBranch currb
delbranch $ syncBranch $ Git.Ref.base $ Annex.Branch.name
mapM_ (\(s,r) -> inRepo $ Git.Ref.delete s r)
=<< listTaggedBranches
return True
cleanupLocal (Just currb, _) =
starting "cleanup" (ActionItemOther (Just "local")) $
next $ do
delbranch $ syncBranch currb
delbranch $ syncBranch $ Git.Ref.base $ Annex.Branch.name
mapM_ (\(s,r) -> inRepo $ Git.Ref.delete s r)
=<< listTaggedBranches
return True
where
delbranch b = whenM (inRepo $ Git.Ref.exists $ Git.Ref.branchRef b) $
inRepo $ Git.Branch.delete b
cleanupRemote :: Remote -> CurrBranch -> CommandStart
cleanupRemote _ (Nothing, _) = stop
cleanupRemote remote (Just b, _) = do
showStart' "cleanup" (Just (Remote.name remote))
next $ next $
inRepo $ Git.Command.runBool
cleanupRemote remote (Just b, _) =
starting "cleanup" (ActionItemOther (Just (Remote.name remote))) $
next $ inRepo $ Git.Command.runBool
[ Param "push"
, Param "--quiet"
, Param "--delete"

5
Command/TestRemote.hs
View file

@ -66,8 +66,7 @@ seek :: TestRemoteOptions -> CommandSeek
seek = commandAction . start
start :: TestRemoteOptions -> CommandStart
start o = do
showStart' "testremote" (Just (testRemote o))
start o = starting "testremote" (ActionItemOther (Just (testRemote o))) $ do
fast <- Annex.getState Annex.fast
r <- either giveup disableExportTree =<< Remote.byName' (testRemote o)
ks <- case testReadonlyFile o of
@ -89,7 +88,7 @@ start o = do
exportr <- if Remote.readonly r'
then return Nothing
else exportTreeVariant r'
next $ perform rs unavailrs exportr ks
perform rs unavailrs exportr ks
where
basesz = fromInteger $ sizeOption o

6
Command/TransferKey.hs
View file

@ -45,9 +45,9 @@ seek :: TransferKeyOptions -> CommandSeek
seek o = withKeys (commandAction . start o) (keyOptions o)
start :: TransferKeyOptions -> Key -> CommandStart
start o key = case fromToOptions o of
ToRemote dest -> next $ toPerform key (fileOption o) =<< getParsed dest
FromRemote src -> next $ fromPerform key (fileOption o) =<< getParsed src
start o key = startingCustomOutput $ case fromToOptions o of
ToRemote dest -> toPerform key (fileOption o) =<< getParsed dest
FromRemote src -> fromPerform key (fileOption o) =<< getParsed src
toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
toPerform key file remote = go Upload file $

3
Command/Trust.hs
View file

@ -27,9 +27,8 @@ trustCommand c level = withWords (commandAction . start)
where
start ws = do
let name = unwords ws
showStart' c (Just name)
u <- Remote.nameToUUID name
next $ perform u
starting c (ActionItemOther (Just name)) (perform u)
perform uuid = do
trustSet uuid level
when (level == DeadTrusted) $

12
Command/Unannex.hs
View file

@ -66,12 +66,12 @@ wrapUnannex a = ifM (versionSupportsUnlockedPointers <||> isDirect)
)
start :: FilePath -> Key -> CommandStart
start file key = stopUnless (inAnnex key) $ do
showStart "unannex" file
next $ ifM isDirect
( performDirect file key
, performIndirect file key
)
start file key = stopUnless (inAnnex key) $
starting "unannex" (mkActionItem (key, file)) $
ifM isDirect
( performDirect file key
, performIndirect file key
)
performIndirect :: FilePath -> Key -> CommandPerform
performIndirect file key = do

5
Command/Undo.hs
View file

@ -46,9 +46,8 @@ seek ps = do
withStrings (commandAction . start) ps
start :: FilePath -> CommandStart
start p = do
showStart "undo" p
next $ perform p
start p = starting "undo" (ActionItemOther (Just p)) $
perform p
perform :: FilePath -> CommandPerform
perform p = do

4
Command/Ungroup.hs
View file

@ -23,9 +23,9 @@ seek = withWords (commandAction . start)
start :: [String] -> CommandStart
start (name:g:[]) = do
showStart' "ungroup" (Just name)
u <- Remote.nameToUUID name
next $ perform u (toGroup g)
starting "ungroup" (ActionItemOther (Just name)) $
perform u (toGroup g)
start _ = giveup "Specify a repository and a group."
perform :: UUID -> Group -> CommandPerform

21
Command/Unlock.hs
View file

@ -37,11 +37,10 @@ seek ps = withFilesInGit (commandAction . whenAnnexed start) =<< workTreeItems p
- to a pointer. -}
start :: FilePath -> Key -> CommandStart
start file key = ifM (isJust <$> isAnnexLink file)
( do
showStart "unlock" file
( starting "unlock" (mkActionItem (key, AssociatedFile (Just file))) $
ifM versionSupportsUnlockedPointers
( next $ performNew file key
, startOld file key
( performNew file key
, performOld file key
)
, stop
)
@ -67,22 +66,22 @@ cleanupNew dest key destmode = do
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath dest)
return True
startOld :: FilePath -> Key -> CommandStart
startOld file key =
performOld :: FilePath -> Key -> CommandPerform
performOld file key =
ifM (inAnnex key)
( ifM (isJust <$> catKeyFileHEAD file)
( next $ performOld file key
( performOld' file key
, do
warning "this has not yet been committed to git; cannot unlock it"
next $ next $ return False
next $ return False
)
, do
warning "content not present; cannot unlock"
next $ next $ return False
next $ return False
)
performOld :: FilePath -> Key -> CommandPerform
performOld dest key = ifM (checkDiskSpace Nothing key 0 True)
performOld' :: FilePath -> Key -> CommandPerform
performOld' dest key = ifM (checkDiskSpace Nothing key 0 True)
( do
src <- calcRepo $ gitAnnexLocation key
tmpdest <- fromRepo $ gitAnnexTmpObjectLocation key

9
Command/Unused.hs
View file

@ -70,8 +70,7 @@ start o = do
Just "." -> (".", checkUnused refspec)
Just "here" -> (".", checkUnused refspec)
Just n -> (n, checkRemoteUnused n refspec)
showStart' "unused" (Just name)
next perform
starting "unused" (ActionItemOther (Just name)) perform
checkUnused :: RefSpec -> CommandPerform
checkUnused refspec = chain 0
@ -335,6 +334,6 @@ startUnused message unused badunused tmpunused maps n = search
search ((m, a):rest) =
case M.lookup n m of
Nothing -> search rest
Just key -> do
showStart' message (Just $ show n)
next $ a key
Just key -> starting message
(ActionItemOther $ Just $ show n)
(a key)

5
Command/Upgrade.hs
View file

@ -22,9 +22,8 @@ seek :: CmdParams -> CommandSeek
seek = withNothing (commandAction start)
start :: CommandStart
start = do
showStart' "upgrade" Nothing
start = starting "upgrade" (ActionItemOther Nothing) $ do
whenM (isNothing <$> getVersion) $ do
initialize Nothing Nothing
r <- upgrade False latestVersion
next $ next $ return r
next $ return r

7
Command/VAdd.hs
View file

@ -22,16 +22,15 @@ seek :: CmdParams -> CommandSeek
seek = withWords (commandAction . start)
start :: [String] -> CommandStart
start params = do
showStart' "vadd" Nothing
start params = starting "vadd" (ActionItemOther Nothing) $
withCurrentView $ \view -> do
let (view', change) = refineView view $
map parseViewParam $ reverse params
case change of
Unchanged -> do
showNote "unchanged"
next $ next $ return True
Narrowing -> next $ next $ do
next $ return True
Narrowing -> next $ do
if visibleViewSize view' == visibleViewSize view
then giveup "That would not add an additional level of directory structure to the view. To filter the view, use vfilter instead of vadd."
else checkoutViewBranch view' narrowView

7
Command/VCycle.hs
View file

@ -26,14 +26,13 @@ start ::CommandStart
start = go =<< currentView
where
go Nothing = giveup "Not in a view."
go (Just v) = do
showStart' "vcycle" Nothing
go (Just v) = starting "vcycle" (ActionItemOther Nothing) $ do
let v' = v { viewComponents = vcycle [] (viewComponents v) }
if v == v'
then do
showNote "unchanged"
next $ next $ return True
else next $ next $ checkoutViewBranch v' narrowView
next $ return True
else next $ checkoutViewBranch v' narrowView
vcycle rest (c:cs)
| viewVisible c = rest ++ cs ++ [c]

5
Command/VFilter.hs
View file

@ -20,11 +20,10 @@ seek :: CmdParams -> CommandSeek
seek = withWords (commandAction . start)
start :: [String] -> CommandStart
start params = do
showStart' "vfilter" Nothing
start params = starting "vfilter" (ActionItemOther Nothing) $
withCurrentView $ \view -> do
let view' = filterView view $
map parseViewParam $ reverse params
next $ next $ if visibleViewSize view' > visibleViewSize view
next $ if visibleViewSize view' > visibleViewSize view
then giveup "That would add an additional level of directory structure to the view, rather than filtering it. If you want to do that, use vadd instead of vfilter."
else checkoutViewBranch view' narrowView

7
Command/VPop.hs
View file

@ -27,17 +27,16 @@ start :: [String] -> CommandStart
start ps = go =<< currentView
where
go Nothing = giveup "Not in a view."
go (Just v) = do
showStart' "vpop" (Just $ show num)
go (Just v) = starting "vpop" (ActionItemOther (Just $ show num)) $ do
removeView v
(oldvs, vs) <- splitAt (num - 1) . filter (sameparentbranch v)
<$> recentViews
mapM_ removeView oldvs
case vs of
(oldv:_) -> next $ next $ do
(oldv:_) -> next $ do
showOutput
checkoutViewBranch oldv (return . branchView)
_ -> next $ next $ do
_ -> next $ do
showOutput
inRepo $ Git.Command.runBool
[ Param "checkout"

17
Command/View.hs
View file

@ -29,16 +29,15 @@ seek = withWords (commandAction . start)
start :: [String] -> CommandStart
start [] = giveup "Specify metadata to include in view"
start ps = do
showStart' "view" Nothing
ifM safeToEnterView
( do
view <- mkView ps
go view =<< currentView
, giveup "Not safe to enter view."
)
start ps = ifM safeToEnterView
( do
view <- mkView ps
go view =<< currentView
, giveup "Not safe to enter view."
)
where
go view Nothing = next $ perform view
go view Nothing = starting "view" (ActionItemOther Nothing) $
perform view
go view (Just v)
| v == view = stop
| otherwise = giveup "Already in a view. Use the vfilter and vadd commands to further refine this view."

17
Command/Wanted.hs
View file

@ -32,16 +32,15 @@ cmd' name desc getter setter = noMessages $
seek = withWords (commandAction . start)
start (rname:[]) = go rname (performGet getter)
start (rname:expr:[]) = go rname $ \uuid -> do
allowMessages
showStart' name (Just rname)
performSet setter expr uuid
start _ = giveup "Specify a repository."
go rname a = do
start (rname:[]) = do
u <- Remote.nameToUUID rname
next $ a u
startingCustomOutput $
performGet getter u
start (rname:expr:[]) = do
u <- Remote.nameToUUID rname
startingUsualMessages name (ActionItemOther (Just rname)) $
performSet setter expr u
start _ = giveup "Specify a repository."
performGet :: Ord a => Annex (M.Map a PreferredContentExpression) -> a -> CommandPerform
performGet getter a = do

4
Command/Whereis.hs
View file

@ -53,9 +53,7 @@ start remotemap file key = startKeys remotemap (key, mkActionItem (key, afile))
afile = AssociatedFile (Just file)
startKeys :: M.Map UUID Remote -> (Key, ActionItem) -> CommandStart
startKeys remotemap (key, ai) = do
showStartKey "whereis" key ai
next $ perform remotemap key
startKeys remotemap (key, ai) = starting "whereis" ai $ perform remotemap key
perform :: M.Map UUID Remote -> Key -> CommandPerform
perform remotemap key = do

29
Messages.hs
View file

@ -1,6 +1,6 @@
{- git-annex output messages
-
- Copyright 2010-2017 Joey Hess <id@joeyh.name>
- Copyright 2010-2019 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@ -8,8 +8,9 @@
module Messages (
showStart,
showStart',
showStartKey,
ActionItem,
showStartMessage,
StartMessage(..),
ActionItem(..),
mkActionItem,
showNote,
showAction,
@ -58,6 +59,8 @@ import Types
import Types.Messages
import Types.ActionItem
import Types.Concurrency
import Types.Command (StartMessage(..))
import Types.Transfer (transferKey)
import Messages.Internal
import Messages.Concurrent
import qualified Messages.JSON as JSON
@ -81,6 +84,26 @@ showStartKey command key i = outputMessage json $
where
json = JSON.start command (actionItemWorkTreeFile i) (Just key)
showStartMessage :: StartMessage -> Annex ()
showStartMessage (StartMessage command ai) = case ai of
ActionItemAssociatedFile _ k -> showStartKey command k ai
ActionItemKey k -> showStartKey command k ai
ActionItemBranchFilePath _ k -> showStartKey command k ai
ActionItemFailedTransfer t _ -> showStartKey command (transferKey t) ai
ActionItemWorkTreeFile file -> showStart command file
ActionItemOther msg -> showStart' command msg
showStartMessage (StartUsualMessages command ai) = do
outputType <$> Annex.getState Annex.output >>= \case
QuietOutput -> Annex.setOutput NormalOutput
_ -> noop
Annex.changeState $ \s -> s
{ Annex.output = (Annex.output s) { implicitMessages = True } }
showStartMessage (StartMessage command ai)
showStartMessage CustomOutput = do
Annex.setOutput QuietOutput
Annex.changeState $ \s -> s
{ Annex.output = (Annex.output s) { implicitMessages = False } }
showNote :: String -> Annex ()
showNote s = outputMessage (JSON.note s) $ "(" ++ s ++ ") "

31
Types/ActionItem.hs
View file

@ -13,21 +13,34 @@ import Key
import Types.Transfer
import Git.FilePath
import Data.Maybe
data ActionItem
= ActionItemAssociatedFile AssociatedFile Key
| ActionItemKey Key
| ActionItemBranchFilePath BranchFilePath Key
| ActionItemFailedTransfer Transfer TransferInfo
| ActionItemWorkTreeFile FilePath
| ActionItemOther (Maybe String)
class MkActionItem t where
mkActionItem :: t -> ActionItem
instance MkActionItem ActionItem where
mkActionItem = id
instance MkActionItem (AssociatedFile, Key) where
mkActionItem = uncurry ActionItemAssociatedFile
instance MkActionItem (Key, AssociatedFile) where
mkActionItem = uncurry $ flip ActionItemAssociatedFile
instance MkActionItem (Key, FilePath) where
mkActionItem (key, file) = ActionItemAssociatedFile (AssociatedFile (Just file)) key
instance MkActionItem (FilePath, Key) where
mkActionItem (file, key) = mkActionItem (key, file)
instance MkActionItem Key where
mkActionItem = ActionItemKey
@ -39,20 +52,26 @@ instance MkActionItem (Transfer, TransferInfo) where
actionItemDesc :: ActionItem -> String
actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) = f
actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) = serializeKey k
actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) =
serializeKey k
actionItemDesc (ActionItemKey k) = serializeKey k
actionItemDesc (ActionItemBranchFilePath bfp _) = descBranchFilePath bfp
actionItemDesc (ActionItemFailedTransfer t i) = actionItemDesc $
ActionItemAssociatedFile (associatedFile i) (transferKey t)
actionItemDesc (ActionItemWorkTreeFile f) = f
actionItemDesc (ActionItemOther s) = fromMaybe "" s
actionItemKey :: ActionItem -> Key
actionItemKey (ActionItemAssociatedFile _ k) = k
actionItemKey (ActionItemKey k) = k
actionItemKey (ActionItemBranchFilePath _ k) = k
actionItemKey (ActionItemFailedTransfer t _) = transferKey t
actionItemKey :: ActionItem -> Maybe Key
actionItemKey (ActionItemAssociatedFile _ k) = Just k
actionItemKey (ActionItemKey k) = Just k
actionItemKey (ActionItemBranchFilePath _ k) = Just k
actionItemKey (ActionItemFailedTransfer t _) = Just (transferKey t)
actionItemKey (ActionItemWorkTreeFile _) = Nothing
actionItemKey (ActionItemOther _) = Nothing
actionItemWorkTreeFile :: ActionItem -> Maybe FilePath
actionItemWorkTreeFile (ActionItemAssociatedFile (AssociatedFile af) _) = af
actionItemWorkTreeFile (ActionItemWorkTreeFile f) = Just f
actionItemWorkTreeFile _ = Nothing
actionItemTransferDirection :: ActionItem -> Maybe Direction

25
Types/Command.hs
View file

@ -1,6 +1,6 @@
{- git-annex command data types
-
- Copyright 2010-2016 Joey Hess <id@joeyh.name>
- Copyright 2010-2019 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@ -12,6 +12,7 @@ import Options.Applicative.Types (Parser)
import Types
import Types.DeferredParse
import Types.ActionItem
{- A command runs in these stages.
-
@ -25,11 +26,11 @@ data CommandCheck = CommandCheck { idCheck :: Int, runCheck :: Annex () }
- the repo to find things to act on (ie, new files to add), and
- runs commandAction to handle all necessary actions. -}
type CommandSeek = Annex ()
{- d. The start stage is run before anything is printed about the
- command, is passed some input, and can early abort it
- if nothing needs to be done. It should run quickly and
- should not modify Annex state. -}
type CommandStart = Annex (Maybe CommandPerform)
{- d. The start stage is run before anything is output, is passed some
- value from the seek stage, and can check if anything needs to be
- done, and early abort if not. It should run quickly and should
- not modify Annex state or output anything. -}
type CommandStart = Annex (Maybe (StartMessage, CommandPerform))
{- e. The perform stage is run after a message is printed about the command
- being run, and it should be where the bulk of the work happens. -}
type CommandPerform = Annex (Maybe CommandCleanup)
@ -37,6 +38,18 @@ type CommandPerform = Annex (Maybe CommandCleanup)
- returns the overall success/fail of the command. -}
type CommandCleanup = Annex Bool
{- Message that is displayed when starting to perform an action on
- something. The String is typically the name of the command or action
- being performed.
-
- CustomOutput prevents any start, end, or other implicit messages from
- being displayed, letting a command output its own custom format.
-}
data StartMessage
= StartMessage String ActionItem
| StartUsualMessages String ActionItem
| CustomOutput
{- A command is defined by specifying these things. -}
data Command = Command
{ cmdcheck :: [CommandCheck] -- check stage