rename some stuff and prepare to break out more into Command/*
This commit is contained in:
parent
14d59b40fb
commit
6a5be9d53c
24 changed files with 176 additions and 158 deletions
4
Annex.hs
4
Annex.hs
|
@ -110,10 +110,10 @@ flagGet name = do
|
|||
|
||||
{- Adds a git command to the queue. -}
|
||||
queue :: String -> [String] -> FilePath -> Annex ()
|
||||
queue subcommand params file = do
|
||||
queue command params file = do
|
||||
state <- get
|
||||
let q = Internals.repoqueue state
|
||||
put state { Internals.repoqueue = GitQueue.add q subcommand params file }
|
||||
put state { Internals.repoqueue = GitQueue.add q command params file }
|
||||
|
||||
{- Returns the queue. -}
|
||||
queueGet :: Annex GitQueue.Queue
|
||||
|
|
69
CmdLine.hs
69
CmdLine.hs
|
@ -37,51 +37,50 @@ import qualified Command.Uninit
|
|||
import qualified Command.Trust
|
||||
import qualified Command.Untrust
|
||||
|
||||
subCmds :: [SubCommand]
|
||||
subCmds =
|
||||
[ SubCommand "add" path Command.Add.seek
|
||||
"add files to annex"
|
||||
, SubCommand "get" path Command.Get.seek
|
||||
cmds :: [Command]
|
||||
cmds =
|
||||
[ Command.Add.command
|
||||
, Command "get" path Command.Get.seek
|
||||
"make content of annexed files available"
|
||||
, SubCommand "drop" path Command.Drop.seek
|
||||
, Command "drop" path Command.Drop.seek
|
||||
"indicate content of files not currently wanted"
|
||||
, SubCommand "move" path Command.Move.seek
|
||||
, Command "move" path Command.Move.seek
|
||||
"move content of files to/from another repository"
|
||||
, SubCommand "copy" path Command.Copy.seek
|
||||
, Command "copy" path Command.Copy.seek
|
||||
"copy content of files to/from another repository"
|
||||
, SubCommand "unlock" path Command.Unlock.seek
|
||||
, Command "unlock" path Command.Unlock.seek
|
||||
"unlock files for modification"
|
||||
, SubCommand "edit" path Command.Unlock.seek
|
||||
, Command "edit" path Command.Unlock.seek
|
||||
"same as unlock"
|
||||
, SubCommand "lock" path Command.Lock.seek
|
||||
, Command "lock" path Command.Lock.seek
|
||||
"undo unlock command"
|
||||
, SubCommand "init" desc Command.Init.seek
|
||||
, Command "init" desc Command.Init.seek
|
||||
"initialize git-annex with repository description"
|
||||
, SubCommand "unannex" path Command.Unannex.seek
|
||||
, Command "unannex" path Command.Unannex.seek
|
||||
"undo accidential add command"
|
||||
, SubCommand "uninit" path Command.Uninit.seek
|
||||
, Command "uninit" path Command.Uninit.seek
|
||||
"de-initialize git-annex and clean out repository"
|
||||
, SubCommand "pre-commit" path Command.PreCommit.seek
|
||||
, Command "pre-commit" path Command.PreCommit.seek
|
||||
"run by git pre-commit hook"
|
||||
, SubCommand "trust" remote Command.Trust.seek
|
||||
, Command "trust" remote Command.Trust.seek
|
||||
"trust a repository"
|
||||
, SubCommand "untrust" remote Command.Untrust.seek
|
||||
, Command "untrust" remote Command.Untrust.seek
|
||||
"do not trust a repository"
|
||||
, SubCommand "fromkey" key Command.FromKey.seek
|
||||
, Command "fromkey" key Command.FromKey.seek
|
||||
"adds a file using a specific key"
|
||||
, SubCommand "dropkey" key Command.DropKey.seek
|
||||
, Command "dropkey" key Command.DropKey.seek
|
||||
"drops annexed content for specified keys"
|
||||
, SubCommand "setkey" key Command.SetKey.seek
|
||||
, Command "setkey" key Command.SetKey.seek
|
||||
"sets annexed content for a key using a temp file"
|
||||
, SubCommand "fix" path Command.Fix.seek
|
||||
, Command "fix" path Command.Fix.seek
|
||||
"fix up symlinks to point to annexed content"
|
||||
, SubCommand "fsck" maybepath Command.Fsck.seek
|
||||
, Command "fsck" maybepath Command.Fsck.seek
|
||||
"check for problems"
|
||||
, SubCommand "unused" nothing Command.Unused.seek
|
||||
, Command "unused" nothing Command.Unused.seek
|
||||
"look for unused file content"
|
||||
, SubCommand "dropunused" number Command.DropUnused.seek
|
||||
, Command "dropunused" number Command.DropUnused.seek
|
||||
"drop unused file content"
|
||||
, SubCommand "find" maybepath Command.Find.seek
|
||||
, Command "find" maybepath Command.Find.seek
|
||||
"lists available files"
|
||||
]
|
||||
where
|
||||
|
@ -125,13 +124,13 @@ header = "Usage: git-annex subcommand [option ..]"
|
|||
usage :: String
|
||||
usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs
|
||||
where
|
||||
cmddescs = unlines $ map (indent . showcmd) subCmds
|
||||
cmddescs = unlines $ map (indent . showcmd) cmds
|
||||
showcmd c =
|
||||
subcmdname c ++
|
||||
pad 11 (subcmdname c) ++
|
||||
subcmdparams c ++
|
||||
pad 13 (subcmdparams c) ++
|
||||
subcmddesc c
|
||||
cmdname c ++
|
||||
pad 11 (cmdname c) ++
|
||||
cmdparams c ++
|
||||
pad 13 (cmdparams c) ++
|
||||
cmddesc c
|
||||
indent l = " " ++ l
|
||||
pad n s = replicate (n - length s) ' '
|
||||
|
||||
|
@ -143,12 +142,12 @@ parseCmd argv = do
|
|||
when (null params) $ error usage
|
||||
case lookupCmd (head params) of
|
||||
[] -> error usage
|
||||
[subcommand] -> do
|
||||
[command] -> do
|
||||
_ <- sequence flags
|
||||
prepSubCmd subcommand (drop 1 params)
|
||||
_ -> error "internal error: multiple matching subcommands"
|
||||
prepCmd command (drop 1 params)
|
||||
_ -> error "internal error: multiple matching commands"
|
||||
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
|
||||
lookupCmd cmd = filter (\c -> cmd == cmdname c) cmds
|
||||
|
|
110
Command.hs
110
Command.hs
|
@ -21,54 +21,54 @@ import qualified Annex
|
|||
import qualified GitRepo as Git
|
||||
import Locations
|
||||
|
||||
{- A subcommand runs in four stages.
|
||||
{- A command runs in four stages.
|
||||
-
|
||||
- 0. The seek stage takes the parameters passed to the subcommand,
|
||||
- 0. The seek stage takes the parameters passed to the command,
|
||||
- looks through the repo to find the ones that are relevant
|
||||
- to that subcommand (ie, new files to add), and generates
|
||||
- to that command (ie, new files to add), and generates
|
||||
- a list of start stage actions. -}
|
||||
type SubCmdSeek = [String] -> Annex [SubCmdStart]
|
||||
type CommandSeek = [String] -> Annex [CommandStart]
|
||||
{- 1. The start stage is run before anything is printed about the
|
||||
- subcommand, is passed some input, and can early abort it
|
||||
- command, 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
|
||||
type CommandStart = Annex (Maybe CommandPerform)
|
||||
{- 2. The perform stage is run after a message is printed about the command
|
||||
- being run, and it should be where the bulk of the work happens. -}
|
||||
type SubCmdPerform = Annex (Maybe SubCmdCleanup)
|
||||
type CommandPerform = Annex (Maybe CommandCleanup)
|
||||
{- 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
|
||||
- returns the overall success/fail of the command. -}
|
||||
type CommandCleanup = Annex Bool
|
||||
{- Some helper functions are used to build up CommandSeek and CommandStart
|
||||
- functions. -}
|
||||
type SubCmdSeekStrings = SubCmdStartString -> SubCmdSeek
|
||||
type SubCmdStartString = String -> SubCmdStart
|
||||
type CommandSeekStrings = CommandStartString -> CommandSeek
|
||||
type CommandStartString = String -> CommandStart
|
||||
type BackendFile = (FilePath, Maybe Backend)
|
||||
type SubCmdSeekBackendFiles = SubCmdStartBackendFile -> SubCmdSeek
|
||||
type SubCmdStartBackendFile = BackendFile -> SubCmdStart
|
||||
type CommandSeekBackendFiles = CommandStartBackendFile -> CommandSeek
|
||||
type CommandStartBackendFile = BackendFile -> CommandStart
|
||||
type AttrFile = (FilePath, String)
|
||||
type SubCmdSeekAttrFiles = SubCmdStartAttrFile -> SubCmdSeek
|
||||
type SubCmdStartAttrFile = AttrFile -> SubCmdStart
|
||||
type SubCmdSeekNothing = SubCmdStart -> SubCmdSeek
|
||||
type SubCmdStartNothing = SubCmdStart
|
||||
type CommandSeekAttrFiles = CommandStartAttrFile -> CommandSeek
|
||||
type CommandStartAttrFile = AttrFile -> CommandStart
|
||||
type CommandSeekNothing = CommandStart -> CommandSeek
|
||||
type CommandStartNothing = CommandStart
|
||||
|
||||
data SubCommand = SubCommand {
|
||||
subcmdname :: String,
|
||||
subcmdparams :: String,
|
||||
subcmdseek :: [SubCmdSeek],
|
||||
subcmddesc :: String
|
||||
data Command = Command {
|
||||
cmdname :: String,
|
||||
cmdparams :: String,
|
||||
cmdseek :: [CommandSeek],
|
||||
cmddesc :: String
|
||||
}
|
||||
|
||||
{- Prepares a list of actions to run to perform a subcommand, based on
|
||||
{- Prepares a list of actions to run to perform a command, based on
|
||||
- the parameters passed to it. -}
|
||||
prepSubCmd :: SubCommand -> [String] -> Annex [Annex Bool]
|
||||
prepSubCmd SubCommand { subcmdseek = seek } params = do
|
||||
prepCmd :: Command -> [String] -> Annex [Annex Bool]
|
||||
prepCmd Command { cmdseek = seek } params = do
|
||||
lists <- mapM (\s -> s params) seek
|
||||
return $ map doSubCmd $ foldl (++) [] lists
|
||||
return $ map doCommand $ foldl (++) [] lists
|
||||
|
||||
{- Runs a subcommand through the start, perform and cleanup stages -}
|
||||
doSubCmd :: SubCmdStart -> SubCmdCleanup
|
||||
doSubCmd start = do
|
||||
{- Runs a command through the start, perform and cleanup stages -}
|
||||
doCommand :: CommandStart -> CommandCleanup
|
||||
doCommand start = do
|
||||
s <- start
|
||||
case s of
|
||||
Nothing -> return True
|
||||
|
@ -104,20 +104,20 @@ isAnnexed file a = do
|
|||
|
||||
{- These functions find appropriate files or other things based on a
|
||||
user's parameters, and run a specified action on them. -}
|
||||
withFilesInGit :: SubCmdSeekStrings
|
||||
withFilesInGit :: CommandSeekStrings
|
||||
withFilesInGit a params = do
|
||||
repo <- Annex.gitRepo
|
||||
files <- liftIO $ Git.inRepo repo params
|
||||
files' <- filterFiles files
|
||||
return $ map a files'
|
||||
withAttrFilesInGit :: String -> SubCmdSeekAttrFiles
|
||||
withAttrFilesInGit :: String -> CommandSeekAttrFiles
|
||||
withAttrFilesInGit attr a params = do
|
||||
repo <- Annex.gitRepo
|
||||
files <- liftIO $ Git.inRepo repo params
|
||||
files' <- filterFiles files
|
||||
pairs <- liftIO $ Git.checkAttr repo attr files'
|
||||
return $ map a pairs
|
||||
withFilesMissing :: SubCmdSeekStrings
|
||||
withFilesMissing :: CommandSeekStrings
|
||||
withFilesMissing a params = do
|
||||
files <- liftIO $ filterM missing params
|
||||
files' <- filterFiles files
|
||||
|
@ -126,27 +126,27 @@ withFilesMissing a params = do
|
|||
missing f = do
|
||||
e <- doesFileExist f
|
||||
return $ not e
|
||||
withFilesNotInGit :: SubCmdSeekBackendFiles
|
||||
withFilesNotInGit :: CommandSeekBackendFiles
|
||||
withFilesNotInGit a params = do
|
||||
repo <- Annex.gitRepo
|
||||
newfiles <- liftIO $ Git.notInRepo repo params
|
||||
newfiles' <- filterFiles newfiles
|
||||
backendPairs a newfiles'
|
||||
withString :: SubCmdSeekStrings
|
||||
withString :: CommandSeekStrings
|
||||
withString a params = return [a $ unwords params]
|
||||
withStrings :: SubCmdSeekStrings
|
||||
withStrings :: CommandSeekStrings
|
||||
withStrings a params = return $ map a params
|
||||
withFilesToBeCommitted :: SubCmdSeekStrings
|
||||
withFilesToBeCommitted :: CommandSeekStrings
|
||||
withFilesToBeCommitted a params = do
|
||||
repo <- Annex.gitRepo
|
||||
tocommit <- liftIO $ Git.stagedFiles repo params
|
||||
tocommit' <- filterFiles tocommit
|
||||
return $ map a tocommit'
|
||||
withFilesUnlocked :: SubCmdSeekBackendFiles
|
||||
withFilesUnlocked :: CommandSeekBackendFiles
|
||||
withFilesUnlocked = withFilesUnlocked' Git.typeChangedFiles
|
||||
withFilesUnlockedToBeCommitted :: SubCmdSeekBackendFiles
|
||||
withFilesUnlockedToBeCommitted :: CommandSeekBackendFiles
|
||||
withFilesUnlockedToBeCommitted = withFilesUnlocked' Git.typeChangedStagedFiles
|
||||
withFilesUnlocked' :: (Git.Repo -> [FilePath] -> IO [FilePath]) -> SubCmdSeekBackendFiles
|
||||
withFilesUnlocked' :: (Git.Repo -> [FilePath] -> IO [FilePath]) -> CommandSeekBackendFiles
|
||||
withFilesUnlocked' typechanged a params = do
|
||||
-- unlocked files have changed type from a symlink to a regular file
|
||||
repo <- Annex.gitRepo
|
||||
|
@ -155,29 +155,29 @@ withFilesUnlocked' typechanged a params = do
|
|||
map (\f -> Git.workTree repo ++ "/" ++ f) typechangedfiles
|
||||
unlockedfiles' <- filterFiles unlockedfiles
|
||||
backendPairs a unlockedfiles'
|
||||
withKeys :: SubCmdSeekStrings
|
||||
withKeys :: CommandSeekStrings
|
||||
withKeys a params = return $ map a params
|
||||
withTempFile :: SubCmdSeekStrings
|
||||
withTempFile :: CommandSeekStrings
|
||||
withTempFile a params = return $ map a params
|
||||
withNothing :: SubCmdSeekNothing
|
||||
withNothing :: CommandSeekNothing
|
||||
withNothing a [] = return [a]
|
||||
withNothing _ _ = return []
|
||||
|
||||
backendPairs :: SubCmdSeekBackendFiles
|
||||
backendPairs :: CommandSeekBackendFiles
|
||||
backendPairs a files = do
|
||||
pairs <- Backend.chooseBackends files
|
||||
return $ map a pairs
|
||||
|
||||
{- Default to acting on all files matching the seek action if
|
||||
- none are specified. -}
|
||||
withAll :: (a -> SubCmdSeek) -> a -> SubCmdSeek
|
||||
withAll :: (a -> CommandSeek) -> a -> CommandSeek
|
||||
withAll w a [] = do
|
||||
g <- Annex.gitRepo
|
||||
w a [Git.workTree g]
|
||||
withAll w a p = w a p
|
||||
|
||||
{- Provides a default parameter to act on if none is specified. -}
|
||||
withDefault :: String-> (a -> SubCmdSeek) -> (a -> SubCmdSeek)
|
||||
withDefault :: String-> (a -> CommandSeek) -> (a -> CommandSeek)
|
||||
withDefault d w a [] = w a [d]
|
||||
withDefault _ w a p = w a p
|
||||
|
||||
|
@ -204,3 +204,19 @@ notSymlink :: FilePath -> IO Bool
|
|||
notSymlink f = do
|
||||
s <- liftIO $ getSymbolicLinkStatus f
|
||||
return $ not $ isSymbolicLink s
|
||||
|
||||
{- descriptions of params used in usage message -}
|
||||
paramPath :: String
|
||||
paramPath = "PATH ..."
|
||||
paramMaybePath :: String
|
||||
paramMaybePath = "[PATH ...]"
|
||||
paramKey :: String
|
||||
paramKey = "KEY ..."
|
||||
paramDesc :: String
|
||||
paramDesc = "DESCRIPTION"
|
||||
paramNumber :: String
|
||||
paramNumber = "NUMBER ..."
|
||||
paramRemote :: String
|
||||
paramRemote = "REMOTE ..."
|
||||
paramNothing :: String
|
||||
paramNothing = ""
|
||||
|
|
|
@ -18,14 +18,17 @@ import Types
|
|||
import Core
|
||||
import Messages
|
||||
|
||||
command :: Command
|
||||
command = Command "add" paramPath seek "add files to annex"
|
||||
|
||||
{- Add acts on both files not checked into git yet, and unlocked files. -}
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withFilesNotInGit start, withFilesUnlocked start]
|
||||
|
||||
{- 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 :: CommandStartBackendFile
|
||||
start pair@(file, _) = notAnnexed file $ do
|
||||
s <- liftIO $ getSymbolicLinkStatus file
|
||||
if (isSymbolicLink s) || (not $ isRegularFile s)
|
||||
|
@ -34,14 +37,14 @@ start pair@(file, _) = notAnnexed file $ do
|
|||
showStart "add" file
|
||||
return $ Just $ perform pair
|
||||
|
||||
perform :: BackendFile -> SubCmdPerform
|
||||
perform :: BackendFile -> CommandPerform
|
||||
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 :: FilePath -> Key -> CommandCleanup
|
||||
cleanup file key = do
|
||||
moveAnnex key file
|
||||
logStatus key ValuePresent
|
||||
|
|
|
@ -11,5 +11,5 @@ import Command
|
|||
import qualified Command.Move
|
||||
|
||||
-- A copy is just a move that does not delete the source file.
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withFilesInGit $ Command.Move.start False]
|
||||
|
|
|
@ -17,12 +17,12 @@ import Core
|
|||
import Messages
|
||||
import Utility
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withAttrFilesInGit "annex.numcopies" start]
|
||||
|
||||
{- Indicates a file's content is not wanted anymore, and should be removed
|
||||
- if it's safe to do so. -}
|
||||
start :: SubCmdStartAttrFile
|
||||
start :: CommandStartAttrFile
|
||||
start (file, attr) = isAnnexed file $ \(key, backend) -> do
|
||||
inbackend <- Backend.hasKey key
|
||||
if not inbackend
|
||||
|
@ -33,14 +33,14 @@ start (file, attr) = isAnnexed file $ \(key, backend) -> do
|
|||
where
|
||||
numcopies = readMaybe attr :: Maybe Int
|
||||
|
||||
perform :: Key -> Backend -> Maybe Int -> SubCmdPerform
|
||||
perform :: Key -> Backend -> Maybe Int -> CommandPerform
|
||||
perform key backend numcopies = do
|
||||
success <- Backend.removeKey backend key numcopies
|
||||
if success
|
||||
then return $ Just $ cleanup key
|
||||
else return Nothing
|
||||
|
||||
cleanup :: Key -> SubCmdCleanup
|
||||
cleanup :: Key -> CommandCleanup
|
||||
cleanup key = do
|
||||
inannex <- inAnnex key
|
||||
when inannex $ removeAnnex key
|
||||
|
|
|
@ -15,11 +15,11 @@ import Types
|
|||
import Core
|
||||
import Messages
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withKeys start]
|
||||
|
||||
{- Drops cached content for a key. -}
|
||||
start :: SubCmdStartString
|
||||
start :: CommandStartString
|
||||
start keyname = do
|
||||
backends <- Backend.list
|
||||
let key = genKey (head backends) keyname
|
||||
|
@ -33,12 +33,12 @@ start keyname = do
|
|||
showStart "dropkey" keyname
|
||||
return $ Just $ perform key
|
||||
|
||||
perform :: Key -> SubCmdPerform
|
||||
perform :: Key -> CommandPerform
|
||||
perform key = do
|
||||
removeAnnex key
|
||||
return $ Just $ cleanup key
|
||||
|
||||
cleanup :: Key -> SubCmdCleanup
|
||||
cleanup :: Key -> CommandCleanup
|
||||
cleanup key = do
|
||||
logStatus key ValueMissing
|
||||
return True
|
||||
|
|
|
@ -18,11 +18,11 @@ import qualified Annex
|
|||
import qualified Command.Drop
|
||||
import Backend
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withStrings start]
|
||||
|
||||
{- Drops unused content by number. -}
|
||||
start :: SubCmdStartString
|
||||
start :: CommandStartString
|
||||
start s = do
|
||||
m <- readUnusedLog
|
||||
case M.lookup s m of
|
||||
|
|
|
@ -13,11 +13,11 @@ import Control.Monad.State (liftIO)
|
|||
import Command
|
||||
import Core
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withDefault "." withFilesInGit start]
|
||||
|
||||
{- Output a list of files. -}
|
||||
start :: SubCmdStartString
|
||||
start :: CommandStartString
|
||||
start file = isAnnexed file $ \(key, _) -> do
|
||||
exists <- inAnnex key
|
||||
when exists $ liftIO $ putStrLn file
|
||||
|
|
|
@ -17,11 +17,11 @@ import Utility
|
|||
import Core
|
||||
import Messages
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withFilesInGit start]
|
||||
|
||||
{- Fixes the symlink to an annexed file. -}
|
||||
start :: SubCmdStartString
|
||||
start :: CommandStartString
|
||||
start file = isAnnexed file $ \(key, _) -> do
|
||||
link <- calcGitLink file key
|
||||
l <- liftIO $ readSymbolicLink file
|
||||
|
@ -31,14 +31,14 @@ start file = isAnnexed file $ \(key, _) -> do
|
|||
showStart "fix" file
|
||||
return $ Just $ perform file link
|
||||
|
||||
perform :: FilePath -> FilePath -> SubCmdPerform
|
||||
perform :: FilePath -> FilePath -> CommandPerform
|
||||
perform file link = do
|
||||
liftIO $ createDirectoryIfMissing True (parentDir file)
|
||||
liftIO $ removeFile file
|
||||
liftIO $ createSymbolicLink link file
|
||||
return $ Just $ cleanup file
|
||||
|
||||
cleanup :: FilePath -> SubCmdCleanup
|
||||
cleanup :: FilePath -> CommandCleanup
|
||||
cleanup file = do
|
||||
Annex.queue "add" ["--"] file
|
||||
return True
|
||||
|
|
|
@ -20,11 +20,11 @@ import Types
|
|||
import Core
|
||||
import Messages
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withFilesMissing start]
|
||||
|
||||
{- Adds a file pointing at a manually-specified key -}
|
||||
start :: SubCmdStartString
|
||||
start :: CommandStartString
|
||||
start file = do
|
||||
keyname <- Annex.flagGet "key"
|
||||
when (null keyname) $ error "please specify the key with --key"
|
||||
|
@ -36,13 +36,13 @@ start file = do
|
|||
"key ("++keyname++") is not present in backend"
|
||||
showStart "fromkey" file
|
||||
return $ Just $ perform file key
|
||||
perform :: FilePath -> Key -> SubCmdPerform
|
||||
perform :: FilePath -> Key -> CommandPerform
|
||||
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 :: FilePath -> CommandCleanup
|
||||
cleanup file = do
|
||||
Annex.queue "add" ["--"] file
|
||||
return True
|
||||
|
|
|
@ -13,18 +13,18 @@ import Types
|
|||
import Messages
|
||||
import Utility
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withAll (withAttrFilesInGit "annex.numcopies") start]
|
||||
|
||||
{- Checks a file's backend data for problems. -}
|
||||
start :: SubCmdStartAttrFile
|
||||
start :: CommandStartAttrFile
|
||||
start (file, attr) = isAnnexed file $ \(key, backend) -> do
|
||||
showStart "fsck" file
|
||||
return $ Just $ perform key backend numcopies
|
||||
where
|
||||
numcopies = readMaybe attr :: Maybe Int
|
||||
|
||||
perform :: Key -> Backend -> Maybe Int -> SubCmdPerform
|
||||
perform :: Key -> Backend -> Maybe Int -> CommandPerform
|
||||
perform key backend numcopies = do
|
||||
success <- Backend.fsckKey backend key numcopies
|
||||
if success
|
||||
|
|
|
@ -13,11 +13,11 @@ import Types
|
|||
import Core
|
||||
import Messages
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withFilesInGit start]
|
||||
|
||||
{- Gets an annexed file from one of the backends. -}
|
||||
start :: SubCmdStartString
|
||||
start :: CommandStartString
|
||||
start file = isAnnexed file $ \(key, backend) -> do
|
||||
inannex <- inAnnex key
|
||||
if inannex
|
||||
|
@ -26,7 +26,7 @@ start file = isAnnexed file $ \(key, backend) -> do
|
|||
showStart "get" file
|
||||
return $ Just $ perform key backend
|
||||
|
||||
perform :: Key -> Backend -> SubCmdPerform
|
||||
perform :: Key -> Backend -> CommandPerform
|
||||
perform key backend = do
|
||||
ok <- getViaTmp key (Backend.retrieveKeyFile backend key)
|
||||
if ok
|
||||
|
|
|
@ -20,18 +20,18 @@ import Messages
|
|||
import Locations
|
||||
import Types
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withString start]
|
||||
|
||||
{- Stores description for the repository etc. -}
|
||||
start :: SubCmdStartString
|
||||
start :: CommandStartString
|
||||
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 :: String -> CommandPerform
|
||||
perform description = do
|
||||
g <- Annex.gitRepo
|
||||
u <- getUUID g
|
||||
|
@ -41,7 +41,7 @@ perform description = do
|
|||
gitPreCommitHookWrite g
|
||||
return $ Just cleanup
|
||||
|
||||
cleanup :: SubCmdCleanup
|
||||
cleanup :: CommandCleanup
|
||||
cleanup = do
|
||||
g <- Annex.gitRepo
|
||||
logfile <- uuidLog
|
||||
|
|
|
@ -15,16 +15,16 @@ import Messages
|
|||
import qualified Annex
|
||||
import qualified GitRepo as Git
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withFilesUnlocked start]
|
||||
|
||||
{- Undo unlock -}
|
||||
start :: SubCmdStartBackendFile
|
||||
start :: CommandStartBackendFile
|
||||
start (file, _) = do
|
||||
showStart "lock" file
|
||||
return $ Just $ perform file
|
||||
|
||||
perform :: FilePath -> SubCmdPerform
|
||||
perform :: FilePath -> CommandPerform
|
||||
perform file = do
|
||||
liftIO $ removeFile file
|
||||
g <- Annex.gitRepo
|
||||
|
|
|
@ -21,14 +21,14 @@ import qualified Remotes
|
|||
import UUID
|
||||
import Messages
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withFilesInGit $ start True]
|
||||
|
||||
{- Move (or copy) 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 :: Bool -> SubCmdStartString
|
||||
start :: Bool -> CommandStartString
|
||||
start move file = do
|
||||
fromName <- Annex.flagGet "fromrepository"
|
||||
toName <- Annex.flagGet "torepository"
|
||||
|
@ -61,7 +61,7 @@ remoteHasKey remote key present = do
|
|||
- A file's content can be moved even if there are insufficient copies to
|
||||
- allow it to be dropped.
|
||||
-}
|
||||
toStart :: Bool -> SubCmdStartString
|
||||
toStart :: Bool -> CommandStartString
|
||||
toStart move file = isAnnexed file $ \(key, _) -> do
|
||||
ishere <- inAnnex key
|
||||
if not ishere
|
||||
|
@ -69,7 +69,7 @@ toStart move file = isAnnexed file $ \(key, _) -> do
|
|||
else do
|
||||
showAction move file
|
||||
return $ Just $ toPerform move key
|
||||
toPerform :: Bool -> Key -> SubCmdPerform
|
||||
toPerform :: Bool -> Key -> CommandPerform
|
||||
toPerform move key = do
|
||||
-- checking the remote is expensive, so not done in the start step
|
||||
remote <- Remotes.commandLineRemote
|
||||
|
@ -86,7 +86,7 @@ toPerform move key = do
|
|||
then return $ Just $ toCleanup move remote key tmpfile
|
||||
else return Nothing -- failed
|
||||
Right True -> return $ Just $ Command.Drop.cleanup key
|
||||
toCleanup :: Bool -> Git.Repo -> Key -> FilePath -> SubCmdCleanup
|
||||
toCleanup :: Bool -> Git.Repo -> Key -> FilePath -> CommandCleanup
|
||||
toCleanup move remote key tmpfile = do
|
||||
-- Tell remote to use the transferred content.
|
||||
ok <- Remotes.runCmd remote "git-annex" ["setkey", "--quiet",
|
||||
|
@ -107,7 +107,7 @@ toCleanup move remote key tmpfile = do
|
|||
- If the current repository already has the content, it is still removed
|
||||
- from the other repository when moving.
|
||||
-}
|
||||
fromStart :: Bool -> SubCmdStartString
|
||||
fromStart :: Bool -> CommandStartString
|
||||
fromStart move file = isAnnexed file $ \(key, _) -> do
|
||||
remote <- Remotes.commandLineRemote
|
||||
(trusted, untrusted, _) <- Remotes.keyPossibilities key
|
||||
|
@ -116,7 +116,7 @@ fromStart move file = isAnnexed file $ \(key, _) -> do
|
|||
else do
|
||||
showAction move file
|
||||
return $ Just $ fromPerform move key
|
||||
fromPerform :: Bool -> Key -> SubCmdPerform
|
||||
fromPerform :: Bool -> Key -> CommandPerform
|
||||
fromPerform move key = do
|
||||
remote <- Remotes.commandLineRemote
|
||||
ishere <- inAnnex key
|
||||
|
@ -128,7 +128,7 @@ fromPerform move key = do
|
|||
if ok
|
||||
then return $ Just $ fromCleanup move remote key
|
||||
else return Nothing -- fail
|
||||
fromCleanup :: Bool -> Git.Repo -> Key -> SubCmdCleanup
|
||||
fromCleanup :: Bool -> Git.Repo -> Key -> CommandCleanup
|
||||
fromCleanup True remote key = do
|
||||
ok <- Remotes.runCmd remote "git-annex"
|
||||
["dropkey", "--quiet", "--force",
|
||||
|
|
|
@ -17,21 +17,21 @@ import qualified Command.Fix
|
|||
|
||||
{- The pre-commit hook needs to fix symlinks to all files being committed.
|
||||
- And, it needs to inject unlocked files into the annex. -}
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withFilesToBeCommitted Command.Fix.start,
|
||||
withFilesUnlockedToBeCommitted start]
|
||||
|
||||
start :: SubCmdStartBackendFile
|
||||
start :: CommandStartBackendFile
|
||||
start pair = return $ Just $ perform pair
|
||||
|
||||
perform :: BackendFile -> SubCmdPerform
|
||||
perform :: BackendFile -> CommandPerform
|
||||
perform pair@(file, _) = do
|
||||
ok <- doSubCmd $ Command.Add.start pair
|
||||
ok <- doCommand $ Command.Add.start pair
|
||||
if ok
|
||||
then return $ Just $ cleanup file
|
||||
else error $ "failed to add " ++ file ++ "; canceling commit"
|
||||
|
||||
cleanup :: FilePath -> SubCmdCleanup
|
||||
cleanup :: FilePath -> CommandCleanup
|
||||
cleanup file = do
|
||||
-- git commit will have staged the file's content;
|
||||
-- drop that and run command queued by Add.state to
|
||||
|
|
|
@ -19,11 +19,11 @@ import Types
|
|||
import Core
|
||||
import Messages
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withTempFile start]
|
||||
|
||||
{- Sets cached content for a key. -}
|
||||
start :: SubCmdStartString
|
||||
start :: CommandStartString
|
||||
start file = do
|
||||
keyname <- Annex.flagGet "key"
|
||||
when (null keyname) $ error "please specify the key with --key"
|
||||
|
@ -31,7 +31,7 @@ start file = do
|
|||
let key = genKey (head backends) keyname
|
||||
showStart "setkey" file
|
||||
return $ Just $ perform file key
|
||||
perform :: FilePath -> Key -> SubCmdPerform
|
||||
perform :: FilePath -> Key -> CommandPerform
|
||||
perform file key = do
|
||||
-- the file might be on a different filesystem, so mv is used
|
||||
-- rather than simply calling moveToObjectDir key file
|
||||
|
@ -43,7 +43,7 @@ perform file key = do
|
|||
then return $ Just $ cleanup key
|
||||
else error "mv failed!"
|
||||
|
||||
cleanup :: Key -> SubCmdCleanup
|
||||
cleanup :: Key -> CommandCleanup
|
||||
cleanup key = do
|
||||
logStatus key ValuePresent
|
||||
return True
|
||||
|
|
|
@ -17,17 +17,17 @@ import qualified Remotes
|
|||
import UUID
|
||||
import Messages
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withString start]
|
||||
|
||||
{- Marks a remote as trusted. -}
|
||||
start :: SubCmdStartString
|
||||
start :: CommandStartString
|
||||
start name = do
|
||||
r <- Remotes.byName name
|
||||
showStart "trust" name
|
||||
return $ Just $ perform r
|
||||
|
||||
perform :: Git.Repo -> SubCmdPerform
|
||||
perform :: Git.Repo -> CommandPerform
|
||||
perform repo = do
|
||||
uuid <- getUUID repo
|
||||
trusted <- getTrusted
|
||||
|
|
|
@ -20,16 +20,16 @@ import Core
|
|||
import qualified GitRepo as Git
|
||||
import Messages
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withFilesInGit start]
|
||||
|
||||
{- The unannex subcommand undoes an add. -}
|
||||
start :: SubCmdStartString
|
||||
start :: CommandStartString
|
||||
start file = isAnnexed file $ \(key, backend) -> do
|
||||
showStart "unannex" file
|
||||
return $ Just $ perform file key backend
|
||||
|
||||
perform :: FilePath -> Key -> Backend -> SubCmdPerform
|
||||
perform :: FilePath -> Key -> Backend -> CommandPerform
|
||||
perform file key backend = do
|
||||
-- force backend to always remove
|
||||
ok <- Backend.removeKey backend key (Just 0)
|
||||
|
@ -37,7 +37,7 @@ perform file key backend = do
|
|||
then return $ Just $ cleanup file key
|
||||
else return Nothing
|
||||
|
||||
cleanup :: FilePath -> Key -> SubCmdCleanup
|
||||
cleanup :: FilePath -> Key -> CommandCleanup
|
||||
cleanup file key = do
|
||||
g <- Annex.gitRepo
|
||||
|
||||
|
|
|
@ -20,15 +20,15 @@ import qualified Annex
|
|||
import qualified Command.Unannex
|
||||
import qualified Command.Init
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withAll withFilesInGit Command.Unannex.start, withNothing start]
|
||||
|
||||
start :: SubCmdStartNothing
|
||||
start :: CommandStartNothing
|
||||
start = do
|
||||
showStart "uninit" ""
|
||||
return $ Just $ perform
|
||||
|
||||
perform :: SubCmdPerform
|
||||
perform :: CommandPerform
|
||||
perform = do
|
||||
g <- Annex.gitRepo
|
||||
|
||||
|
|
|
@ -18,17 +18,17 @@ import Locations
|
|||
import Core
|
||||
import CopyFile
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withFilesInGit start]
|
||||
|
||||
{- The unlock subcommand replaces the symlink with a copy of the file's
|
||||
- content. -}
|
||||
start :: SubCmdStartString
|
||||
start :: CommandStartString
|
||||
start file = isAnnexed file $ \(key, _) -> do
|
||||
showStart "unlock" file
|
||||
return $ Just $ perform file key
|
||||
|
||||
perform :: FilePath -> Key -> SubCmdPerform
|
||||
perform :: FilePath -> Key -> CommandPerform
|
||||
perform dest key = do
|
||||
g <- Annex.gitRepo
|
||||
let src = annexLocation g key
|
||||
|
|
|
@ -17,17 +17,17 @@ import qualified Remotes
|
|||
import UUID
|
||||
import Messages
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withString start]
|
||||
|
||||
{- Marks a remote as not trusted. -}
|
||||
start :: SubCmdStartString
|
||||
start :: CommandStartString
|
||||
start name = do
|
||||
r <- Remotes.byName name
|
||||
showStart "untrust" name
|
||||
return $ Just $ perform r
|
||||
|
||||
perform :: Git.Repo -> SubCmdPerform
|
||||
perform :: Git.Repo -> CommandPerform
|
||||
perform repo = do
|
||||
uuid <- getUUID repo
|
||||
trusted <- getTrusted
|
||||
|
|
|
@ -17,16 +17,16 @@ import Messages
|
|||
import Locations
|
||||
import qualified Annex
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek :: [CommandSeek]
|
||||
seek = [withNothing start]
|
||||
|
||||
{- Finds unused content in the annex. -}
|
||||
start :: SubCmdStartNothing
|
||||
start :: CommandStartNothing
|
||||
start = do
|
||||
showStart "unused" ""
|
||||
return $ Just perform
|
||||
|
||||
perform :: SubCmdPerform
|
||||
perform :: CommandPerform
|
||||
perform = do
|
||||
_ <- checkUnused
|
||||
return $ Just $ return True
|
||||
|
|
Loading…
Reference in a new issue