From 82d5a46c5618c6d35ef7b85c5cc257875de4a34b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 1 Nov 2010 20:13:10 -0400 Subject: finally got the types clear enough --- Commands.hs | 64 +++++++++++++++++++++++++++++++------------------------------ 1 file changed, 33 insertions(+), 31 deletions(-) (limited to 'Commands.hs') diff --git a/Commands.hs b/Commands.hs index 01761d030..199b83abf 100644 --- a/Commands.hs +++ b/Commands.hs @@ -31,23 +31,25 @@ import qualified Remotes - 0. The seek stage takes the parameters passed to the subcommand, - looks through the repo to find the ones that are relevant - to that subcommand (ie, new files to add), and generates - - a start stage action. -} -type SubCmdSeekStrings = SubCmdStartString -> SubCmdSeek -type SubCmdSeekBackendFiles = SubCmdStartBackendFile -> SubCmdSeek -type SubCmdSeek = [String] -> Annex [SubCmdPerform] + - a list of start stage actions. -} +type SubCmdSeek = [String] -> Annex [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 SubCmdStartString = String -> SubCmdPerform -type SubCmdStartBackendFile = (FilePath, Maybe Backend) -> SubCmdPerform +type SubCmdStart = Annex (Maybe 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 (Maybe SubCmdStatus) -type SubCmdStatus = Annex Bool +type SubCmdCleanup = Annex Bool +{- Some helper functions are used to build up SubCmdSeek and SubCmdStart + - functions. -} +type SubCmdSeekStrings = SubCmdStartString -> SubCmdSeek +type SubCmdSeekBackendFiles = SubCmdStartBackendFile -> SubCmdSeek +type SubCmdStartString = String -> SubCmdStart +type SubCmdStartBackendFile = (FilePath, Maybe Backend) -> SubCmdStart data SubCommand = SubCommand { subcmdname :: String, @@ -125,7 +127,7 @@ usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs indent l = " " ++ l pad n s = take (n - (length s)) $ repeat ' ' -{- Prepares a set of actions to run to perform a subcommand, based on +{- Prepares a list of actions to run to perform a subcommand, based on - the parameters passed to it. -} prepSubCmd :: SubCommand -> AnnexState -> [String] -> IO [Annex Bool] prepSubCmd SubCommand { subcmdseek = seek } state params = do @@ -133,7 +135,7 @@ prepSubCmd SubCommand { subcmdseek = seek } state params = do return $ map (\a -> doSubCmd a) list {- Runs a subcommand through the start, perform and cleanup stages -} -doSubCmd :: SubCmdPerform -> SubCmdStatus +doSubCmd :: SubCmdStart -> SubCmdCleanup doSubCmd start = do s <- start case (s) of @@ -227,13 +229,13 @@ addStart pair@(file, _) = notAnnexed file $ do else do showStart "add" file return $ Just $ addPerform pair -addPerform :: (FilePath, Maybe Backend) -> SubCmdCleanup +addPerform :: (FilePath, Maybe Backend) -> SubCmdPerform 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 -> SubCmdStatus +addCleanup :: FilePath -> Key -> SubCmdCleanup addCleanup file key = do logStatus key ValuePresent g <- Annex.gitRepo @@ -250,7 +252,7 @@ unannexStart :: SubCmdStartString unannexStart file = isAnnexed file $ \(key, backend) -> do showStart "unannex" file return $ Just $ unannexPerform file key backend -unannexPerform :: FilePath -> Key -> Backend -> SubCmdCleanup +unannexPerform :: FilePath -> Key -> Backend -> SubCmdPerform unannexPerform file key backend = do -- force backend to always remove Annex.flagChange "force" $ FlagBool True @@ -258,7 +260,7 @@ unannexPerform file key backend = do if (ok) then return $ Just $ unannexCleanup file key else return Nothing -unannexCleanup :: FilePath -> Key -> SubCmdStatus +unannexCleanup :: FilePath -> Key -> SubCmdCleanup unannexCleanup file key = do logStatus key ValueMissing g <- Annex.gitRepo @@ -279,7 +281,7 @@ getStart file = isAnnexed file $ \(key, backend) -> do else do showStart "get" file return $ Just $ getPerform key backend -getPerform :: Key -> Backend -> SubCmdCleanup +getPerform :: Key -> Backend -> SubCmdPerform getPerform key backend = do ok <- getViaTmp key (Backend.retrieveKeyFile backend key) if (ok) @@ -296,13 +298,13 @@ dropStart file = isAnnexed file $ \(key, backend) -> do else do showStart "drop" file return $ Just $ dropPerform key backend -dropPerform :: Key -> Backend -> SubCmdCleanup +dropPerform :: Key -> Backend -> SubCmdPerform dropPerform key backend = do success <- Backend.removeKey backend key if (success) then return $ Just $ dropCleanup key else return Nothing -dropCleanup :: Key -> SubCmdStatus +dropCleanup :: Key -> SubCmdCleanup dropCleanup key = do logStatus key ValueMissing inannex <- inAnnex key @@ -328,13 +330,13 @@ dropKeyStart keyname = do else do showStart "dropkey" keyname return $ Just $ dropKeyPerform key -dropKeyPerform :: Key -> SubCmdCleanup +dropKeyPerform :: Key -> SubCmdPerform dropKeyPerform key = do g <- Annex.gitRepo let loc = annexLocation g key liftIO $ removeFile loc return $ Just $ dropKeyCleanup key -dropKeyCleanup :: Key -> SubCmdStatus +dropKeyCleanup :: Key -> SubCmdCleanup dropKeyCleanup key = do logStatus key ValueMissing return True @@ -348,7 +350,7 @@ setKeyStart tmpfile = do let key = genKey (backends !! 0) keyname showStart "setkey" tmpfile return $ Just $ setKeyPerform tmpfile key -setKeyPerform :: FilePath -> Key -> SubCmdCleanup +setKeyPerform :: FilePath -> Key -> SubCmdPerform setKeyPerform tmpfile key = do g <- Annex.gitRepo let loc = annexLocation g key @@ -356,7 +358,7 @@ setKeyPerform tmpfile key = do if (not ok) then error "mv failed!" else return $ Just $ setKeyCleanup key -setKeyCleanup :: Key -> SubCmdStatus +setKeyCleanup :: Key -> SubCmdCleanup setKeyCleanup key = do logStatus key ValuePresent return True @@ -371,13 +373,13 @@ fixStart file = isAnnexed file $ \(key, _) -> do else do showStart "fix" file return $ Just $ fixPerform file link -fixPerform :: FilePath -> FilePath -> SubCmdCleanup +fixPerform :: FilePath -> FilePath -> SubCmdPerform fixPerform file link = do liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ removeFile file liftIO $ createSymbolicLink link file return $ Just $ fixCleanup file -fixCleanup :: FilePath -> SubCmdStatus +fixCleanup :: FilePath -> SubCmdCleanup fixCleanup file = do Annex.queue "add" [] file return True @@ -389,7 +391,7 @@ initStart description = do "please specify a description of this repository\n" ++ usage showStart "init" description return $ Just $ initPerform description -initPerform :: String -> SubCmdCleanup +initPerform :: String -> SubCmdPerform initPerform description = do g <- Annex.gitRepo u <- getUUID g @@ -397,7 +399,7 @@ initPerform description = do liftIO $ gitAttributes g liftIO $ gitPreCommitHook g return $ Just $ initCleanup -initCleanup :: SubCmdStatus +initCleanup :: SubCmdCleanup initCleanup = do g <- Annex.gitRepo logfile <- uuidLog @@ -418,13 +420,13 @@ fromKeyStart file = do "key ("++keyname++") is not present in backend" showStart "fromkey" file return $ Just $ fromKeyPerform file key -fromKeyPerform :: FilePath -> Key -> SubCmdCleanup +fromKeyPerform :: FilePath -> Key -> SubCmdPerform fromKeyPerform file key = do link <- calcGitLink file key liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ createSymbolicLink link file return $ Just $ fromKeyCleanup file -fromKeyCleanup :: FilePath -> SubCmdStatus +fromKeyCleanup :: FilePath -> SubCmdCleanup fromKeyCleanup file = do Annex.queue "add" [] file return True @@ -462,7 +464,7 @@ moveToStart file = isAnnexed file $ \(key, _) -> do else do showStart "move" file return $ Just $ moveToPerform key -moveToPerform :: Key -> SubCmdCleanup +moveToPerform :: Key -> SubCmdPerform moveToPerform key = do -- checking the remote is expensive, so not done in the start step remote <- Remotes.commandLineRemote @@ -479,7 +481,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 -> SubCmdStatus +moveToCleanup :: Git.Repo -> Key -> FilePath -> SubCmdCleanup moveToCleanup remote key tmpfile = do -- Tell remote to use the transferred content. ok <- Remotes.runCmd remote "git-annex" ["setkey", "--quiet", @@ -513,7 +515,7 @@ moveFromStart file = isAnnexed file $ \(key, _) -> do else do showStart "move" file return $ Just $ moveFromPerform key -moveFromPerform :: Key -> SubCmdCleanup +moveFromPerform :: Key -> SubCmdPerform moveFromPerform key = do remote <- Remotes.commandLineRemote ishere <- inAnnex key @@ -525,7 +527,7 @@ moveFromPerform key = do if (ok) then return $ Just $ moveFromCleanup remote key else return Nothing -- fail -moveFromCleanup :: Git.Repo -> Key -> SubCmdStatus +moveFromCleanup :: Git.Repo -> Key -> SubCmdCleanup moveFromCleanup remote key = do ok <- Remotes.runCmd remote "git-annex" ["dropkey", "--quiet", "--force", "--backend=" ++ (backendName key), -- cgit v1.2.3