diff --git a/Annex/Import.hs b/Annex/Import.hs index d70942acd4..bb15fb7b6b 100644 --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -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 $ diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs index 7a3c8ac341..3588d2ebd6 100644 --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -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 diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index 328a395d62..9196a6dcc1 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -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 diff --git a/Command.hs b/Command.hs index 39c790dedb..9276d32072 100644 --- a/Command.hs +++ b/Command.hs @@ -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 diff --git a/Command/Add.hs b/Command/Add.hs index b5124838b7..771cd95341 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -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 diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index df7973d95d..1df53c3d26 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -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 diff --git a/Command/Adjust.hs b/Command/Adjust.hs index 7126359b91..6930e2c7be 100644 --- a/Command/Adjust.hs +++ b/Command/Adjust.hs @@ -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 diff --git a/Command/Commit.hs b/Command/Commit.hs index dc7d3c7655..3f19d34f47 100644 --- a/Command/Commit.hs +++ b/Command/Commit.hs @@ -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 diff --git a/Command/Config.hs b/Command/Config.hs index 25ae6f6b28..dabfb7cda7 100644 --- a/Command/Config.hs +++ b/Command/Config.hs @@ -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 diff --git a/Command/Dead.hs b/Command/Dead.hs index ecddce2049..a83dcdad55 100644 --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -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 diff --git a/Command/Describe.hs b/Command/Describe.hs index 9e1533438e..ef639135ee 100644 --- a/Command/Describe.hs +++ b/Command/Describe.hs @@ -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 diff --git a/Command/Direct.hs b/Command/Direct.hs index f8f89379b5..0d04bab8b2 100644 --- a/Command/Direct.hs +++ b/Command/Direct.hs @@ -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 diff --git a/Command/Drop.hs b/Command/Drop.hs index d54dc82239..9336ea789a 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -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 diff --git a/Command/DropKey.hs b/Command/DropKey.hs index 0bb7c1547f..60040451ab 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -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) diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs index efa19498dc..1af7cd073b 100644 --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -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 diff --git a/Command/EnableTor.hs b/Command/EnableTor.hs index 3c0a40b1f4..f05fccea4d 100644 --- a/Command/EnableTor.hs +++ b/Command/EnableTor.hs @@ -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 ) diff --git a/Command/Expire.hs b/Command/Expire.hs index 924b5851d5..83c38e5698 100644 --- a/Command/Expire.hs +++ b/Command/Expire.hs @@ -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)) diff --git a/Command/Export.hs b/Command/Export.hs index 192c3157d1..1163f5bad2 100644 --- a/Command/Export.hs +++ b/Command/Export.hs @@ -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 diff --git a/Command/Find.hs b/Command/Find.hs index 4eae0f035b..250f817ffa 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -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) _) = diff --git a/Command/Fix.hs b/Command/Fix.hs index faf84497f4..6432a46ff0 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -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 diff --git a/Command/Forget.hs b/Command/Forget.hs index 58098ae02f..0c93e7451e 100644 --- a/Command/Forget.hs +++ b/Command/Forget.hs @@ -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 diff --git a/Command/FromKey.hs b/Command/FromKey.hs index d6773dcc9c..cc9491264f 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -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. diff --git a/Command/Fsck.hs b/Command/Fsck.hs index f372aea168..09054491c7 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -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 diff --git a/Command/GCryptSetup.hs b/Command/GCryptSetup.hs index a17055e5a9..13b6c11971 100644 --- a/Command/GCryptSetup.hs +++ b/Command/GCryptSetup.hs @@ -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" diff --git a/Command/Get.hs b/Command/Get.hs index 783b1cb30a..32ccefe36f 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -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) $ diff --git a/Command/Group.hs b/Command/Group.hs index 8af071a526..5dac5ef379 100644 --- a/Command/Group.hs +++ b/Command/Group.hs @@ -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." diff --git a/Command/GroupWanted.hs b/Command/GroupWanted.hs index 3455ca879d..cbd1ac4c5b 100644 --- a/Command/GroupWanted.hs +++ b/Command/GroupWanted.hs @@ -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." diff --git a/Command/Import.hs b/Command/Import.hs index c8659a1e92..7fc3c0e639 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -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 diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs index c082fcfaff..1d5ad0c9c8 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -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 diff --git a/Command/Indirect.hs b/Command/Indirect.hs index 442e2cd4fc..f1e4e65211 100644 --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -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 diff --git a/Command/Init.hs b/Command/Init.hs index 23b5f93ad3..e8d80a3533 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -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 diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs index 8b4406cf7e..186ee1ca5e 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -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 diff --git a/Command/Inprogress.hs b/Command/Inprogress.hs index c814d0b4f8..6bf6ab2856 100644 --- a/Command/Inprogress.hs +++ b/Command/Inprogress.hs @@ -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 diff --git a/Command/Lock.hs b/Command/Lock.hs index f75cbec1c7..c42def8411 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -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 diff --git a/Command/Map.hs b/Command/Map.hs index 46bb508cd5..7fa9d560e2 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -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 diff --git a/Command/Merge.hs b/Command/Merge.hs index b78137c13d..8870e556b8 100644 --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -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 diff --git a/Command/MetaData.hs b/Command/MetaData.hs index 9e87f4733e..24364439a6 100644 --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -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 diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 0f9471b41d..1cdca17800 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -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. diff --git a/Command/Mirror.hs b/Command/Mirror.hs index 291d5d74b9..154c8d0f2a 100644 --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -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 diff --git a/Command/Move.hs b/Command/Move.hs index 65150258c1..223b572a25 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -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 diff --git a/Command/Multicast.hs b/Command/Multicast.hs index 84d96648d3..e34ef56ac7 100644 --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -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 diff --git a/Command/NumCopies.hs b/Command/NumCopies.hs index b323e0417b..1237ca4225 100644 --- a/Command/NumCopies.hs +++ b/Command/NumCopies.hs @@ -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 diff --git a/Command/P2P.hs b/Command/P2P.hs index 0211e9462f..ae86f59076 100644 --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -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 diff --git a/Command/P2PStdIO.hs b/Command/P2PStdIO.hs index c9be293acd..8cb03e550e 100644 --- a/Command/P2PStdIO.hs +++ b/Command/P2PStdIO.hs @@ -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 diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index c251f0c46c..abebf8dc7e 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -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 diff --git a/Command/ReKey.hs b/Command/ReKey.hs index a2fda4d506..fd543fd789 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -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 diff --git a/Command/RegisterUrl.hs b/Command/RegisterUrl.hs index a20af1fb47..c9d72ee2d3 100644 --- a/Command/RegisterUrl.hs +++ b/Command/RegisterUrl.hs @@ -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 diff --git a/Command/Reinit.hs b/Command/Reinit.hs index ca8d50f3d7..e37f6d5c60 100644 --- a/Command/Reinit.hs +++ b/Command/Reinit.hs @@ -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 diff --git a/Command/Reinject.hs b/Command/Reinject.hs index 618985c3c7..428b9ff988 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -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 $ diff --git a/Command/RenameRemote.hs b/Command/RenameRemote.hs index ca351afe85..ac4228eb8d 100644 --- a/Command/RenameRemote.hs +++ b/Command/RenameRemote.hs @@ -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 diff --git a/Command/Repair.hs b/Command/Repair.hs index f99ff7b3a5..c9981974f6 100644 --- a/Command/Repair.hs +++ b/Command/Repair.hs @@ -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 diff --git a/Command/ResolveMerge.hs b/Command/ResolveMerge.hs index a8a7ca2234..3a38ffaa7d 100644 --- a/Command/ResolveMerge.hs +++ b/Command/ResolveMerge.hs @@ -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 diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs index 9858836207..3d8d8ca2df 100644 --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -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 diff --git a/Command/Schedule.hs b/Command/Schedule.hs index 2b83e6b830..f048539d9b 100644 --- a/Command/Schedule.hs +++ b/Command/Schedule.hs @@ -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 diff --git a/Command/SetKey.hs b/Command/SetKey.hs index afcf8e786c..1cf7fb14e2 100644 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -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 diff --git a/Command/SetPresentKey.hs b/Command/SetPresentKey.hs index 5223224ccb..616e153cc9 100644 --- a/Command/SetPresentKey.hs +++ b/Command/SetPresentKey.hs @@ -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 diff --git a/Command/Sync.hs b/Command/Sync.hs index 70c19f213f..b08ac7e1f9 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -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" diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index bcb9490ff7..813ae7e048 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -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 diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index 38ce6f000f..176d1b58e4 100644 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -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 $ diff --git a/Command/Trust.hs b/Command/Trust.hs index e31805bc0f..73c76b15cd 100644 --- a/Command/Trust.hs +++ b/Command/Trust.hs @@ -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) $ diff --git a/Command/Unannex.hs b/Command/Unannex.hs index dc064f9f56..362a92efd1 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -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 diff --git a/Command/Undo.hs b/Command/Undo.hs index 847cae186e..0daa37eaaa 100644 --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -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 diff --git a/Command/Ungroup.hs b/Command/Ungroup.hs index b7b0a15b1e..50514911ef 100644 --- a/Command/Ungroup.hs +++ b/Command/Ungroup.hs @@ -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 diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 8a8011c2c7..579e71caf5 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -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 diff --git a/Command/Unused.hs b/Command/Unused.hs index 41b4d705d7..ca6fb01d8d 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -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) diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs index 59a25759a3..00e972ae5d 100644 --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -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 diff --git a/Command/VAdd.hs b/Command/VAdd.hs index f166f23775..c18e542e34 100644 --- a/Command/VAdd.hs +++ b/Command/VAdd.hs @@ -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 diff --git a/Command/VCycle.hs b/Command/VCycle.hs index 45373e60c8..93627f2f44 100644 --- a/Command/VCycle.hs +++ b/Command/VCycle.hs @@ -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] diff --git a/Command/VFilter.hs b/Command/VFilter.hs index b3cbc2d5a2..74eb55e620 100644 --- a/Command/VFilter.hs +++ b/Command/VFilter.hs @@ -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 diff --git a/Command/VPop.hs b/Command/VPop.hs index 55b35bf4de..05ddfa39cf 100644 --- a/Command/VPop.hs +++ b/Command/VPop.hs @@ -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" diff --git a/Command/View.hs b/Command/View.hs index b57bbf58f4..7c10ab1586 100644 --- a/Command/View.hs +++ b/Command/View.hs @@ -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." diff --git a/Command/Wanted.hs b/Command/Wanted.hs index b54a720adf..eedc5f67ac 100644 --- a/Command/Wanted.hs +++ b/Command/Wanted.hs @@ -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 diff --git a/Command/Whereis.hs b/Command/Whereis.hs index 4a863fea69..c5010473c4 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -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 diff --git a/Messages.hs b/Messages.hs index 94dbb301e3..87666b1372 100644 --- a/Messages.hs +++ b/Messages.hs @@ -1,6 +1,6 @@ {- git-annex output messages - - - Copyright 2010-2017 Joey Hess + - Copyright 2010-2019 Joey Hess - - 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 ++ ") " diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs index dbcaf0982f..aabcb7c9ce 100644 --- a/Types/ActionItem.hs +++ b/Types/ActionItem.hs @@ -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 diff --git a/Types/Command.hs b/Types/Command.hs index 9162011c28..09a39103ac 100644 --- a/Types/Command.hs +++ b/Types/Command.hs @@ -1,6 +1,6 @@ {- git-annex command data types - - - Copyright 2010-2016 Joey Hess + - Copyright 2010-2019 Joey Hess - - 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