From 4e9be0d1f86893a469b33b763b55edfe75bdb3aa Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 29 Oct 2011 23:48:46 -0400 Subject: refactoring and cleanup No code changes. --- Command.hs | 233 ++++++++----------------------------------------------------- 1 file changed, 30 insertions(+), 203 deletions(-) (limited to 'Command.hs') diff --git a/Command.hs b/Command.hs index 32f6743f3..74b1ff21c 100644 --- a/Command.hs +++ b/Command.hs @@ -5,52 +5,38 @@ - Licensed under the GNU GPL version 3 or higher. -} -module Command where +module Command ( + module Types.Command, + module Seek, + module Checks, + module Options, + command, + next, + stop, + prepCommand, + doCommand, + notAnnexed, + isAnnexed, + notBareRepo, + isBareRepo, + autoCopies +) where import Common.Annex import qualified Backend import qualified Annex import qualified Git -import qualified Git.LsFiles as LsFiles -import Types.Key +import Types.Command import Logs.Trust import Logs.Location import Config -import Backend -import Limit -import Init +import Seek +import Checks +import Options -{- A command runs in these stages. - - - - a. The check stage runs checks, that error out if - - anything prevents the command from running. -} -data CommandCheck = CommandCheck { idCheck :: Int, runCheck :: Annex () } -instance Eq CommandCheck where - a == b = idCheck a == idCheck b -{- b. The seek stage takes the parameters passed to the command, - - looks through the repo to find the ones that are relevant - - to that command (ie, new files to add), and generates - - a list of start stage actions. -} -type CommandSeek = [String] -> Annex [CommandStart] -{- c. The start stage is run before anything is printed about the - - command, is passed some input, and can early abort it - - if the input does not make sense. It should run quickly and - - should not modify Annex state. -} -type CommandStart = Annex (Maybe CommandPerform) -{- d. 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) -{- e. The cleanup stage is run only if the perform stage succeeds, and it - - returns the overall success/fail of the command. -} -type CommandCleanup = Annex Bool - -data Command = Command { - cmdcheck :: [CommandCheck], - cmdname :: String, - cmdparams :: String, - cmdseek :: [CommandSeek], - cmddesc :: String -} +{- Generates a command with the common checks. -} +command :: String -> String -> [CommandSeek] -> String -> Command +command = Command commonChecks {- For start and perform stages to indicate what step to run next. -} next :: a -> Annex (Maybe a) @@ -60,15 +46,14 @@ next a = return $ Just a stop :: Annex (Maybe a) stop = return Nothing -{- Generates a command with the common checks. -} -command :: String -> String -> [CommandSeek] -> String -> Command -command = Command commonChecks - {- Prepares a list of actions to run to perform a command, based on - the parameters passed to it. -} prepCommand :: Command -> [String] -> Annex [Annex Bool] -prepCommand Command { cmdseek = seek } params = - return . map doCommand . concat =<< mapM (\s -> s params) seek +prepCommand cmd ps = return . map doCommand =<< seekCommand cmd ps + +{- Runs a command through the seek stage. -} +seekCommand :: Command -> [String] -> Annex [CommandStart] +seekCommand Command { cmdseek = seek } ps = concat <$> mapM (\s -> s ps) seek {- Runs a command through the start, perform and cleanup stages -} doCommand :: CommandStart -> CommandCleanup @@ -81,147 +66,20 @@ doCommand = start success = return True failure = showEndFail >> return False -{- These functions find appropriate files or other things based on a - user's parameters, and prepare actions operating on them. -} -withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek -withFilesInGit a params = do - repo <- gitRepo - runFiltered a $ liftIO $ runPreserveOrder (LsFiles.inRepo repo) params -withAttrFilesInGit :: String -> ((FilePath, String) -> CommandStart) -> CommandSeek -withAttrFilesInGit attr a params = do - repo <- gitRepo - files <- liftIO $ runPreserveOrder (LsFiles.inRepo repo) params - runFilteredGen a fst $ liftIO $ Git.checkAttr repo attr files -withNumCopies :: (FilePath -> Maybe Int -> CommandStart) -> CommandSeek -withNumCopies a params = withAttrFilesInGit "annex.numcopies" go params - where - go (file, v) = a file (readMaybe v) -withBackendFilesInGit :: (BackendFile -> CommandStart) -> CommandSeek -withBackendFilesInGit a params = do - repo <- gitRepo - files <- liftIO $ runPreserveOrder (LsFiles.inRepo repo) params - backendPairs a files -withFilesMissing :: (String -> CommandStart) -> CommandSeek -withFilesMissing a params = runFiltered a $ liftIO $ filterM missing params - where - missing = liftM not . doesFileExist -withFilesNotInGit :: (BackendFile -> CommandStart) -> CommandSeek -withFilesNotInGit a params = do - repo <- gitRepo - force <- Annex.getState Annex.force - newfiles <- liftIO $ runPreserveOrder (LsFiles.notInRepo repo force) params - backendPairs a newfiles -withWords :: ([String] -> CommandStart) -> CommandSeek -withWords a params = return [a params] -withStrings :: (String -> CommandStart) -> CommandSeek -withStrings a params = return $ map a params -withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek -withFilesToBeCommitted a params = do - repo <- gitRepo - runFiltered a $ - liftIO $ runPreserveOrder (LsFiles.stagedNotDeleted repo) params -withFilesUnlocked :: (BackendFile -> CommandStart) -> CommandSeek -withFilesUnlocked = withFilesUnlocked' LsFiles.typeChanged -withFilesUnlockedToBeCommitted :: (BackendFile -> CommandStart) -> CommandSeek -withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged -withFilesUnlocked' :: (Git.Repo -> [FilePath] -> IO [FilePath]) -> (BackendFile -> CommandStart) -> CommandSeek -withFilesUnlocked' typechanged a params = do - -- unlocked files have changed type from a symlink to a regular file - repo <- gitRepo - typechangedfiles <- liftIO $ runPreserveOrder (typechanged repo) params - unlockedfiles <- liftIO $ filterM notSymlink $ - map (\f -> Git.workTree repo ++ "/" ++ f) typechangedfiles - backendPairs a unlockedfiles -withKeys :: (Key -> CommandStart) -> CommandSeek -withKeys a params = return $ map (a . parse) params - where - parse p = fromMaybe (error "bad key") $ readKey p -withNothing :: CommandStart -> CommandSeek -withNothing a [] = return [a] -withNothing _ _ = error "This command takes no parameters." - -runFiltered :: (FilePath -> Annex (Maybe a)) -> Annex [FilePath] -> Annex [Annex (Maybe a)] -runFiltered a = runFilteredGen a id - -backendPairs :: (BackendFile -> CommandStart) -> CommandSeek -backendPairs a fs = runFilteredGen a snd (Backend.chooseBackends fs) - -runFilteredGen :: (b -> Annex (Maybe a)) -> (b -> FilePath) -> Annex [b] -> Annex [Annex (Maybe a)] -runFilteredGen a d fs = do - matcher <- Limit.getMatcher - runActions (proc matcher) fs - where - proc matcher v = do - let f = d v - ok <- matcher f - if ok then a v else stop - -runActions :: (b -> Annex (Maybe a)) -> Annex [b] -> Annex [Annex (Maybe a)] -runActions a fs = liftM (map a) fs - notAnnexed :: FilePath -> Annex (Maybe a) -> Annex (Maybe a) notAnnexed file a = maybe a (const $ return Nothing) =<< Backend.lookupFile file isAnnexed :: FilePath -> ((Key, Backend Annex) -> Annex (Maybe a)) -> Annex (Maybe a) isAnnexed file a = maybe (return Nothing) a =<< Backend.lookupFile file -isBareRepo :: Annex Bool -isBareRepo = Git.repoIsLocalBare <$> gitRepo - notBareRepo :: Annex a -> Annex a notBareRepo a = do whenM isBareRepo $ error "You cannot run this subcommand in a bare repository." a -notSymlink :: FilePath -> IO Bool -notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f - -{- Descriptions of params used in usage messages. -} -paramPaths :: String -paramPaths = paramOptional $ paramRepeating paramPath -- most often used -paramPath :: String -paramPath = "PATH" -paramKey :: String -paramKey = "KEY" -paramDesc :: String -paramDesc = "DESC" -paramUrl :: String -paramUrl = "URL" -paramNumber :: String -paramNumber = "NUMBER" -paramRemote :: String -paramRemote = "REMOTE" -paramGlob :: String -paramGlob = "GLOB" -paramName :: String -paramName = "NAME" -paramUUID :: String -paramUUID = "UUID" -paramType :: String -paramType = "TYPE" -paramKeyValue :: String -paramKeyValue = "K=V" -paramNothing :: String -paramNothing = "" -paramRepeating :: String -> String -paramRepeating s = s ++ " ..." -paramOptional :: String -> String -paramOptional s = "[" ++ s ++ "]" -paramPair :: String -> String -> String -paramPair a b = a ++ " " ++ b - -{- The Key specified by the --key parameter. -} -cmdlineKey :: Annex Key -cmdlineKey = do - k <- Annex.getState Annex.defaultkey - case k of - Nothing -> nokey - Just "" -> nokey - Just kstring -> maybe badkey return $ readKey kstring - where - nokey = error "please specify the key with --key" - badkey = error "bad key" +isBareRepo :: Annex Bool +isBareRepo = Git.repoIsLocalBare <$> gitRepo {- Used for commands that have an auto mode that checks the number of known - copies of a key. @@ -238,34 +96,3 @@ autoCopies key vs numcopiesattr a = do (_, have) <- trustPartition UnTrusted =<< keyLocations key if length have `vs` needed then a else stop else a - -{- Common checks for commands, and an interface to selectively remove them, - - or add others. -} -commonChecks :: [CommandCheck] -commonChecks = [fromOpt, toOpt, repoExists] - -repoExists :: CommandCheck -repoExists = CommandCheck 0 ensureInitialized - -fromOpt :: CommandCheck -fromOpt = CommandCheck 1 $ do - v <- Annex.getState Annex.fromremote - unless (v == Nothing) $ error "cannot use --from with this command" - -toOpt :: CommandCheck -toOpt = CommandCheck 2 $ do - v <- Annex.getState Annex.toremote - unless (v == Nothing) $ error "cannot use --to with this command" - -checkCommand :: Command -> Annex () -checkCommand Command { cmdcheck = c } = sequence_ $ map runCheck c - -dontCheck :: CommandCheck -> Command -> Command -dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c - -addCheck :: Annex () -> Command -> Command -addCheck check cmd = mutateCheck cmd $ - \c -> CommandCheck (length c + 100) check : c - -mutateCheck :: Command -> ([CommandCheck] -> [CommandCheck]) -> Command -mutateCheck cmd@(Command { cmdcheck = c }) a = cmd { cmdcheck = a c } -- cgit v1.2.3