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

less confusing names for the subcommand stage types

Browse source
This commit is contained in:
Joey Hess 2010-11-01 19:18:47 -04:00
parent f1f4bdcd60
commit 1f9996f742
1 changed files with 48 additions and 48 deletions
Download patch file Download diff file Expand all files Collapse all files

96
Commands.hs
View file

@ -33,23 +33,25 @@ import qualified Remotes
- looks through the repo to find the ones that are relevant - looks through the repo to find the ones that are relevant
- to that subcommand (ie, new files to add), and returns a list of - to that subcommand (ie, new files to add), and returns a list of
- start stage actions to run. -} - start stage actions to run. -}
type SubCmdParse = [String] -> Annex [SubCmdStart] type SubCmdParseStrings = (String -> SubCmdPerform) -> SubCmdStart
type SubCmdParseBackendFiles = ((FilePath, Maybe Backend) -> SubCmdPerform) -> SubCmdStart
{- 1. The start stage is run before anything is printed about the {- 1. The start stage is run before anything is printed about the
- subcommand, is passed some input, and can early abort it - subcommand, is passed some input, and can early abort it
- if the input does not make sense. It should run quickly and - if the input does not make sense. It should run quickly and
- should not modify Annex state. -} - should not modify Annex state. -}
type SubCmdStart = Annex (Maybe SubCmdPerform) type SubCmdStart = [String] -> Annex [SubCmdPerform]
{- 2. The perform stage is run after a message is printed about the subcommand {- 2. The perform stage is run after a message is printed about the subcommand
- being run, and it should be where the bulk of the work happens. -} - being run, and it should be where the bulk of the work happens. -}
type SubCmdPerform = Annex (Maybe SubCmdCleanup) type SubCmdPerform = Annex (Maybe SubCmdCleanup)
{- 3. The cleanup stage is run only if the perform stage succeeds, and it {- 3. The cleanup stage is run only if the perform stage succeeds, and it
- returns the overall success/fail of the subcommand. -} - returns the overall success/fail of the subcommand. -}
type SubCmdCleanup = Annex Bool type SubCmdCleanup = Annex (Maybe SubCmdStatus)
type SubCmdStatus = Annex Bool
data SubCommand = SubCommand { data SubCommand = SubCommand {
subcmdname :: String, subcmdname :: String,
subcmdparams :: String, subcmdparams :: String,
subcmdparse :: SubCmdParse, subcmdparse :: SubCmdStart,
subcmddesc :: String subcmddesc :: String
} }
subCmds :: [SubCommand] subCmds :: [SubCommand]
@ -130,7 +132,7 @@ prepSubCmd SubCommand { subcmdparse = parse } state params = do
return $ map (\a -> doSubCmd a) list return $ map (\a -> doSubCmd a) list
{- Runs a subcommand through the start, perform and cleanup stages -} {- Runs a subcommand through the start, perform and cleanup stages -}
doSubCmd :: SubCmdStart -> SubCmdCleanup doSubCmd :: SubCmdPerform -> SubCmdStatus
doSubCmd start = do doSubCmd start = do
s <- start s <- start
case (s) of case (s) of
@ -151,23 +153,21 @@ doSubCmd start = do
showEndFail showEndFail
return False return False
{- These functions parse a user's parameters into a list of SubCmdStart {- These functions parse a user's parameters into a list of SubCmdPerform
actions to perform. -} actions to perform. -}
type ParseStrings = (String -> SubCmdStart) -> SubCmdParse withFilesNotInGit :: SubCmdParseBackendFiles
type ParseBackendFiles = ((FilePath, Maybe Backend) -> SubCmdStart) -> SubCmdParse
withFilesNotInGit :: ParseBackendFiles
withFilesNotInGit a params = do withFilesNotInGit a params = do
repo <- Annex.gitRepo repo <- Annex.gitRepo
files <- liftIO $ mapM (Git.notInRepo repo) params files <- liftIO $ mapM (Git.notInRepo repo) params
let files' = foldl (++) [] files let files' = foldl (++) [] files
pairs <- Backend.chooseBackends files' pairs <- Backend.chooseBackends files'
return $ map a $ filter (\(f,_) -> notState f) pairs return $ map a $ filter (\(f,_) -> notState f) pairs
withFilesInGit :: ParseStrings withFilesInGit :: SubCmdParseStrings
withFilesInGit a params = do withFilesInGit a params = do
repo <- Annex.gitRepo repo <- Annex.gitRepo
files <- liftIO $ mapM (Git.inRepo repo) params files <- liftIO $ mapM (Git.inRepo repo) params
return $ map a $ filter notState $ foldl (++) [] files return $ map a $ filter notState $ foldl (++) [] files
withFilesMissing :: ParseStrings withFilesMissing :: SubCmdParseStrings
withFilesMissing a params = do withFilesMissing a params = do
files <- liftIO $ filterM missing params files <- liftIO $ filterM missing params
return $ map a $ filter notState files return $ map a $ filter notState files
@ -175,17 +175,17 @@ withFilesMissing a params = do
missing f = do missing f = do
e <- doesFileExist f e <- doesFileExist f
return $ not e return $ not e
withDescription :: ParseStrings withDescription :: SubCmdParseStrings
withDescription a params = do withDescription a params = do
return $ [a $ unwords params] return $ [a $ unwords params]
withFilesToBeCommitted :: ParseStrings withFilesToBeCommitted :: SubCmdParseStrings
withFilesToBeCommitted a params = do withFilesToBeCommitted a params = do
repo <- Annex.gitRepo repo <- Annex.gitRepo
files <- liftIO $ mapM (Git.stagedFiles repo) params files <- liftIO $ mapM (Git.stagedFiles repo) params
return $ map a $ filter notState $ foldl (++) [] files return $ map a $ filter notState $ foldl (++) [] files
withKeys :: ParseStrings withKeys :: SubCmdParseStrings
withKeys a params = return $ map a params withKeys a params = return $ map a params
withTempFile :: ParseStrings withTempFile :: SubCmdParseStrings
withTempFile a params = return $ map a params withTempFile a params = return $ map a params
{- filter out files from the state directory -} {- filter out files from the state directory -}
@ -218,7 +218,7 @@ parseCmd argv state = do
{- The add subcommand annexes a file, storing it in a backend, and then {- The add subcommand annexes a file, storing it in a backend, and then
- moving it into the annex directory and setting up the symlink pointing - moving it into the annex directory and setting up the symlink pointing
- to its content. -} - to its content. -}
addStart :: (FilePath, Maybe Backend) -> SubCmdStart addStart :: (FilePath, Maybe Backend) -> SubCmdPerform
addStart pair@(file, _) = notAnnexed file $ do addStart pair@(file, _) = notAnnexed file $ do
s <- liftIO $ getSymbolicLinkStatus file s <- liftIO $ getSymbolicLinkStatus file
if ((isSymbolicLink s) || (not $ isRegularFile s)) if ((isSymbolicLink s) || (not $ isRegularFile s))
@ -226,13 +226,13 @@ addStart pair@(file, _) = notAnnexed file $ do
else do else do
showStart "add" file showStart "add" file
return $ Just $ addPerform pair return $ Just $ addPerform pair
addPerform :: (FilePath, Maybe Backend) -> SubCmdPerform addPerform :: (FilePath, Maybe Backend) -> SubCmdCleanup
addPerform (file, backend) = do addPerform (file, backend) = do
stored <- Backend.storeFileKey file backend stored <- Backend.storeFileKey file backend
case (stored) of case (stored) of
Nothing -> return Nothing Nothing -> return Nothing
Just (key, _) -> return $ Just $ addCleanup file key Just (key, _) -> return $ Just $ addCleanup file key
addCleanup :: FilePath -> Key -> SubCmdCleanup addCleanup :: FilePath -> Key -> SubCmdStatus
addCleanup file key = do addCleanup file key = do
logStatus key ValuePresent logStatus key ValuePresent
g <- Annex.gitRepo g <- Annex.gitRepo
@ -245,11 +245,11 @@ addCleanup file key = do
return True return True
{- The unannex subcommand undoes an add. -} {- The unannex subcommand undoes an add. -}
unannexStart :: FilePath -> SubCmdStart unannexStart :: FilePath -> SubCmdPerform
unannexStart file = isAnnexed file $ \(key, backend) -> do unannexStart file = isAnnexed file $ \(key, backend) -> do
showStart "unannex" file showStart "unannex" file
return $ Just $ unannexPerform file key backend return $ Just $ unannexPerform file key backend
unannexPerform :: FilePath -> Key -> Backend -> SubCmdPerform unannexPerform :: FilePath -> Key -> Backend -> SubCmdCleanup
unannexPerform file key backend = do unannexPerform file key backend = do
-- force backend to always remove -- force backend to always remove
Annex.flagChange "force" $ FlagBool True Annex.flagChange "force" $ FlagBool True
@ -257,7 +257,7 @@ unannexPerform file key backend = do
if (ok) if (ok)
then return $ Just $ unannexCleanup file key then return $ Just $ unannexCleanup file key
else return Nothing else return Nothing
unannexCleanup :: FilePath -> Key -> SubCmdCleanup unannexCleanup :: FilePath -> Key -> SubCmdStatus
unannexCleanup file key = do unannexCleanup file key = do
logStatus key ValueMissing logStatus key ValueMissing
g <- Annex.gitRepo g <- Annex.gitRepo
@ -270,7 +270,7 @@ unannexCleanup file key = do
return True return True
{- Gets an annexed file from one of the backends. -} {- Gets an annexed file from one of the backends. -}
getStart :: FilePath -> SubCmdStart getStart :: FilePath -> SubCmdPerform
getStart file = isAnnexed file $ \(key, backend) -> do getStart file = isAnnexed file $ \(key, backend) -> do
inannex <- inAnnex key inannex <- inAnnex key
if (inannex) if (inannex)
@ -278,7 +278,7 @@ getStart file = isAnnexed file $ \(key, backend) -> do
else do else do
showStart "get" file showStart "get" file
return $ Just $ getPerform key backend return $ Just $ getPerform key backend
getPerform :: Key -> Backend -> SubCmdPerform getPerform :: Key -> Backend -> SubCmdCleanup
getPerform key backend = do getPerform key backend = do
ok <- getViaTmp key (Backend.retrieveKeyFile backend key) ok <- getViaTmp key (Backend.retrieveKeyFile backend key)
if (ok) if (ok)
@ -287,7 +287,7 @@ getPerform key backend = do
{- Indicates a file's content is not wanted anymore, and should be removed {- Indicates a file's content is not wanted anymore, and should be removed
- if it's safe to do so. -} - if it's safe to do so. -}
dropStart :: FilePath -> SubCmdStart dropStart :: FilePath -> SubCmdPerform
dropStart file = isAnnexed file $ \(key, backend) -> do dropStart file = isAnnexed file $ \(key, backend) -> do
inbackend <- Backend.hasKey key inbackend <- Backend.hasKey key
if (not inbackend) if (not inbackend)
@ -295,13 +295,13 @@ dropStart file = isAnnexed file $ \(key, backend) -> do
else do else do
showStart "drop" file showStart "drop" file
return $ Just $ dropPerform key backend return $ Just $ dropPerform key backend
dropPerform :: Key -> Backend -> SubCmdPerform dropPerform :: Key -> Backend -> SubCmdCleanup
dropPerform key backend = do dropPerform key backend = do
success <- Backend.removeKey backend key success <- Backend.removeKey backend key
if (success) if (success)
then return $ Just $ dropCleanup key then return $ Just $ dropCleanup key
else return Nothing else return Nothing
dropCleanup :: Key -> SubCmdCleanup dropCleanup :: Key -> SubCmdStatus
dropCleanup key = do dropCleanup key = do
logStatus key ValueMissing logStatus key ValueMissing
inannex <- inAnnex key inannex <- inAnnex key
@ -314,7 +314,7 @@ dropCleanup key = do
else return True else return True
{- Drops cached content for a key. -} {- Drops cached content for a key. -}
dropKeyStart :: String -> SubCmdStart dropKeyStart :: String -> SubCmdPerform
dropKeyStart keyname = do dropKeyStart keyname = do
backends <- Backend.list backends <- Backend.list
let key = genKey (backends !! 0) keyname let key = genKey (backends !! 0) keyname
@ -327,19 +327,19 @@ dropKeyStart keyname = do
else do else do
showStart "dropkey" keyname showStart "dropkey" keyname
return $ Just $ dropKeyPerform key return $ Just $ dropKeyPerform key
dropKeyPerform :: Key -> SubCmdPerform dropKeyPerform :: Key -> SubCmdCleanup
dropKeyPerform key = do dropKeyPerform key = do
g <- Annex.gitRepo g <- Annex.gitRepo
let loc = annexLocation g key let loc = annexLocation g key
liftIO $ removeFile loc liftIO $ removeFile loc
return $ Just $ dropKeyCleanup key return $ Just $ dropKeyCleanup key
dropKeyCleanup :: Key -> SubCmdCleanup dropKeyCleanup :: Key -> SubCmdStatus
dropKeyCleanup key = do dropKeyCleanup key = do
logStatus key ValueMissing logStatus key ValueMissing
return True return True
{- Sets cached content for a key. -} {- Sets cached content for a key. -}
setKeyStart :: FilePath -> SubCmdStart setKeyStart :: FilePath -> SubCmdPerform
setKeyStart tmpfile = do setKeyStart tmpfile = do
keyname <- Annex.flagGet "key" keyname <- Annex.flagGet "key"
when (null keyname) $ error "please specify the key with --key" when (null keyname) $ error "please specify the key with --key"
@ -347,7 +347,7 @@ setKeyStart tmpfile = do
let key = genKey (backends !! 0) keyname let key = genKey (backends !! 0) keyname
showStart "setkey" tmpfile showStart "setkey" tmpfile
return $ Just $ setKeyPerform tmpfile key return $ Just $ setKeyPerform tmpfile key
setKeyPerform :: FilePath -> Key -> SubCmdPerform setKeyPerform :: FilePath -> Key -> SubCmdCleanup
setKeyPerform tmpfile key = do setKeyPerform tmpfile key = do
g <- Annex.gitRepo g <- Annex.gitRepo
let loc = annexLocation g key let loc = annexLocation g key
@ -355,13 +355,13 @@ setKeyPerform tmpfile key = do
if (not ok) if (not ok)
then error "mv failed!" then error "mv failed!"
else return $ Just $ setKeyCleanup key else return $ Just $ setKeyCleanup key
setKeyCleanup :: Key -> SubCmdCleanup setKeyCleanup :: Key -> SubCmdStatus
setKeyCleanup key = do setKeyCleanup key = do
logStatus key ValuePresent logStatus key ValuePresent
return True return True
{- Fixes the symlink to an annexed file. -} {- Fixes the symlink to an annexed file. -}
fixStart :: FilePath -> SubCmdStart fixStart :: FilePath -> SubCmdPerform
fixStart file = isAnnexed file $ \(key, _) -> do fixStart file = isAnnexed file $ \(key, _) -> do
link <- calcGitLink file key link <- calcGitLink file key
l <- liftIO $ readSymbolicLink file l <- liftIO $ readSymbolicLink file
@ -370,25 +370,25 @@ fixStart file = isAnnexed file $ \(key, _) -> do
else do else do
showStart "fix" file showStart "fix" file
return $ Just $ fixPerform file link return $ Just $ fixPerform file link
fixPerform :: FilePath -> FilePath -> SubCmdPerform fixPerform :: FilePath -> FilePath -> SubCmdCleanup
fixPerform file link = do fixPerform file link = do
liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ createDirectoryIfMissing True (parentDir file)
liftIO $ removeFile file liftIO $ removeFile file
liftIO $ createSymbolicLink link file liftIO $ createSymbolicLink link file
return $ Just $ fixCleanup file return $ Just $ fixCleanup file
fixCleanup :: FilePath -> SubCmdCleanup fixCleanup :: FilePath -> SubCmdStatus
fixCleanup file = do fixCleanup file = do
Annex.queue "add" [] file Annex.queue "add" [] file
return True return True
{- Stores description for the repository etc. -} {- Stores description for the repository etc. -}
initStart :: String -> SubCmdStart initStart :: String -> SubCmdPerform
initStart description = do initStart description = do
when (null description) $ error $ when (null description) $ error $
"please specify a description of this repository\n" ++ usage "please specify a description of this repository\n" ++ usage
showStart "init" description showStart "init" description
return $ Just $ initPerform description return $ Just $ initPerform description
initPerform :: String -> SubCmdPerform initPerform :: String -> SubCmdCleanup
initPerform description = do initPerform description = do
g <- Annex.gitRepo g <- Annex.gitRepo
u <- getUUID g u <- getUUID g
@ -396,7 +396,7 @@ initPerform description = do
liftIO $ gitAttributes g liftIO $ gitAttributes g
liftIO $ gitPreCommitHook g liftIO $ gitPreCommitHook g
return $ Just $ initCleanup return $ Just $ initCleanup
initCleanup :: SubCmdCleanup initCleanup :: SubCmdStatus
initCleanup = do initCleanup = do
g <- Annex.gitRepo g <- Annex.gitRepo
logfile <- uuidLog logfile <- uuidLog
@ -405,7 +405,7 @@ initCleanup = do
return True return True
{- Adds a file pointing at a manually-specified key -} {- Adds a file pointing at a manually-specified key -}
fromKeyStart :: FilePath -> SubCmdStart fromKeyStart :: FilePath -> SubCmdPerform
fromKeyStart file = do fromKeyStart file = do
keyname <- Annex.flagGet "key" keyname <- Annex.flagGet "key"
when (null keyname) $ error "please specify the key with --key" when (null keyname) $ error "please specify the key with --key"
@ -417,13 +417,13 @@ fromKeyStart file = do
"key ("++keyname++") is not present in backend" "key ("++keyname++") is not present in backend"
showStart "fromkey" file showStart "fromkey" file
return $ Just $ fromKeyPerform file key return $ Just $ fromKeyPerform file key
fromKeyPerform :: FilePath -> Key -> SubCmdPerform fromKeyPerform :: FilePath -> Key -> SubCmdCleanup
fromKeyPerform file key = do fromKeyPerform file key = do
link <- calcGitLink file key link <- calcGitLink file key
liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ createDirectoryIfMissing True (parentDir file)
liftIO $ createSymbolicLink link file liftIO $ createSymbolicLink link file
return $ Just $ fromKeyCleanup file return $ Just $ fromKeyCleanup file
fromKeyCleanup :: FilePath -> SubCmdCleanup fromKeyCleanup :: FilePath -> SubCmdStatus
fromKeyCleanup file = do fromKeyCleanup file = do
Annex.queue "add" [] file Annex.queue "add" [] file
return True return True
@ -432,7 +432,7 @@ fromKeyCleanup file = do
- -
- This only operates on the cached file content; it does not involve - This only operates on the cached file content; it does not involve
- moving data in the key-value backend. -} - moving data in the key-value backend. -}
moveStart :: FilePath -> SubCmdStart moveStart :: FilePath -> SubCmdPerform
moveStart file = do moveStart file = do
fromName <- Annex.flagGet "fromrepository" fromName <- Annex.flagGet "fromrepository"
toName <- Annex.flagGet "torepository" toName <- Annex.flagGet "torepository"
@ -453,7 +453,7 @@ moveStart file = do
- A file's content can be moved even if there are insufficient copies to - A file's content can be moved even if there are insufficient copies to
- allow it to be dropped. - allow it to be dropped.
-} -}
moveToStart :: FilePath -> SubCmdStart moveToStart :: FilePath -> SubCmdPerform
moveToStart file = isAnnexed file $ \(key, _) -> do moveToStart file = isAnnexed file $ \(key, _) -> do
ishere <- inAnnex key ishere <- inAnnex key
if (not ishere) if (not ishere)
@ -461,7 +461,7 @@ moveToStart file = isAnnexed file $ \(key, _) -> do
else do else do
showStart "move" file showStart "move" file
return $ Just $ moveToPerform key return $ Just $ moveToPerform key
moveToPerform :: Key -> SubCmdPerform moveToPerform :: Key -> SubCmdCleanup
moveToPerform key = do moveToPerform key = do
-- checking the remote is expensive, so not done in the start step -- checking the remote is expensive, so not done in the start step
remote <- Remotes.commandLineRemote remote <- Remotes.commandLineRemote
@ -478,7 +478,7 @@ moveToPerform key = do
then return $ Just $ moveToCleanup remote key tmpfile then return $ Just $ moveToCleanup remote key tmpfile
else return Nothing -- failed else return Nothing -- failed
Right True -> return $ Just $ dropCleanup key Right True -> return $ Just $ dropCleanup key
moveToCleanup :: Git.Repo -> Key -> FilePath -> SubCmdCleanup moveToCleanup :: Git.Repo -> Key -> FilePath -> SubCmdStatus
moveToCleanup remote key tmpfile = do moveToCleanup remote key tmpfile = do
-- Tell remote to use the transferred content. -- Tell remote to use the transferred content.
ok <- Remotes.runCmd remote "git-annex" ["setkey", "--quiet", ok <- Remotes.runCmd remote "git-annex" ["setkey", "--quiet",
@ -503,7 +503,7 @@ moveToCleanup remote key tmpfile = do
- If the current repository already has the content, it is still removed - If the current repository already has the content, it is still removed
- from the other repository. - from the other repository.
-} -}
moveFromStart :: FilePath -> SubCmdStart moveFromStart :: FilePath -> SubCmdPerform
moveFromStart file = isAnnexed file $ \(key, _) -> do moveFromStart file = isAnnexed file $ \(key, _) -> do
remote <- Remotes.commandLineRemote remote <- Remotes.commandLineRemote
l <- Remotes.keyPossibilities key l <- Remotes.keyPossibilities key
@ -512,7 +512,7 @@ moveFromStart file = isAnnexed file $ \(key, _) -> do
else do else do
showStart "move" file showStart "move" file
return $ Just $ moveFromPerform key return $ Just $ moveFromPerform key
moveFromPerform :: Key -> SubCmdPerform moveFromPerform :: Key -> SubCmdCleanup
moveFromPerform key = do moveFromPerform key = do
remote <- Remotes.commandLineRemote remote <- Remotes.commandLineRemote
ishere <- inAnnex key ishere <- inAnnex key
@ -524,7 +524,7 @@ moveFromPerform key = do
if (ok) if (ok)
then return $ Just $ moveFromCleanup remote key then return $ Just $ moveFromCleanup remote key
else return Nothing -- fail else return Nothing -- fail
moveFromCleanup :: Git.Repo -> Key -> SubCmdCleanup moveFromCleanup :: Git.Repo -> Key -> SubCmdStatus
moveFromCleanup remote key = do moveFromCleanup remote key = do
ok <- Remotes.runCmd remote "git-annex" ["dropkey", "--quiet", "--force", ok <- Remotes.runCmd remote "git-annex" ["dropkey", "--quiet", "--force",
"--backend=" ++ (backendName key), "--backend=" ++ (backendName key),