diff options
author | Joey Hess <joey@kitenet.net> | 2010-11-01 19:18:47 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2010-11-01 19:18:47 -0400 |
commit | 1f9996f7424a6581ed92b56e3ad3f298348c1daf (patch) | |
tree | 67bb43ee65e0f1e281499dd4b2b975fc1df2a7ca /Commands.hs | |
parent | f1f4bdcd6054303a5711944e146093d2f4f8069b (diff) |
less confusing names for the subcommand stage types
Diffstat (limited to 'Commands.hs')
-rw-r--r-- | Commands.hs | 96 |
1 files changed, 48 insertions, 48 deletions
diff --git a/Commands.hs b/Commands.hs index c012cdca0..f4f675d02 100644 --- a/Commands.hs +++ b/Commands.hs @@ -33,23 +33,25 @@ import qualified Remotes - looks through the repo to find the ones that are relevant - to that subcommand (ie, new files to add), and returns a list of - 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 - subcommand, 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 SubCmdStart = Annex (Maybe SubCmdPerform) +type SubCmdStart = [String] -> Annex [SubCmdPerform] {- 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. -} type SubCmdPerform = Annex (Maybe SubCmdCleanup) {- 3. The cleanup stage is run only if the perform stage succeeds, and it - returns the overall success/fail of the subcommand. -} -type SubCmdCleanup = Annex Bool +type SubCmdCleanup = Annex (Maybe SubCmdStatus) +type SubCmdStatus = Annex Bool data SubCommand = SubCommand { subcmdname :: String, subcmdparams :: String, - subcmdparse :: SubCmdParse, + subcmdparse :: SubCmdStart, subcmddesc :: String } subCmds :: [SubCommand] @@ -130,7 +132,7 @@ prepSubCmd SubCommand { subcmdparse = parse } state params = do return $ map (\a -> doSubCmd a) list {- Runs a subcommand through the start, perform and cleanup stages -} -doSubCmd :: SubCmdStart -> SubCmdCleanup +doSubCmd :: SubCmdPerform -> SubCmdStatus doSubCmd start = do s <- start case (s) of @@ -151,23 +153,21 @@ doSubCmd start = do showEndFail 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. -} -type ParseStrings = (String -> SubCmdStart) -> SubCmdParse -type ParseBackendFiles = ((FilePath, Maybe Backend) -> SubCmdStart) -> SubCmdParse -withFilesNotInGit :: ParseBackendFiles +withFilesNotInGit :: SubCmdParseBackendFiles withFilesNotInGit a params = do repo <- Annex.gitRepo files <- liftIO $ mapM (Git.notInRepo repo) params let files' = foldl (++) [] files pairs <- Backend.chooseBackends files' return $ map a $ filter (\(f,_) -> notState f) pairs -withFilesInGit :: ParseStrings +withFilesInGit :: SubCmdParseStrings withFilesInGit a params = do repo <- Annex.gitRepo files <- liftIO $ mapM (Git.inRepo repo) params return $ map a $ filter notState $ foldl (++) [] files -withFilesMissing :: ParseStrings +withFilesMissing :: SubCmdParseStrings withFilesMissing a params = do files <- liftIO $ filterM missing params return $ map a $ filter notState files @@ -175,17 +175,17 @@ withFilesMissing a params = do missing f = do e <- doesFileExist f return $ not e -withDescription :: ParseStrings +withDescription :: SubCmdParseStrings withDescription a params = do return $ [a $ unwords params] -withFilesToBeCommitted :: ParseStrings +withFilesToBeCommitted :: SubCmdParseStrings withFilesToBeCommitted a params = do repo <- Annex.gitRepo files <- liftIO $ mapM (Git.stagedFiles repo) params return $ map a $ filter notState $ foldl (++) [] files -withKeys :: ParseStrings +withKeys :: SubCmdParseStrings withKeys a params = return $ map a params -withTempFile :: ParseStrings +withTempFile :: SubCmdParseStrings withTempFile a params = return $ map a params {- 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 - moving it into the annex directory and setting up the symlink pointing - to its content. -} -addStart :: (FilePath, Maybe Backend) -> SubCmdStart +addStart :: (FilePath, Maybe Backend) -> SubCmdPerform addStart pair@(file, _) = notAnnexed file $ do s <- liftIO $ getSymbolicLinkStatus file if ((isSymbolicLink s) || (not $ isRegularFile s)) @@ -226,13 +226,13 @@ addStart pair@(file, _) = notAnnexed file $ do else do showStart "add" file return $ Just $ addPerform pair -addPerform :: (FilePath, Maybe Backend) -> SubCmdPerform +addPerform :: (FilePath, Maybe Backend) -> SubCmdCleanup addPerform (file, backend) = do stored <- Backend.storeFileKey file backend case (stored) of Nothing -> return Nothing Just (key, _) -> return $ Just $ addCleanup file key -addCleanup :: FilePath -> Key -> SubCmdCleanup +addCleanup :: FilePath -> Key -> SubCmdStatus addCleanup file key = do logStatus key ValuePresent g <- Annex.gitRepo @@ -245,11 +245,11 @@ addCleanup file key = do return True {- The unannex subcommand undoes an add. -} -unannexStart :: FilePath -> SubCmdStart +unannexStart :: FilePath -> SubCmdPerform unannexStart file = isAnnexed file $ \(key, backend) -> do showStart "unannex" file return $ Just $ unannexPerform file key backend -unannexPerform :: FilePath -> Key -> Backend -> SubCmdPerform +unannexPerform :: FilePath -> Key -> Backend -> SubCmdCleanup unannexPerform file key backend = do -- force backend to always remove Annex.flagChange "force" $ FlagBool True @@ -257,7 +257,7 @@ unannexPerform file key backend = do if (ok) then return $ Just $ unannexCleanup file key else return Nothing -unannexCleanup :: FilePath -> Key -> SubCmdCleanup +unannexCleanup :: FilePath -> Key -> SubCmdStatus unannexCleanup file key = do logStatus key ValueMissing g <- Annex.gitRepo @@ -270,7 +270,7 @@ unannexCleanup file key = do return True {- Gets an annexed file from one of the backends. -} -getStart :: FilePath -> SubCmdStart +getStart :: FilePath -> SubCmdPerform getStart file = isAnnexed file $ \(key, backend) -> do inannex <- inAnnex key if (inannex) @@ -278,7 +278,7 @@ getStart file = isAnnexed file $ \(key, backend) -> do else do showStart "get" file return $ Just $ getPerform key backend -getPerform :: Key -> Backend -> SubCmdPerform +getPerform :: Key -> Backend -> SubCmdCleanup getPerform key backend = do ok <- getViaTmp key (Backend.retrieveKeyFile backend key) if (ok) @@ -287,7 +287,7 @@ getPerform key backend = do {- Indicates a file's content is not wanted anymore, and should be removed - if it's safe to do so. -} -dropStart :: FilePath -> SubCmdStart +dropStart :: FilePath -> SubCmdPerform dropStart file = isAnnexed file $ \(key, backend) -> do inbackend <- Backend.hasKey key if (not inbackend) @@ -295,13 +295,13 @@ dropStart file = isAnnexed file $ \(key, backend) -> do else do showStart "drop" file return $ Just $ dropPerform key backend -dropPerform :: Key -> Backend -> SubCmdPerform +dropPerform :: Key -> Backend -> SubCmdCleanup dropPerform key backend = do success <- Backend.removeKey backend key if (success) then return $ Just $ dropCleanup key else return Nothing -dropCleanup :: Key -> SubCmdCleanup +dropCleanup :: Key -> SubCmdStatus dropCleanup key = do logStatus key ValueMissing inannex <- inAnnex key @@ -314,7 +314,7 @@ dropCleanup key = do else return True {- Drops cached content for a key. -} -dropKeyStart :: String -> SubCmdStart +dropKeyStart :: String -> SubCmdPerform dropKeyStart keyname = do backends <- Backend.list let key = genKey (backends !! 0) keyname @@ -327,19 +327,19 @@ dropKeyStart keyname = do else do showStart "dropkey" keyname return $ Just $ dropKeyPerform key -dropKeyPerform :: Key -> SubCmdPerform +dropKeyPerform :: Key -> SubCmdCleanup dropKeyPerform key = do g <- Annex.gitRepo let loc = annexLocation g key liftIO $ removeFile loc return $ Just $ dropKeyCleanup key -dropKeyCleanup :: Key -> SubCmdCleanup +dropKeyCleanup :: Key -> SubCmdStatus dropKeyCleanup key = do logStatus key ValueMissing return True {- Sets cached content for a key. -} -setKeyStart :: FilePath -> SubCmdStart +setKeyStart :: FilePath -> SubCmdPerform setKeyStart tmpfile = do keyname <- Annex.flagGet "key" when (null keyname) $ error "please specify the key with --key" @@ -347,7 +347,7 @@ setKeyStart tmpfile = do let key = genKey (backends !! 0) keyname showStart "setkey" tmpfile return $ Just $ setKeyPerform tmpfile key -setKeyPerform :: FilePath -> Key -> SubCmdPerform +setKeyPerform :: FilePath -> Key -> SubCmdCleanup setKeyPerform tmpfile key = do g <- Annex.gitRepo let loc = annexLocation g key @@ -355,13 +355,13 @@ setKeyPerform tmpfile key = do if (not ok) then error "mv failed!" else return $ Just $ setKeyCleanup key -setKeyCleanup :: Key -> SubCmdCleanup +setKeyCleanup :: Key -> SubCmdStatus setKeyCleanup key = do logStatus key ValuePresent return True {- Fixes the symlink to an annexed file. -} -fixStart :: FilePath -> SubCmdStart +fixStart :: FilePath -> SubCmdPerform fixStart file = isAnnexed file $ \(key, _) -> do link <- calcGitLink file key l <- liftIO $ readSymbolicLink file @@ -370,25 +370,25 @@ fixStart file = isAnnexed file $ \(key, _) -> do else do showStart "fix" file return $ Just $ fixPerform file link -fixPerform :: FilePath -> FilePath -> SubCmdPerform +fixPerform :: FilePath -> FilePath -> SubCmdCleanup fixPerform file link = do liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ removeFile file liftIO $ createSymbolicLink link file return $ Just $ fixCleanup file -fixCleanup :: FilePath -> SubCmdCleanup +fixCleanup :: FilePath -> SubCmdStatus fixCleanup file = do Annex.queue "add" [] file return True {- Stores description for the repository etc. -} -initStart :: String -> SubCmdStart +initStart :: String -> SubCmdPerform initStart description = do when (null description) $ error $ "please specify a description of this repository\n" ++ usage showStart "init" description return $ Just $ initPerform description -initPerform :: String -> SubCmdPerform +initPerform :: String -> SubCmdCleanup initPerform description = do g <- Annex.gitRepo u <- getUUID g @@ -396,7 +396,7 @@ initPerform description = do liftIO $ gitAttributes g liftIO $ gitPreCommitHook g return $ Just $ initCleanup -initCleanup :: SubCmdCleanup +initCleanup :: SubCmdStatus initCleanup = do g <- Annex.gitRepo logfile <- uuidLog @@ -405,7 +405,7 @@ initCleanup = do return True {- Adds a file pointing at a manually-specified key -} -fromKeyStart :: FilePath -> SubCmdStart +fromKeyStart :: FilePath -> SubCmdPerform fromKeyStart file = do keyname <- Annex.flagGet "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" showStart "fromkey" file return $ Just $ fromKeyPerform file key -fromKeyPerform :: FilePath -> Key -> SubCmdPerform +fromKeyPerform :: FilePath -> Key -> SubCmdCleanup fromKeyPerform file key = do link <- calcGitLink file key liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ createSymbolicLink link file return $ Just $ fromKeyCleanup file -fromKeyCleanup :: FilePath -> SubCmdCleanup +fromKeyCleanup :: FilePath -> SubCmdStatus fromKeyCleanup file = do Annex.queue "add" [] file return True @@ -432,7 +432,7 @@ fromKeyCleanup file = do - - This only operates on the cached file content; it does not involve - moving data in the key-value backend. -} -moveStart :: FilePath -> SubCmdStart +moveStart :: FilePath -> SubCmdPerform moveStart file = do fromName <- Annex.flagGet "fromrepository" 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 - allow it to be dropped. -} -moveToStart :: FilePath -> SubCmdStart +moveToStart :: FilePath -> SubCmdPerform moveToStart file = isAnnexed file $ \(key, _) -> do ishere <- inAnnex key if (not ishere) @@ -461,7 +461,7 @@ moveToStart file = isAnnexed file $ \(key, _) -> do else do showStart "move" file return $ Just $ moveToPerform key -moveToPerform :: Key -> SubCmdPerform +moveToPerform :: Key -> SubCmdCleanup moveToPerform key = do -- checking the remote is expensive, so not done in the start step remote <- Remotes.commandLineRemote @@ -478,7 +478,7 @@ moveToPerform key = do then return $ Just $ moveToCleanup remote key tmpfile else return Nothing -- failed Right True -> return $ Just $ dropCleanup key -moveToCleanup :: Git.Repo -> Key -> FilePath -> SubCmdCleanup +moveToCleanup :: Git.Repo -> Key -> FilePath -> SubCmdStatus moveToCleanup remote key tmpfile = do -- Tell remote to use the transferred content. 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 - from the other repository. -} -moveFromStart :: FilePath -> SubCmdStart +moveFromStart :: FilePath -> SubCmdPerform moveFromStart file = isAnnexed file $ \(key, _) -> do remote <- Remotes.commandLineRemote l <- Remotes.keyPossibilities key @@ -512,7 +512,7 @@ moveFromStart file = isAnnexed file $ \(key, _) -> do else do showStart "move" file return $ Just $ moveFromPerform key -moveFromPerform :: Key -> SubCmdPerform +moveFromPerform :: Key -> SubCmdCleanup moveFromPerform key = do remote <- Remotes.commandLineRemote ishere <- inAnnex key @@ -524,7 +524,7 @@ moveFromPerform key = do if (ok) then return $ Just $ moveFromCleanup remote key else return Nothing -- fail -moveFromCleanup :: Git.Repo -> Key -> SubCmdCleanup +moveFromCleanup :: Git.Repo -> Key -> SubCmdStatus moveFromCleanup remote key = do ok <- Remotes.runCmd remote "git-annex" ["dropkey", "--quiet", "--force", "--backend=" ++ (backendName key), |