diff options
author | Joey Hess <joey@kitenet.net> | 2010-11-02 19:04:24 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2010-11-02 19:04:24 -0400 |
commit | 0eae5b806c76b0fa3e21fbae6e5f2d9a39a04cce (patch) | |
tree | 53aada39ec10bc6217507bce1a9add3b86b3793b /Commands.hs | |
parent | 606ed6bb3566fa86c1783e3f1c7d799a6f1be8d1 (diff) |
broke subcommands out into separate modules
Diffstat (limited to 'Commands.hs')
-rw-r--r-- | Commands.hs | 555 |
1 files changed, 0 insertions, 555 deletions
diff --git a/Commands.hs b/Commands.hs deleted file mode 100644 index 330b71ed2..000000000 --- a/Commands.hs +++ /dev/null @@ -1,555 +0,0 @@ -{- git-annex command line - - - - Copyright 2010 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Commands (parseCmd) where - -import System.Console.GetOpt -import Control.Monad.State (liftIO) -import System.Posix.Files -import System.Directory -import Data.String.Utils -import Control.Monad (filterM) -import Monad (when, unless) - -import qualified GitRepo as Git -import qualified Annex -import Utility -import Locations -import qualified Backend -import UUID -import LocationLog -import Types -import Core -import qualified Remotes - -{- A subcommand runs in four stages. - - - - 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 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 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 Bool -{- Some helper functions are used to build up SubCmdSeek and SubCmdStart - - functions. -} -type SubCmdSeekStrings = SubCmdStartString -> SubCmdSeek -type SubCmdStartString = String -> SubCmdStart -type SubCmdSeekBackendFiles = SubCmdStartBackendFile -> SubCmdSeek -type SubCmdStartBackendFile = (FilePath, Maybe Backend) -> SubCmdStart - -data SubCommand = SubCommand { - subcmdname :: String, - subcmdparams :: String, - subcmdseek :: SubCmdSeek, - subcmddesc :: String -} -subCmds :: [SubCommand] -subCmds = [ - (SubCommand "add" path (withFilesNotInGit addStart) - "add files to annex") - , (SubCommand "get" path (withFilesInGit getStart) - "make content of annexed files available") - , (SubCommand "drop" path (withFilesInGit dropStart) - "indicate content of files not currently wanted") - , (SubCommand "move" path (withFilesInGit moveStart) - "transfer content of files to/from another repository") - , (SubCommand "init" desc (withDescription initStart) - "initialize git-annex with repository description") - , (SubCommand "unannex" path (withFilesInGit unannexStart) - "undo accidential add command") - , (SubCommand "fix" path (withFilesInGit fixStart) - "fix up symlinks to point to annexed content") - , (SubCommand "pre-commit" path (withFilesToBeCommitted fixStart) - "fix up symlinks before they are committed") - , (SubCommand "fromkey" key (withFilesMissing fromKeyStart) - "adds a file using a specific key") - , (SubCommand "dropkey" key (withKeys dropKeyStart) - "drops annexed content for specified keys") - , (SubCommand "setkey" key (withTempFile setKeyStart) - "sets annexed content for a key using a temp file") - ] - where - path = "PATH ..." - key = "KEY ..." - desc = "DESCRIPTION" - --- Each dashed command-line option results in generation of an action --- in the Annex monad that performs the necessary setting. -options :: [OptDescr (Annex ())] -options = [ - Option ['f'] ["force"] (NoArg (storebool "force" True)) - "allow actions that may lose annexed data" - , Option ['q'] ["quiet"] (NoArg (storebool "quiet" True)) - "avoid verbose output" - , Option ['v'] ["verbose"] (NoArg (storebool "quiet" False)) - "allow verbose output" - , Option ['b'] ["backend"] (ReqArg (storestring "backend") "NAME") - "specify default key-value backend to use" - , Option ['k'] ["key"] (ReqArg (storestring "key") "KEY") - "specify a key to use" - , Option ['t'] ["to"] (ReqArg (storestring "torepository") "REPOSITORY") - "specify to where to transfer content" - , Option ['f'] ["from"] (ReqArg (storestring "fromrepository") "REPOSITORY") - "specify from where to transfer content" - ] - where - storebool n b = Annex.flagChange n $ FlagBool b - storestring n s = Annex.flagChange n $ FlagString s - -header :: String -header = "Usage: git-annex " ++ (join "|" $ map subcmdname subCmds) - -{- Usage message with lists of options and subcommands. -} -usage :: String -usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs - where - cmddescs = unlines $ map (\c -> indent $ showcmd c) subCmds - showcmd c = - (subcmdname c) ++ - (pad 11 (subcmdname c)) ++ - (subcmdparams c) ++ - (pad 13 (subcmdparams c)) ++ - (subcmddesc c) - indent l = " " ++ l - pad n s = take (n - (length s)) $ repeat ' ' - -{- 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 - list <- Annex.eval state $ seek params - return $ map (\a -> doSubCmd a) list - -{- Runs a subcommand through the start, perform and cleanup stages -} -doSubCmd :: SubCmdStart -> SubCmdCleanup -doSubCmd start = do - s <- start - case (s) of - Nothing -> return True - Just perform -> do - p <- perform - case (p) of - Nothing -> do - showEndFail - return False - Just cleanup -> do - c <- cleanup - if (c) - then do - showEndOk - return True - else do - showEndFail - return False - -{- These functions find appropriate files or other things based on a - user's parameters. -} -withFilesNotInGit :: SubCmdSeekBackendFiles -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 :: SubCmdSeekStrings -withFilesInGit a params = do - repo <- Annex.gitRepo - files <- liftIO $ mapM (Git.inRepo repo) params - return $ map a $ filter notState $ foldl (++) [] files -withFilesMissing :: SubCmdSeekStrings -withFilesMissing a params = do - files <- liftIO $ filterM missing params - return $ map a $ filter notState files - where - missing f = do - e <- doesFileExist f - return $ not e -withDescription :: SubCmdSeekStrings -withDescription a params = do - return $ [a $ unwords params] -withFilesToBeCommitted :: SubCmdSeekStrings -withFilesToBeCommitted a params = do - repo <- Annex.gitRepo - files <- liftIO $ mapM (Git.stagedFiles repo) params - return $ map a $ filter notState $ foldl (++) [] files -withKeys :: SubCmdSeekStrings -withKeys a params = return $ map a params -withTempFile :: SubCmdSeekStrings -withTempFile a params = return $ map a params - -{- filter out files from the state directory -} -notState :: FilePath -> Bool -notState f = stateLoc /= take (length stateLoc) f - -{- Parses command line and returns two lists of actions to be - - run in the Annex monad. The first actions configure it - - according to command line options, while the second actions - - handle subcommands. -} -parseCmd :: [String] -> AnnexState -> IO ([Annex Bool], [Annex Bool]) -parseCmd argv state = do - (flags, params) <- getopt - when (null params) $ error usage - case lookupCmd (params !! 0) of - [] -> error usage - [subcommand] -> do - actions <- prepSubCmd subcommand state (drop 1 params) - let configactions = map (\flag -> do - flag - return True) flags - return (configactions, actions) - _ -> error "internal error: multiple matching subcommands" - where - getopt = case getOpt Permute options argv of - (flags, params, []) -> return (flags, params) - (_, _, errs) -> ioError (userError (concat errs ++ usage)) - lookupCmd cmd = filter (\c -> cmd == subcmdname c) subCmds - -{- 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 :: SubCmdStartBackendFile -addStart pair@(file, _) = notAnnexed file $ do - s <- liftIO $ getSymbolicLinkStatus file - if ((isSymbolicLink s) || (not $ isRegularFile s)) - then return Nothing - else do - showStart "add" file - return $ Just $ addPerform pair -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 -> SubCmdCleanup -addCleanup file key = do - logStatus key ValuePresent - g <- Annex.gitRepo - let dest = annexLocation g key - liftIO $ createDirectoryIfMissing True (parentDir dest) - liftIO $ renameFile file dest - link <- calcGitLink file key - liftIO $ createSymbolicLink link file - Annex.queue "add" [] file - return True - -{- The unannex subcommand undoes an add. -} -unannexStart :: SubCmdStartString -unannexStart file = isAnnexed file $ \(key, backend) -> do - showStart "unannex" file - return $ Just $ unannexPerform file key backend -unannexPerform :: FilePath -> Key -> Backend -> SubCmdPerform -unannexPerform file key backend = do - -- force backend to always remove - Annex.flagChange "force" $ FlagBool True - ok <- Backend.removeKey backend key - if (ok) - then return $ Just $ unannexCleanup file key - else return Nothing -unannexCleanup :: FilePath -> Key -> SubCmdCleanup -unannexCleanup file key = do - logStatus key ValueMissing - g <- Annex.gitRepo - let src = annexLocation g key - liftIO $ removeFile file - liftIO $ Git.run g ["rm", "--quiet", file] - -- git rm deletes empty directories; put them back - liftIO $ createDirectoryIfMissing True (parentDir file) - liftIO $ renameFile src file - return True - -{- Gets an annexed file from one of the backends. -} -getStart :: SubCmdStartString -getStart file = isAnnexed file $ \(key, backend) -> do - inannex <- inAnnex key - if (inannex) - then return Nothing - else do - showStart "get" file - return $ Just $ getPerform key backend -getPerform :: Key -> Backend -> SubCmdPerform -getPerform key backend = do - ok <- getViaTmp key (Backend.retrieveKeyFile backend key) - if (ok) - then return $ Just $ return True -- no cleanup needed - else return Nothing - -{- Indicates a file's content is not wanted anymore, and should be removed - - if it's safe to do so. -} -dropStart :: SubCmdStartString -dropStart file = isAnnexed file $ \(key, backend) -> do - inbackend <- Backend.hasKey key - if (not inbackend) - then return Nothing - else do - showStart "drop" file - return $ Just $ dropPerform key backend -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 -> SubCmdCleanup -dropCleanup key = do - logStatus key ValueMissing - inannex <- inAnnex key - if (inannex) - then do - g <- Annex.gitRepo - let loc = annexLocation g key - liftIO $ removeFile loc - return True - else return True - -{- Drops cached content for a key. -} -dropKeyStart :: SubCmdStartString -dropKeyStart keyname = do - backends <- Backend.list - let key = genKey (backends !! 0) keyname - present <- inAnnex key - force <- Annex.flagIsSet "force" - if (not present) - then return Nothing - else if (not force) - then error "dropkey is can cause data loss; use --force if you're sure you want to do this" - else do - showStart "dropkey" keyname - return $ Just $ dropKeyPerform key -dropKeyPerform :: Key -> SubCmdPerform -dropKeyPerform key = do - g <- Annex.gitRepo - let loc = annexLocation g key - liftIO $ removeFile loc - return $ Just $ dropKeyCleanup key -dropKeyCleanup :: Key -> SubCmdCleanup -dropKeyCleanup key = do - logStatus key ValueMissing - return True - -{- Sets cached content for a key. -} -setKeyStart :: SubCmdStartString -setKeyStart tmpfile = do - keyname <- Annex.flagGet "key" - when (null keyname) $ error "please specify the key with --key" - backends <- Backend.list - let key = genKey (backends !! 0) keyname - showStart "setkey" tmpfile - return $ Just $ setKeyPerform tmpfile key -setKeyPerform :: FilePath -> Key -> SubCmdPerform -setKeyPerform tmpfile key = do - g <- Annex.gitRepo - let loc = annexLocation g key - ok <- liftIO $ boolSystem "mv" [tmpfile, loc] - if (not ok) - then error "mv failed!" - else return $ Just $ setKeyCleanup key -setKeyCleanup :: Key -> SubCmdCleanup -setKeyCleanup key = do - logStatus key ValuePresent - return True - -{- Fixes the symlink to an annexed file. -} -fixStart :: SubCmdStartString -fixStart file = isAnnexed file $ \(key, _) -> do - link <- calcGitLink file key - l <- liftIO $ readSymbolicLink file - if (link == l) - then return Nothing - else do - showStart "fix" file - return $ Just $ fixPerform file link -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 -> SubCmdCleanup -fixCleanup file = do - Annex.queue "add" [] file - return True - -{- Stores description for the repository etc. -} -initStart :: SubCmdStartString -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 description = do - g <- Annex.gitRepo - u <- getUUID g - describeUUID u description - liftIO $ gitAttributes g - liftIO $ gitPreCommitHook g - return $ Just $ initCleanup -initCleanup :: SubCmdCleanup -initCleanup = do - g <- Annex.gitRepo - logfile <- uuidLog - liftIO $ Git.run g ["add", logfile] - liftIO $ Git.run g ["commit", "-m", "git annex init", logfile] - return True - -{- Adds a file pointing at a manually-specified key -} -fromKeyStart :: SubCmdStartString -fromKeyStart file = do - keyname <- Annex.flagGet "key" - when (null keyname) $ error "please specify the key with --key" - backends <- Backend.list - let key = genKey (backends !! 0) keyname - - inbackend <- Backend.hasKey key - unless (inbackend) $ error $ - "key ("++keyname++") is not present in backend" - showStart "fromkey" file - return $ Just $ fromKeyPerform file key -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 -> SubCmdCleanup -fromKeyCleanup file = do - Annex.queue "add" [] file - return True - -{- Move a file either --to or --from a repository. - - - - This only operates on the cached file content; it does not involve - - moving data in the key-value backend. -} -moveStart :: SubCmdStartString -moveStart file = do - fromName <- Annex.flagGet "fromrepository" - toName <- Annex.flagGet "torepository" - case (fromName, toName) of - ("", "") -> error "specify either --from or --to" - ("", _) -> moveToStart file - (_ , "") -> moveFromStart file - (_ , _) -> error "only one of --from or --to can be specified" - -{- Moves the content of an annexed file to another repository, - - removing it from the current repository, and updates locationlog - - information on both. - - - - If the destination already has the content, it is still removed - - from the current repository. - - - - Note that unlike drop, this does not honor annex.numcopies. - - A file's content can be moved even if there are insufficient copies to - - allow it to be dropped. - -} -moveToStart :: SubCmdStartString -moveToStart file = isAnnexed file $ \(key, _) -> do - ishere <- inAnnex key - if (not ishere) - then return Nothing -- not here, so nothing to do - else do - showStart "move" file - return $ Just $ moveToPerform key -moveToPerform :: Key -> SubCmdPerform -moveToPerform key = do - -- checking the remote is expensive, so not done in the start step - remote <- Remotes.commandLineRemote - isthere <- Remotes.inAnnex remote key - case isthere of - Left err -> do - showNote $ show err - return Nothing - Right False -> do - Core.showNote $ "moving to " ++ (Git.repoDescribe remote) ++ "..." - let tmpfile = (annexTmpLocation remote) ++ (keyFile key) - ok <- Remotes.copyToRemote remote key tmpfile - if (ok) - then return $ Just $ moveToCleanup remote key tmpfile - else return Nothing -- failed - Right True -> return $ Just $ dropCleanup key -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", - "--backend=" ++ (backendName key), - "--key=" ++ keyName key, - tmpfile] - if ok - then do - -- Record that the key is present on the remote. - g <- Annex.gitRepo - remoteuuid <- getUUID remote - logfile <- liftIO $ logChange g key remoteuuid ValuePresent - Annex.queue "add" [] logfile - -- Cleanup on the local side is the same as done for the - -- drop subcommand. - dropCleanup key - else return False - -{- Moves the content of an annexed file from another repository to the current - - repository and updates locationlog information on both. - - - - If the current repository already has the content, it is still removed - - from the other repository. - -} -moveFromStart :: SubCmdStartString -moveFromStart file = isAnnexed file $ \(key, _) -> do - remote <- Remotes.commandLineRemote - l <- Remotes.keyPossibilities key - if (null $ filter (\r -> Remotes.same r remote) l) - then return Nothing - else do - showStart "move" file - return $ Just $ moveFromPerform key -moveFromPerform :: Key -> SubCmdPerform -moveFromPerform key = do - remote <- Remotes.commandLineRemote - ishere <- inAnnex key - if (ishere) - then return $ Just $ moveFromCleanup remote key - else do - Core.showNote $ "moving from " ++ (Git.repoDescribe remote) ++ "..." - ok <- getViaTmp key (Remotes.copyFromRemote remote key) - if (ok) - then return $ Just $ moveFromCleanup remote key - else return Nothing -- fail -moveFromCleanup :: Git.Repo -> Key -> SubCmdCleanup -moveFromCleanup remote key = do - ok <- Remotes.runCmd remote "git-annex" ["dropkey", "--quiet", "--force", - "--backend=" ++ (backendName key), - keyName key] - when ok $ do - -- Record locally that the key is not on the remote. - remoteuuid <- getUUID remote - g <- Annex.gitRepo - logfile <- liftIO $ logChange g key remoteuuid ValueMissing - Annex.queue "add" [] logfile - return ok - --- helpers -notAnnexed :: FilePath -> Annex (Maybe a) -> Annex (Maybe a) -notAnnexed file a = do - r <- Backend.lookupFile file - case (r) of - Just _ -> return Nothing - Nothing -> a -isAnnexed :: FilePath -> ((Key, Backend) -> Annex (Maybe a)) -> Annex (Maybe a) -isAnnexed file a = do - r <- Backend.lookupFile file - case (r) of - Just v -> a v - Nothing -> return Nothing |