diff --git a/Checks.hs b/Checks.hs new file mode 100644 index 0000000000..cd172c6091 --- /dev/null +++ b/Checks.hs @@ -0,0 +1,45 @@ +{- git-annex command checks + - + - Common sanity checks for commands, and an interface to selectively + - remove them, or add others. + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Checks where + +import Common.Annex +import Types.Command +import Init +import qualified Annex + +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 } diff --git a/CmdLine.hs b/CmdLine.hs index 9f1ded498c..fffd343f0d 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -20,7 +20,6 @@ import qualified Annex.Queue import qualified Git import Annex.Content import Command -import Options {- Runs the passed command line. -} dispatch :: [String] -> [Command] -> [Option] -> String -> Git.Repo -> IO () diff --git a/Command.hs b/Command.hs index 32f6743f36..74b1ff21c6 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 } diff --git a/Command/FromKey.hs b/Command/FromKey.hs index fe9b5c96a0..4e4644708f 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -12,6 +12,7 @@ import Command import qualified Annex.Queue import Annex.Content import Types.Key +import Config def :: [Command] def = [command "fromkey" paramPath seek "adds a file using a specific key"] diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 1f30d2eb63..073652d2ce 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -49,7 +49,7 @@ withBarePresentKeys a params = isBareRepo >>= go go True = do unless (null params) $ do error "fsck should be run without parameters in a bare repository" - runActions a loggedKeys + prepStart a loggedKeys startBare :: Key -> CommandStart startBare key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of diff --git a/Command/SetKey.hs b/Command/SetKey.hs index 9c31abb083..0c70d12b09 100644 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -11,6 +11,7 @@ import Common.Annex import Command import Logs.Location import Annex.Content +import Config def :: [Command] def = [command "setkey" paramPath seek diff --git a/Config.hs b/Config.hs index f4c3843af8..f994002b93 100644 --- a/Config.hs +++ b/Config.hs @@ -10,6 +10,7 @@ module Config where import Common.Annex import qualified Git import qualified Annex +import Types.Key (readKey) type ConfigKey = String @@ -92,3 +93,14 @@ getNumCopies v = return $ read $ Git.configGet g config "1" config = "annex.numcopies" +{- 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" diff --git a/GitAnnex.hs b/GitAnnex.hs index c07e727fa0..89fb4e5919 100644 --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -13,7 +13,6 @@ import Common.Annex import qualified Git import CmdLine import Command -import Options import Types.TrustLevel import qualified Annex import qualified Remote diff --git a/Options.hs b/Options.hs index 0c7b4d5f41..a8c165a816 100644 --- a/Options.hs +++ b/Options.hs @@ -1,6 +1,6 @@ -{- git-annex dashed options +{- git-annex command-line options - - - Copyright 2010 Joey Hess + - Copyright 2010-2011 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -12,7 +12,6 @@ import System.Log.Logger import Common.Annex import qualified Annex -import Command import Limit {- Each dashed command-line option results in generation of an action @@ -59,3 +58,37 @@ matcherOptions = where longopt o = Option [] [o] $ NoArg $ addToken o shortopt o = Option o [] $ NoArg $ addToken o + +{- 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 diff --git a/Seek.hs b/Seek.hs new file mode 100644 index 0000000000..4ae943157b --- /dev/null +++ b/Seek.hs @@ -0,0 +1,117 @@ +{- git-annex command seeking + - + - These functions find appropriate files or other things based on + - the values a user passes to a command, and prepare actions operating + - on them. + - + - Copyright 2010-2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Seek where + +import Common.Annex +import Types.Command +import Types.Key +import Backend +import qualified Annex +import qualified Git +import qualified Git.LsFiles as LsFiles +import qualified Limit + +withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek +withFilesInGit a params = do + repo <- gitRepo + prepFiltered 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 + prepFilteredGen 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 + prepBackendPairs a files + +withFilesMissing :: (String -> CommandStart) -> CommandSeek +withFilesMissing a params = prepFiltered 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 + prepBackendPairs 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 + prepFiltered 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 + prepBackendPairs 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." + + +prepFiltered :: (FilePath -> CommandStart) -> Annex [FilePath] -> Annex [CommandStart] +prepFiltered a = prepFilteredGen a id + +prepBackendPairs :: (BackendFile -> CommandStart) -> CommandSeek +prepBackendPairs a fs = prepFilteredGen a snd (chooseBackends fs) + +prepFilteredGen :: (b -> CommandStart) -> (b -> FilePath) -> Annex [b] -> Annex [CommandStart] +prepFilteredGen a d fs = do + matcher <- Limit.getMatcher + prepStart (proc matcher) fs + where + proc matcher v = do + let f = d v + ok <- matcher f + if ok then a v else return Nothing + +{- Generates a list of CommandStart actions that will be run to perform a + - command, using a list (ie of files) coming from an action. The list + - will be produced and consumed lazily. -} +prepStart :: (b -> CommandStart) -> Annex [b] -> Annex [CommandStart] +prepStart a fs = liftM (map a) fs + +notSymlink :: FilePath -> IO Bool +notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f diff --git a/Types/Command.hs b/Types/Command.hs new file mode 100644 index 0000000000..d39876a7ae --- /dev/null +++ b/Types/Command.hs @@ -0,0 +1,45 @@ +{- git-annex command data types + - + - Copyright 2010-2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Types.Command where + +import Types + +{- 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 () } +{- 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 + +{- A command is defined by specifying these things. -} +data Command = Command { + cmdcheck :: [CommandCheck], + cmdname :: String, + cmdparams :: String, + cmdseek :: [CommandSeek], + cmddesc :: String +} + +{- CommandCheck functions can be compared using their unique id. -} +instance Eq CommandCheck where + a == b = idCheck a == idCheck b diff --git a/git-annex-shell.hs b/git-annex-shell.hs index 328d7b1006..10eeb454af 100644 --- a/git-annex-shell.hs +++ b/git-annex-shell.hs @@ -12,7 +12,6 @@ import Common.Annex import qualified Git import CmdLine import Command -import Options import Annex.UUID import qualified Command.ConfigList