refactoring and cleanup
No code changes.
This commit is contained in:
Joey Hess
parent
ef5330120c
commit
4e9be0d1f8
12 changed files with 288 additions and 210 deletions
45
Checks.hs
Normal file
45
Checks.hs
Normal file
|
|
@ -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 <joey@kitenet.net>
|
||||
-
|
||||
- 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 }
|
||||
|
|
@ -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 ()
|
||||
|
|
|
|||
233
Command.hs
233
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 }
|
||||
|
|
|
|||
|
|
@ -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"]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@ import Common.Annex
|
|||
import Command
|
||||
import Logs.Location
|
||||
import Annex.Content
|
||||
import Config
|
||||
|
||||
def :: [Command]
|
||||
def = [command "setkey" paramPath seek
|
||||
|
|
|
|||
12
Config.hs
12
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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
39
Options.hs
39
Options.hs
|
|
@ -1,6 +1,6 @@
|
|||
{- git-annex dashed options
|
||||
{- git-annex command-line options
|
||||
-
|
||||
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
||||
- Copyright 2010-2011 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- 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
|
||||
|
|
|
|||
117
Seek.hs
Normal file
117
Seek.hs
Normal file
|
|
@ -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 <joey@kitenet.net>
|
||||
-
|
||||
- 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
|
||||
45
Types/Command.hs
Normal file
45
Types/Command.hs
Normal file
|
|
@ -0,0 +1,45 @@
|
|||
{- git-annex command data types
|
||||
-
|
||||
- Copyright 2010-2011 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- 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
|
||||
|
|
@ -12,7 +12,6 @@ import Common.Annex
|
|||
import qualified Git
|
||||
import CmdLine
|
||||
import Command
|
||||
import Options
|
||||
import Annex.UUID
|
||||
|
||||
import qualified Command.ConfigList
|
||||
|
|
|
|||
Loading…
Reference in a new issue