355 lines
11 KiB
Haskell
355 lines
11 KiB
Haskell
{- git-annex command line -}
|
|
|
|
module Commands (parseCmd) where
|
|
|
|
import System.Console.GetOpt
|
|
import Control.Monad.State (liftIO)
|
|
import System.Posix.Files
|
|
import System.Directory
|
|
import System.Path
|
|
import Data.String.Utils
|
|
import Control.Monad (filterM)
|
|
import List
|
|
import IO
|
|
|
|
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
|
|
import qualified TypeInternals
|
|
|
|
data CmdWants = FilesInGit | FilesNotInGit | FilesMissing | Description
|
|
data Command = Command {
|
|
cmdname :: String,
|
|
cmdaction :: (String -> Annex ()),
|
|
cmdwants :: CmdWants,
|
|
cmddesc :: String
|
|
}
|
|
|
|
cmds :: [Command]
|
|
cmds = [
|
|
(Command "add" addCmd FilesNotInGit
|
|
"add files to annex")
|
|
, (Command "get" getCmd FilesInGit
|
|
"make content of annexed files available")
|
|
, (Command "drop" dropCmd FilesInGit
|
|
"indicate content of files not currently wanted")
|
|
, (Command "move" moveCmd FilesInGit
|
|
"transfer content of files to/from another repository")
|
|
, (Command "init" initCmd Description
|
|
"initialize git-annex with repository description")
|
|
, (Command "unannex" unannexCmd FilesInGit
|
|
"undo accidential add command")
|
|
, (Command "fix" fixCmd FilesInGit
|
|
"fix up files' symlinks to point to annexed content")
|
|
, (Command "fromkey" fromKeyCmd FilesMissing
|
|
"adds a file using a specific key")
|
|
]
|
|
|
|
-- 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 ['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 = "Usage: git-annex " ++ (join "|" $ map cmdname cmds)
|
|
|
|
usage :: String
|
|
usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs
|
|
where
|
|
cmddescs = unlines $ map (\c -> indent $ showcmd c) cmds
|
|
showcmd c =
|
|
(cmdname c) ++
|
|
(pad 10 (cmdname c)) ++
|
|
(descWanted (cmdwants c)) ++
|
|
(pad 13 (descWanted (cmdwants c))) ++
|
|
(cmddesc c)
|
|
indent l = " " ++ l
|
|
pad n s = take (n - (length s)) $ repeat ' '
|
|
|
|
{- Generate descrioptions of wanted parameters for subcommands. -}
|
|
descWanted :: CmdWants -> String
|
|
descWanted Description = "DESCRIPTION"
|
|
descWanted _ = "PATH ..."
|
|
|
|
{- Finds the type of parameters a command wants, from among the passed
|
|
- parameter list. -}
|
|
findWanted :: CmdWants -> [String] -> Git.Repo -> IO [String]
|
|
findWanted FilesNotInGit params repo = do
|
|
files <- mapM (Git.notInRepo repo) params
|
|
return $ foldl (++) [] files
|
|
findWanted FilesInGit params repo = do
|
|
files <- mapM (Git.inRepo repo) params
|
|
return $ foldl (++) [] files
|
|
findWanted FilesMissing params repo = do
|
|
files <- liftIO $ filterM missing params
|
|
return $ files
|
|
where
|
|
missing f = do
|
|
e <- doesFileExist f
|
|
if (e) then return False else return True
|
|
findWanted Description params _ = do
|
|
return $ [unwords params]
|
|
|
|
{- 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 ()], [Annex ()])
|
|
parseCmd argv state = do
|
|
(flags, params) <- getopt
|
|
if (null params)
|
|
then error usage
|
|
else case (lookupCmd (params !! 0)) of
|
|
[] -> error usage
|
|
[Command _ action want _] -> do
|
|
f <- findWanted want (drop 1 params)
|
|
(TypeInternals.repo state)
|
|
return (flags, map action $ filter notstate f)
|
|
where
|
|
-- never include files from the state directory
|
|
notstate f = stateLoc /= take (length stateLoc) f
|
|
getopt = case getOpt Permute options argv of
|
|
(flags, params, []) -> return (flags, params)
|
|
(_, _, errs) -> ioError (userError (concat errs ++ usage))
|
|
lookupCmd cmd = filter (\c -> cmd == cmdname c) cmds
|
|
|
|
{- 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. -}
|
|
addCmd :: FilePath -> Annex ()
|
|
addCmd file = notAnnexed file $ do
|
|
s <- liftIO $ getSymbolicLinkStatus file
|
|
if ((isSymbolicLink s) || (not $ isRegularFile s))
|
|
then return ()
|
|
else do
|
|
showStart "add" file
|
|
g <- Annex.gitRepo
|
|
stored <- Backend.storeFileKey file
|
|
case (stored) of
|
|
Nothing -> showEndFail
|
|
Just (key, backend) -> do
|
|
logStatus key ValuePresent
|
|
setup g key
|
|
where
|
|
setup g key = do
|
|
let dest = annexLocation g key
|
|
liftIO $ createDirectoryIfMissing True (parentDir dest)
|
|
liftIO $ renameFile file dest
|
|
link <- calcGitLink file key
|
|
liftIO $ createSymbolicLink link file
|
|
liftIO $ Git.run g ["add", file]
|
|
showEndOk
|
|
|
|
{- Undo addCmd. -}
|
|
unannexCmd :: FilePath -> Annex ()
|
|
unannexCmd file = isAnnexed file $ \(key, backend) -> do
|
|
showStart "unannex" file
|
|
Annex.flagChange "force" $ FlagBool True -- force backend to always remove
|
|
Backend.removeKey backend key
|
|
logStatus key ValueMissing
|
|
g <- Annex.gitRepo
|
|
let src = annexLocation g key
|
|
moveout g src
|
|
where
|
|
moveout g src = do
|
|
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
|
|
showEndOk
|
|
|
|
{- Gets an annexed file from one of the backends. -}
|
|
getCmd :: FilePath -> Annex ()
|
|
getCmd file = isAnnexed file $ \(key, backend) -> do
|
|
inannex <- inAnnex key
|
|
if (inannex)
|
|
then return ()
|
|
else do
|
|
showStart "get" file
|
|
getViaTmp key (Backend.retrieveKeyFile backend key)
|
|
|
|
{- Indicates a file's content is not wanted anymore, and should be removed
|
|
- if it's safe to do so. -}
|
|
dropCmd :: FilePath -> Annex ()
|
|
dropCmd file = isAnnexed file $ \(key, backend) -> do
|
|
inbackend <- Backend.hasKey key
|
|
if (not inbackend)
|
|
then return () -- no-op
|
|
else do
|
|
showStart "drop" file
|
|
success <- Backend.removeKey backend key
|
|
if (success)
|
|
then do
|
|
cleanup key
|
|
showEndOk
|
|
else showEndFail
|
|
where
|
|
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 ()
|
|
else return ()
|
|
|
|
{- Fixes the symlink to an annexed file. -}
|
|
fixCmd :: FilePath -> Annex ()
|
|
fixCmd file = isAnnexed file $ \(key, backend) -> do
|
|
link <- calcGitLink file key
|
|
l <- liftIO $ readSymbolicLink file
|
|
if (link == l)
|
|
then return ()
|
|
else do
|
|
showStart "fix" file
|
|
liftIO $ createDirectoryIfMissing True (parentDir file)
|
|
liftIO $ removeFile file
|
|
liftIO $ createSymbolicLink link file
|
|
g <- Annex.gitRepo
|
|
liftIO $ Git.run g ["add", file]
|
|
showEndOk
|
|
|
|
{- Stores description for the repository. -}
|
|
initCmd :: String -> Annex ()
|
|
initCmd description = do
|
|
if (null description)
|
|
then error $
|
|
"please specify a description of this repository\n" ++
|
|
usage
|
|
else do
|
|
g <- Annex.gitRepo
|
|
u <- getUUID g
|
|
describeUUID u description
|
|
log <- uuidLog
|
|
liftIO $ Git.run g ["add", log]
|
|
liftIO $ Git.run g ["commit", "-m", "git annex init", log]
|
|
liftIO $ putStrLn "description set"
|
|
|
|
{- Adds a file pointing at a manually-specified key -}
|
|
fromKeyCmd :: FilePath -> Annex ()
|
|
fromKeyCmd file = do
|
|
keyname <- Annex.flagGet "key"
|
|
if (null keyname)
|
|
then error "please specify the key with --key"
|
|
else return ()
|
|
backends <- Backend.list
|
|
let key = genKey (backends !! 0) keyname
|
|
|
|
inbackend <- Backend.hasKey key
|
|
if (not inbackend)
|
|
then error $ "key ("++keyname++") is not present in backend"
|
|
else return ()
|
|
|
|
link <- calcGitLink file key
|
|
showStart "fromkey" file
|
|
liftIO $ createDirectoryIfMissing True (parentDir file)
|
|
liftIO $ createSymbolicLink link file
|
|
g <- Annex.gitRepo
|
|
liftIO $ Git.run g ["add", file]
|
|
showEndOk
|
|
|
|
{- 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.
|
|
-
|
|
- 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.
|
|
-}
|
|
moveCmd :: FilePath -> Annex ()
|
|
moveCmd file = do
|
|
fromName <- Annex.flagGet "fromrepository"
|
|
toName <- Annex.flagGet "torepository"
|
|
case (fromName, toName) of
|
|
("", "") -> error "specify either --from or --to"
|
|
("", to) -> moveTo file
|
|
(from, "") -> moveFrom 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.
|
|
-}
|
|
moveTo :: FilePath -> Annex ()
|
|
moveTo file = isAnnexed file $ \(key, backend) -> do
|
|
ishere <- inAnnex key
|
|
if (not ishere)
|
|
then return () -- not here, so nothing to do
|
|
else do
|
|
showStart "move" file
|
|
remote <- Remotes.commandLineRemote
|
|
isthere <- Remotes.inAnnex remote key
|
|
case isthere of
|
|
Left err -> error (show err)
|
|
Right False -> moveit remote key
|
|
Right True -> removeit remote key
|
|
where
|
|
moveit remote key = do
|
|
Remotes.copyToRemote remote key
|
|
removeit remote key
|
|
removeit remote key = do
|
|
error $ "TODO remove" ++ file
|
|
|
|
{- 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.
|
|
-}
|
|
moveFrom :: FilePath -> Annex ()
|
|
moveFrom file = isAnnexed file $ \(key, backend) -> do
|
|
showStart "move" file -- have to show this before checking remote
|
|
ishere <- inAnnex key
|
|
remote <- Remotes.commandLineRemote
|
|
isthere <- Remotes.inAnnex remote key
|
|
case (ishere, isthere) of
|
|
(_, Left err) -> error (show err)
|
|
(_, Right False) -> showEndFail
|
|
(False, Right True) -> moveit remote key
|
|
(True, Right True) -> removeit remote key
|
|
where
|
|
moveit remote key = do
|
|
getViaTmp key (Remotes.copyFromRemote remote key)
|
|
removeit remote key
|
|
removeit remote key = do
|
|
error $ "TODO remove" ++ file
|
|
showEndOk
|
|
|
|
-- helpers
|
|
notAnnexed file a = do
|
|
r <- Backend.lookupFile file
|
|
case (r) of
|
|
Just v -> return ()
|
|
Nothing -> a
|
|
isAnnexed file a = do
|
|
r <- Backend.lookupFile file
|
|
case (r) of
|
|
Just v -> a v
|
|
Nothing -> return ()
|