diff --git a/CmdLine.hs b/CmdLine.hs new file mode 100644 index 0000000000..494da2873c --- /dev/null +++ b/CmdLine.hs @@ -0,0 +1,201 @@ +{- git-annex command line + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module CmdLine (parseCmd) where + +import System.Console.GetOpt +import Control.Monad.State (liftIO) +import System.Directory +import Data.String.Utils +import Control.Monad (filterM) +import Monad (when) + +import qualified GitRepo as Git +import qualified Annex +import Locations +import qualified Backend +import Types +import Core + +import Command +import qualified Command.Add +import qualified Command.Unannex +import qualified Command.Drop +import qualified Command.Move +import qualified Command.Get +import qualified Command.FromKey +import qualified Command.DropKey +import qualified Command.SetKey +import qualified Command.Fix +import qualified Command.Init + +data SubCommand = SubCommand { + subcmdname :: String, + subcmdparams :: String, + subcmdseek :: SubCmdSeek, + subcmddesc :: String +} +subCmds :: [SubCommand] +subCmds = [ + (SubCommand "add" path (withFilesNotInGit Command.Add.start) + "add files to annex") + , (SubCommand "get" path (withFilesInGit Command.Get.start) + "make content of annexed files available") + , (SubCommand "drop" path (withFilesInGit Command.Drop.start) + "indicate content of files not currently wanted") + , (SubCommand "move" path (withFilesInGit Command.Move.start) + "transfer content of files to/from another repository") + , (SubCommand "init" desc (withDescription Command.Init.start) + "initialize git-annex with repository description") + , (SubCommand "unannex" path (withFilesInGit Command.Unannex.start) + "undo accidential add command") + , (SubCommand "fix" path (withFilesInGit Command.Fix.start) + "fix up symlinks to point to annexed content") + , (SubCommand "pre-commit" path (withFilesToBeCommitted Command.Fix.start) + "fix up symlinks before they are committed") + , (SubCommand "fromkey" key (withFilesMissing Command.FromKey.start) + "adds a file using a specific key") + , (SubCommand "dropkey" key (withKeys Command.DropKey.start) + "drops annexed content for specified keys") + , (SubCommand "setkey" key (withTempFile Command.SetKey.start) + "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 diff --git a/Command.hs b/Command.hs new file mode 100644 index 0000000000..3d1e75e5f5 --- /dev/null +++ b/Command.hs @@ -0,0 +1,50 @@ +{- git-annex command types + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command where + +import Types +import Backend + +{- 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 + +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 diff --git a/Command/Add.hs b/Command/Add.hs new file mode 100644 index 0000000000..825c1d8c1e --- /dev/null +++ b/Command/Add.hs @@ -0,0 +1,52 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Add where + +import Control.Monad.State (liftIO) +import System.Posix.Files +import System.Directory + +import Command +import qualified Annex +import Utility +import Locations +import qualified Backend +import LocationLog +import Types +import Core + +{- 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. -} +start :: SubCmdStartBackendFile +start 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 $ perform pair + +perform :: (FilePath, Maybe Backend) -> SubCmdPerform +perform (file, backend) = do + stored <- Backend.storeFileKey file backend + case (stored) of + Nothing -> return Nothing + Just (key, _) -> return $ Just $ cleanup file key + +cleanup :: FilePath -> Key -> SubCmdCleanup +cleanup 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 diff --git a/Command/Drop.hs b/Command/Drop.hs new file mode 100644 index 0000000000..6cdf216f41 --- /dev/null +++ b/Command/Drop.hs @@ -0,0 +1,50 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Drop where + +import Control.Monad.State (liftIO) +import System.Directory + +import Command +import qualified Annex +import Locations +import qualified Backend +import LocationLog +import Types +import Core + +{- Indicates a file's content is not wanted anymore, and should be removed + - if it's safe to do so. -} +start :: SubCmdStartString +start file = isAnnexed file $ \(key, backend) -> do + inbackend <- Backend.hasKey key + if (not inbackend) + then return Nothing + else do + showStart "drop" file + return $ Just $ perform key backend + +perform :: Key -> Backend -> SubCmdPerform +perform key backend = do + success <- Backend.removeKey backend key + if (success) + then return $ Just $ cleanup key + else return Nothing + +cleanup :: Key -> SubCmdCleanup +cleanup 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 + diff --git a/Command/DropKey.hs b/Command/DropKey.hs new file mode 100644 index 0000000000..bdd9b55b12 --- /dev/null +++ b/Command/DropKey.hs @@ -0,0 +1,47 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.DropKey where + +import Control.Monad.State (liftIO) +import System.Directory + +import Command +import qualified Annex +import Locations +import qualified Backend +import LocationLog +import Types +import Core + +{- Drops cached content for a key. -} +start :: SubCmdStartString +start 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 $ perform key + +perform :: Key -> SubCmdPerform +perform key = do + g <- Annex.gitRepo + let loc = annexLocation g key + liftIO $ removeFile loc + return $ Just $ cleanup key + +cleanup :: Key -> SubCmdCleanup +cleanup key = do + logStatus key ValueMissing + return True + diff --git a/Command/Fix.hs b/Command/Fix.hs new file mode 100644 index 0000000000..90257a8a53 --- /dev/null +++ b/Command/Fix.hs @@ -0,0 +1,40 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Fix where + +import Control.Monad.State (liftIO) +import System.Posix.Files +import System.Directory + +import Command +import qualified Annex +import Utility +import Core + +{- Fixes the symlink to an annexed file. -} +start :: SubCmdStartString +start 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 $ perform file link + +perform :: FilePath -> FilePath -> SubCmdPerform +perform file link = do + liftIO $ createDirectoryIfMissing True (parentDir file) + liftIO $ removeFile file + liftIO $ createSymbolicLink link file + return $ Just $ cleanup file + +cleanup :: FilePath -> SubCmdCleanup +cleanup file = do + Annex.queue "add" [] file + return True diff --git a/Command/FromKey.hs b/Command/FromKey.hs new file mode 100644 index 0000000000..3071f218f4 --- /dev/null +++ b/Command/FromKey.hs @@ -0,0 +1,44 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.FromKey where + +import Control.Monad.State (liftIO) +import System.Posix.Files +import System.Directory +import Control.Monad (when, unless) + +import Command +import qualified Annex +import Utility +import qualified Backend +import Types +import Core + +{- Adds a file pointing at a manually-specified key -} +start :: SubCmdStartString +start 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 $ perform file key +perform :: FilePath -> Key -> SubCmdPerform +perform file key = do + link <- calcGitLink file key + liftIO $ createDirectoryIfMissing True (parentDir file) + liftIO $ createSymbolicLink link file + return $ Just $ cleanup file +cleanup :: FilePath -> SubCmdCleanup +cleanup file = do + Annex.queue "add" [] file + return True diff --git a/Command/Get.hs b/Command/Get.hs new file mode 100644 index 0000000000..1433bc8d00 --- /dev/null +++ b/Command/Get.hs @@ -0,0 +1,31 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Get where + +import Command +import qualified Backend +import Types +import Core + +{- Gets an annexed file from one of the backends. -} +start :: SubCmdStartString +start file = isAnnexed file $ \(key, backend) -> do + inannex <- inAnnex key + if (inannex) + then return Nothing + else do + showStart "get" file + return $ Just $ perform key backend + +perform :: Key -> Backend -> SubCmdPerform +perform key backend = do + ok <- getViaTmp key (Backend.retrieveKeyFile backend key) + if (ok) + then return $ Just $ return True -- no cleanup needed + else return Nothing + diff --git a/Command/Init.hs b/Command/Init.hs new file mode 100644 index 0000000000..b1e4e0e066 --- /dev/null +++ b/Command/Init.hs @@ -0,0 +1,42 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Init where + +import Control.Monad.State (liftIO) +import Control.Monad (when) + +import Command +import qualified Annex +import Core +import qualified GitRepo as Git +import UUID + +{- Stores description for the repository etc. -} +start :: SubCmdStartString +start description = do + when (null description) $ error $ + "please specify a description of this repository\n" + showStart "init" description + return $ Just $ perform description + +perform :: String -> SubCmdPerform +perform description = do + g <- Annex.gitRepo + u <- getUUID g + describeUUID u description + liftIO $ gitAttributes g + liftIO $ gitPreCommitHook g + return $ Just $ cleanup + +cleanup :: SubCmdCleanup +cleanup = do + g <- Annex.gitRepo + logfile <- uuidLog + liftIO $ Git.run g ["add", logfile] + liftIO $ Git.run g ["commit", "-m", "git annex init", logfile] + return True diff --git a/Command/Move.hs b/Command/Move.hs new file mode 100644 index 0000000000..cee9416222 --- /dev/null +++ b/Command/Move.hs @@ -0,0 +1,131 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Move where + +import Control.Monad.State (liftIO) +import Monad (when) + +import Command +import Command.Drop +import qualified Annex +import Locations +import LocationLog +import Types +import Core +import qualified GitRepo as Git +import qualified Remotes +import UUID + +{- 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. -} +start :: SubCmdStartString +start 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 $ Command.Drop.cleanup 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. + Command.Drop.cleanup 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 diff --git a/Command/SetKey.hs b/Command/SetKey.hs new file mode 100644 index 0000000000..a5710643ec --- /dev/null +++ b/Command/SetKey.hs @@ -0,0 +1,43 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.SetKey where + +import Control.Monad.State (liftIO) +import Control.Monad (when) + +import Command +import qualified Annex +import Utility +import Locations +import qualified Backend +import LocationLog +import Types +import Core + +{- Sets cached content for a key. -} +start :: SubCmdStartString +start 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 $ perform tmpfile key +perform :: FilePath -> Key -> SubCmdPerform +perform 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 $ cleanup key +cleanup :: Key -> SubCmdCleanup +cleanup key = do + logStatus key ValuePresent + return True + diff --git a/Command/Unannex.hs b/Command/Unannex.hs new file mode 100644 index 0000000000..5cffb2d894 --- /dev/null +++ b/Command/Unannex.hs @@ -0,0 +1,48 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Unannex where + +import Control.Monad.State (liftIO) +import System.Directory + +import Command +import qualified Annex +import Utility +import Locations +import qualified Backend +import LocationLog +import Types +import Core +import qualified GitRepo as Git + +{- The unannex subcommand undoes an add. -} +start :: SubCmdStartString +start file = isAnnexed file $ \(key, backend) -> do + showStart "unannex" file + return $ Just $ perform file key backend + +perform :: FilePath -> Key -> Backend -> SubCmdPerform +perform file key backend = do + -- force backend to always remove + Annex.flagChange "force" $ FlagBool True + ok <- Backend.removeKey backend key + if (ok) + then return $ Just $ cleanup file key + else return Nothing + +cleanup :: FilePath -> Key -> SubCmdCleanup +cleanup 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 diff --git a/Commands.hs b/Commands.hs deleted file mode 100644 index 330b71ed27..0000000000 --- a/Commands.hs +++ /dev/null @@ -1,555 +0,0 @@ -{- git-annex command line - - - - Copyright 2010 Joey Hess - - - - 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 diff --git a/git-annex.hs b/git-annex.hs index 370c22a1ef..098ccac2d4 100644 --- a/git-annex.hs +++ b/git-annex.hs @@ -9,7 +9,7 @@ import System.Environment import qualified Annex import Core -import Commands +import CmdLine import qualified GitRepo as Git import BackendList