diff options
| -rw-r--r-- | Annex.hs | 5 | ||||
| -rw-r--r-- | Backend/SHA1.hs | 2 | ||||
| -rw-r--r-- | Backend/URL.hs | 2 | ||||
| -rw-r--r-- | Command/Add.hs | 3 | ||||
| -rw-r--r-- | Command/Fix.hs | 2 | ||||
| -rw-r--r-- | Command/FromKey.hs | 2 | ||||
| -rw-r--r-- | Command/Init.hs | 17 | ||||
| -rw-r--r-- | Command/Lock.hs | 5 | ||||
| -rw-r--r-- | Command/Map.hs | 9 | ||||
| -rw-r--r-- | Command/Move.hs | 9 | ||||
| -rw-r--r-- | Command/PreCommit.hs | 3 | ||||
| -rw-r--r-- | Command/SetKey.hs | 2 | ||||
| -rw-r--r-- | Command/Unannex.hs | 4 | ||||
| -rw-r--r-- | Content.hs | 2 | ||||
| -rw-r--r-- | CopyFile.hs | 14 | ||||
| -rw-r--r-- | GitQueue.hs | 11 | ||||
| -rw-r--r-- | GitRepo.hs | 44 | ||||
| -rw-r--r-- | Remotes.hs | 50 | ||||
| -rw-r--r-- | RsyncFile.hs | 29 | ||||
| -rw-r--r-- | Trust.hs | 8 | ||||
| -rw-r--r-- | Upgrade.hs | 3 | ||||
| -rw-r--r-- | Utility.hs | 11 | ||||
| -rw-r--r-- | git-annex-shell.hs | 2 | ||||
| -rw-r--r-- | test.hs | 36 |
24 files changed, 151 insertions, 124 deletions
@@ -24,6 +24,7 @@ import Control.Monad.State import qualified GitRepo as Git import qualified GitQueue import qualified BackendTypes +import Utility -- git-annex's monad type Annex = StateT AnnexState IO @@ -91,7 +92,7 @@ gitRepo :: Annex Git.Repo gitRepo = getState repo {- Adds a git command to the queue. -} -queue :: String -> [String] -> FilePath -> Annex () +queue :: String -> [ShellParam] -> FilePath -> Annex () queue command params file = do state <- get let q = repoqueue state @@ -110,7 +111,7 @@ queueRun = do setConfig :: String -> String -> Annex () setConfig k value = do g <- Annex.gitRepo - liftIO $ Git.run g ["config", k, value] + liftIO $ Git.run g "config" [Param k, Param value] -- re-read git config and update the repo's state g' <- liftIO $ Git.configRead g Annex.changeState $ \s -> s { Annex.repo = g' } diff --git a/Backend/SHA1.hs b/Backend/SHA1.hs index e1830bc13..a7f592b73 100644 --- a/Backend/SHA1.hs +++ b/Backend/SHA1.hs @@ -32,7 +32,7 @@ backend = Backend.File.backend { sha1 :: FilePath -> Annex String sha1 file = do showNote "checksum..." - liftIO $ pOpen ReadFromPipe "sha1sum" [utilityEscape file] $ \h -> do + liftIO $ pOpen ReadFromPipe "sha1sum" (toShell [File file]) $ \h -> do line <- hGetLine h let bits = split " " line if null bits diff --git a/Backend/URL.hs b/Backend/URL.hs index 15cc88d64..864c79301 100644 --- a/Backend/URL.hs +++ b/Backend/URL.hs @@ -51,6 +51,6 @@ downloadUrl :: Key -> FilePath -> Annex Bool downloadUrl key file = do showNote "downloading" showProgress -- make way for curl progress bar - liftIO $ boolSystem "curl" ["-#", "-o", utilityEscape file, url] + liftIO $ boolSystem "curl" [Params "-# -o", File file, File url] where url = join ":" $ drop 1 $ split ":" $ show key diff --git a/Command/Add.hs b/Command/Add.hs index 4b49297fc..26e7fa258 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -17,6 +17,7 @@ import LocationLog import Types import Content import Messages +import Utility command :: [Command] command = [Command "add" paramPath seek "add files to annex"] @@ -52,5 +53,5 @@ cleanup file key = do link <- calcGitLink file key liftIO $ createSymbolicLink link file - Annex.queue "add" ["--"] file + Annex.queue "add" [Param "--"] file return True diff --git a/Command/Fix.hs b/Command/Fix.hs index d67eca164..004754871 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -44,5 +44,5 @@ perform file link = do cleanup :: FilePath -> CommandCleanup cleanup file = do - Annex.queue "add" ["--"] file + Annex.queue "add" [Param "--"] file return True diff --git a/Command/FromKey.hs b/Command/FromKey.hs index 881794258..d16eff846 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -47,5 +47,5 @@ perform file = do cleanup :: FilePath -> CommandCleanup cleanup file = do - Annex.queue "add" ["--"] file + Annex.queue "add" [Param "--"] file return True diff --git a/Command/Init.hs b/Command/Init.hs index 2976b988d..1074d100e 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -51,8 +51,12 @@ cleanup :: CommandCleanup cleanup = do g <- Annex.gitRepo logfile <- uuidLog - liftIO $ Git.run g ["add", logfile] - liftIO $ Git.run g ["commit", "-q", "-m", "git annex init", logfile] + liftIO $ Git.run g "add" [File logfile] + liftIO $ Git.run g "commit" + [ Params "-q -m" + , Param "git annex init" + , File logfile + ] return True {- configure git to use union merge driver on state files, if it is not @@ -72,9 +76,12 @@ gitAttributesWrite repo = do where attributes = Git.attributes repo commit = do - Git.run repo ["add", attributes] - Git.run repo ["commit", "-q", "-m", "git-annex setup", - attributes] + Git.run repo "add" [Param attributes] + Git.run repo "commit" + [ Params "-q -m" + , Param "git-annex setup" + , Param attributes + ] attrLine :: String attrLine = stateDir </> "*.log merge=union" diff --git a/Command/Lock.hs b/Command/Lock.hs index 00a553e95..a3a39a907 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -14,6 +14,7 @@ import Command import Messages import qualified Annex import qualified GitRepo as Git +import Utility command :: [Command] command = [Command "lock" paramPath seek "undo unlock command"] @@ -32,7 +33,7 @@ perform file = do liftIO $ removeFile file g <- Annex.gitRepo -- first reset the file to drop any changes checked into the index - liftIO $ Git.run g ["reset", "-q", "--", file] + liftIO $ Git.run g "reset" [Params "-q --", File file] -- checkout the symlink - liftIO $ Git.run g ["checkout", "--", file] + liftIO $ Git.run g "checkout" [Param "--", File file] return $ Just $ return True -- no cleanup needed diff --git a/Command/Map.hs b/Command/Map.hs index 0a3bb9fff..00b5fc21b 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -44,7 +44,7 @@ start = do liftIO $ writeFile file (drawMap rs umap trusted) showLongNote $ "running: dot -Tx11 " ++ file showProgress - r <- liftIO $ boolSystem "dot" ["-Tx11", file] + r <- liftIO $ boolSystem "dot" [Param "-Tx11", File file] return $ Just $ return $ Just $ return r where file = "map.dot" @@ -198,7 +198,7 @@ tryScan r Left _ -> return Nothing Right r' -> return $ Just r' pipedconfig cmd params = safely $ - pOpen ReadFromPipe cmd params $ + pOpen ReadFromPipe cmd (toShell params) $ Git.hConfigRead r configlist = @@ -208,8 +208,9 @@ tryScan r let sshcmd = "cd " ++ shellEscape(Git.workTree r) ++ " && " ++ "git config --list" - liftIO $ pipedconfig "ssh" $ - words sshoptions ++ [Git.urlHostFull r, sshcmd] + liftIO $ pipedconfig "ssh" $ map Param $ + words sshoptions ++ + [Git.urlHostFull r, sshcmd] -- First, try sshing and running git config manually, -- only fall back to git-annex-shell configlist if that diff --git a/Command/Move.hs b/Command/Move.hs index 6dc2e4874..8c19539fb 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -56,7 +56,7 @@ remoteHasKey remote key present = do g <- Annex.gitRepo remoteuuid <- getUUID remote logfile <- liftIO $ logChange g key remoteuuid status - Annex.queue "add" ["--"] logfile + Annex.queue "add" [Param "--"] logfile where status = if present then ValuePresent else ValueMissing @@ -130,9 +130,10 @@ fromPerform src move key = do fromCleanup :: Git.Repo -> Bool -> Key -> CommandCleanup fromCleanup src True key = do ok <- Remotes.onRemote src (boolSystem, False) "dropkey" - ["--quiet", "--force", - "--backend=" ++ backendName key, - keyName key] + [ Params "--quiet --force" + , Param $ "--backend=" ++ backendName key + , Param $ keyName key + ] -- better safe than sorry: assume the src dropped the key -- even if it seemed to fail; the failure could have occurred -- after it really dropped it diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index 750997f54..d2f696434 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -15,6 +15,7 @@ import qualified GitRepo as Git import qualified Command.Add import qualified Command.Fix import Messages +import Utility command :: [Command] command = [Command "pre-commit" paramPath seek "run by git pre-commit hook"] @@ -41,6 +42,6 @@ cleanup file = do -- drop that and run command queued by Add.state to -- stage the symlink g <- Annex.gitRepo - liftIO $ Git.run g ["reset", "-q", "--", file] + liftIO $ Git.run g "reset" [Params "-q --", File file] Annex.queueRun return True diff --git a/Command/SetKey.hs b/Command/SetKey.hs index 025fb74d6..fdda1c3be 100644 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -36,7 +36,7 @@ perform file = do ok <- getViaTmp key $ \dest -> do if dest /= file then liftIO $ - boolSystem "mv" [utilityEscape file, utilityEscape dest] + boolSystem "mv" [File file, File dest] else return True if ok then return $ Just $ cleanup diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 19cb1624e..42dc1fb0a 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -58,7 +58,7 @@ cleanup file key = do g <- Annex.gitRepo liftIO $ removeFile file - liftIO $ Git.run g ["rm", "--quiet", "--", file] + liftIO $ Git.run g "rm" [Params "--quiet --", File file] -- git rm deletes empty directories; put them back liftIO $ createDirectoryIfMissing True (parentDir file) @@ -68,6 +68,6 @@ cleanup file key = do -- Commit staged changes at end to avoid confusing the -- pre-commit hook if this file is later added back to -- git as a normal, non-annexed file. - Annex.queue "commit" ["-m", "content removed from git annex"] "-a" + Annex.queue "commit" [Params "-a -m", Param "content removed from git annex"] "-a" return True diff --git a/Content.hs b/Content.hs index 345599dba..cb954f4a0 100644 --- a/Content.hs +++ b/Content.hs @@ -60,7 +60,7 @@ logStatus key status = do g <- Annex.gitRepo u <- getUUID g logfile <- liftIO $ logChange g key u status - Annex.queue "add" ["--"] logfile + Annex.queue "add" [Param "--"] logfile {- Runs an action, passing it a temporary filename to download, - and if the action succeeds, moves the temp file into diff --git a/CopyFile.hs b/CopyFile.hs index 73d911a29..4575fb08a 100644 --- a/CopyFile.hs +++ b/CopyFile.hs @@ -20,14 +20,12 @@ copyFile src dest = do e <- doesFileExist dest when e $ removeFile dest - boolSystem "cp" opts + boolSystem "cp" [params, File src, File dest] where - opts = if SysConfig.cp_reflink_auto - then ["--reflink=auto", src', dest'] + params = if SysConfig.cp_reflink_auto + then Params "--reflink=auto" else if SysConfig.cp_a - then ["-a", src', dest'] + then Params "-a" else if SysConfig.cp_p - then ["-p", src', dest'] - else [src', dest'] - src' = utilityEscape src - dest' = utilityEscape dest + then Params "-p" + else Params "" diff --git a/GitQueue.hs b/GitQueue.hs index 4a777af4d..328243fa0 100644 --- a/GitQueue.hs +++ b/GitQueue.hs @@ -17,6 +17,7 @@ import System.IO import System.Cmd.Utils import Data.String.Utils import Control.Monad (unless, forM_) +import Utility import qualified GitRepo as Git @@ -24,7 +25,7 @@ import qualified GitRepo as Git - is not included, and must be able to be appended after the params. -} data Action = Action { getSubcommand :: String, - getParams :: [String] + getParams :: [ShellParam] } deriving (Show, Eq, Ord) {- A queue of actions to perform (in any order) on a git repository, @@ -37,7 +38,7 @@ empty :: Queue empty = M.empty {- Adds an action to a queue. -} -add :: Queue -> String -> [String] -> FilePath -> Queue +add :: Queue -> String -> [ShellParam] -> FilePath -> Queue add queue subcommand params file = M.insertWith (++) action [file] queue where action = Action subcommand params @@ -55,7 +56,7 @@ runAction :: Git.Repo -> Action -> [FilePath] -> IO () runAction repo action files = do unless (null files) runxargs where - runxargs = pOpen WriteToPipe "xargs" ("-0":gitcmd) feedxargs - gitcmd = "git" : Git.gitCommandLine repo - (getSubcommand action:getParams action) + runxargs = pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs + params = toShell $ Git.gitCommandLine repo + (Param (getSubcommand action):getParams action) feedxargs h = hPutStr h $ join "\0" files diff --git a/GitRepo.hs b/GitRepo.hs index 7cf0891ed..3f2acdcf4 100644 --- a/GitRepo.hs +++ b/GitRepo.hs @@ -243,16 +243,18 @@ urlPath Repo { location = Url u } = uriPath u urlPath repo = assertUrl repo $ error "internal" {- Constructs a git command line operating on the specified repo. -} -gitCommandLine :: Repo -> [String] -> [String] +gitCommandLine :: Repo -> [ShellParam] -> [ShellParam] gitCommandLine repo@(Repo { location = Dir d} ) params = -- force use of specified repo via --git-dir and --work-tree - ["--git-dir=" ++ d ++ "/" ++ gitDir repo, "--work-tree=" ++ d] ++ params + [ Param ("--git-dir=" ++ d ++ "/" ++ gitDir repo) + , Param ("--work-tree=" ++ d) + ] ++ params gitCommandLine repo _ = assertLocal repo $ error "internal" {- Runs git in the specified repo, throwing an error if it fails. -} -run :: Repo -> [String] -> IO () -run repo params = assertLocal repo $ do - ok <- boolSystem "git" (gitCommandLine repo params) +run :: Repo -> String -> [ShellParam] -> IO () +run repo subcommand params = assertLocal repo $ do + ok <- boolSystem "git" (gitCommandLine repo ((Param subcommand):params)) unless ok $ error $ "git " ++ show params ++ " failed" {- Runs a git subcommand and returns it output, lazily. @@ -260,9 +262,9 @@ run repo params = assertLocal repo $ do - Note that this leaves the git process running, and so zombies will - result unless reap is called. -} -pipeRead :: Repo -> [String] -> IO String +pipeRead :: Repo -> [ShellParam] -> IO String pipeRead repo params = assertLocal repo $ do - (_, s) <- pipeFrom "git" (gitCommandLine repo params) + (_, s) <- pipeFrom "git" $ toShell $ gitCommandLine repo params return s {- Reaps any zombie git processes. -} @@ -277,13 +279,13 @@ reap = do {- Scans for files that are checked into git at the specified locations. -} inRepo :: Repo -> [FilePath] -> IO [FilePath] inRepo repo l = pipeNullSplit repo $ - ["ls-files", "--cached", "--exclude-standard", "-z", "--"] ++ l + [Params "ls-files --cached --exclude-standard -z --"] ++ map File l {- Scans for files at the specified locations that are not checked into git, - and not gitignored. -} notInRepo :: Repo -> [FilePath] -> IO [FilePath] notInRepo repo l = pipeNullSplit repo $ - ["ls-files", "--others", "--exclude-standard", "-z", "--"] ++ l + [Params "ls-files --others --exclude-standard -z --"] ++ map File l {- Returns a list of all files that are staged for commit. -} stagedFiles :: Repo -> [FilePath] -> IO [FilePath] @@ -292,38 +294,38 @@ stagedFiles repo l = stagedFiles' repo l [] {- Returns a list of the files, staged for commit, that are being added, - moved, or changed (but not deleted), from the specified locations. -} stagedFilesNotDeleted :: Repo -> [FilePath] -> IO [FilePath] -stagedFilesNotDeleted repo l = stagedFiles' repo l ["--diff-filter=ACMRT"] +stagedFilesNotDeleted repo l = stagedFiles' repo l [Param "--diff-filter=ACMRT"] -stagedFiles' :: Repo -> [FilePath] -> [String] -> IO [FilePath] +stagedFiles' :: Repo -> [FilePath] -> [ShellParam] -> IO [FilePath] stagedFiles' repo l middle = pipeNullSplit repo $ start ++ middle ++ end where - start = ["diff", "--cached", "--name-only", "-z"] - end = ["--"] ++ l + start = [Params "diff --cached --name-only -z"] + end = [Param "--"] ++ map File l {- Returns a list of files that have unstaged changes. -} changedUnstagedFiles :: Repo -> [FilePath] -> IO [FilePath] changedUnstagedFiles repo l = pipeNullSplit repo $ - ["diff", "--name-only", "-z", "--"] ++ l + [Params "diff --name-only -z --"] ++ map File l {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -} typeChangedStagedFiles :: Repo -> [FilePath] -> IO [FilePath] -typeChangedStagedFiles repo l = typeChangedFiles' repo l ["--cached"] +typeChangedStagedFiles repo l = typeChangedFiles' repo l [Param "--cached"] {- Returns a list of the files in the specified locations whose type has - changed. Files only staged for commit will not be included. -} typeChangedFiles :: Repo -> [FilePath] -> IO [FilePath] typeChangedFiles repo l = typeChangedFiles' repo l [] -typeChangedFiles' :: Repo -> [FilePath] -> [String] -> IO [FilePath] +typeChangedFiles' :: Repo -> [FilePath] -> [ShellParam] -> IO [FilePath] typeChangedFiles' repo l middle = pipeNullSplit repo $ start ++ middle ++ end where - start = ["diff", "--name-only", "--diff-filter=T", "-z"] - end = ["--"] ++ l + start = [Params "diff --name-only --diff-filter=T -z"] + end = [Param "--"] ++ map File l {- Reads null terminated output of a git command (as enabled by the -z - parameter), and splits it into a list of files. -} -pipeNullSplit :: Repo -> [String] -> IO [FilePath] +pipeNullSplit :: Repo -> [ShellParam] -> IO [FilePath] pipeNullSplit repo params = do fs0 <- pipeRead repo params return $ split0 fs0 @@ -408,11 +410,11 @@ checkAttr repo attr files = do -- directory. Convert to absolute, and then convert the filenames -- in its output back to relative. absfiles <- mapM absPath files - (_, s) <- pipeBoth "git" params $ join "\0" absfiles + (_, s) <- pipeBoth "git" (toShell params) $ join "\0" absfiles cwd <- getCurrentDirectory return $ map (topair $ cwd++"/") $ lines s where - params = gitCommandLine repo ["check-attr", attr, "-z", "--stdin"] + params = gitCommandLine repo [Param "check-attr", Param attr, Params "-z --stdin"] topair cwd l = (relfile, value) where relfile diff --git a/Remotes.hs b/Remotes.hs index c7e69aad8..1523e6750 100644 --- a/Remotes.hs +++ b/Remotes.hs @@ -64,7 +64,7 @@ tryGitConfigRead r Left _ -> return r Right r' -> return r' pipedconfig cmd params = safely $ - pOpen ReadFromPipe cmd params $ + pOpen ReadFromPipe cmd (toShell params) $ Git.hConfigRead r store a = do r' <- a @@ -154,7 +154,7 @@ inAnnex r key = if Git.repoIsUrl r checkremote = do showNote ("checking " ++ Git.repoDescribe r ++ "...") inannex <- onRemote r (boolSystem, False) "inannex" - ["--backend=" ++ backendName key, keyName key] + [Param ("--backend=" ++ backendName key), Param (keyName key)] return $ Right inannex {- Cost Ordered list of remotes. -} @@ -263,28 +263,31 @@ rsynchelper r sending key file = do {- Generates rsync parameters that ssh to the remote and asks it - to either receive or send the key's content. -} -rsyncParams :: Git.Repo -> Bool -> Key -> FilePath -> Annex [String] +rsyncParams :: Git.Repo -> Bool -> Key -> FilePath -> Annex [ShellParam] rsyncParams r sending key file = do - -- Note that the command is terminated with "--", because - -- rsync will tack on its own options to this command, - -- and they need to be ignored. - shellcmd <- git_annex_shell r + Just (shellcmd, shellparams) <- git_annex_shell r (if sending then "sendkey" else "recvkey") - ["--backend=" ++ backendName key, keyName key, "--"] + [ Param $ "--backend=" ++ backendName key + , Param $ keyName key + -- Command is terminated with "--", because + -- rsync will tack on its own options afterwards, + -- and they need to be ignored. + , Param "--" + ] -- Convert the ssh command into rsync command line. - let eparam = rsyncShell $ fromJust shellcmd + let eparam = rsyncShell (Param shellcmd:shellparams) o <- repoConfig r "rsync-options" "" - let base = options ++ words o ++ eparam + let base = options ++ map Param (words o) ++ eparam if sending - then return $ base ++ [dummy, file] - else return $ base ++ [file, dummy] + then return $ base ++ [dummy, File file] + else return $ base ++ [File file, dummy] where -- inplace makes rsync resume partial files - options = ["-p", "--progress", "--inplace"] + options = [Params "-p --progress --inplace"] -- the rsync shell parameter controls where rsync -- goes, so the source/dest parameter can be a dummy value, -- that just enables remote rsync mode. - dummy = ":" + dummy = Param ":" {- Uses a supplied function to run a git-annex-shell command on a remote. - @@ -292,30 +295,31 @@ rsyncParams r sending key file = do - a specified error value. -} onRemote :: Git.Repo - -> (String -> [String] -> IO a, a) + -> (FilePath -> [ShellParam] -> IO a, a) -> String - -> [String] + -> [ShellParam] -> Annex a onRemote r (with, errorval) command params = do s <- git_annex_shell r command params case s of - Just shellcmd -> liftIO $ with (shellcmd !! 0) (tail shellcmd) + Just (c, ps) -> liftIO $ with c ps Nothing -> return errorval {- Generates parameters to run a git-annex-shell command on a remote. -} -git_annex_shell :: Git.Repo -> String -> [String] -> Annex (Maybe [String]) +git_annex_shell :: Git.Repo -> String -> [ShellParam] -> Annex (Maybe (FilePath, [ShellParam])) git_annex_shell r command params - | not $ Git.repoIsUrl r = return $ Just (shellcmd:shellopts) + | not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts) | Git.repoIsSsh r = do sshoptions <- repoConfig r "ssh-options" "" - return $ Just $ ["ssh"] ++ words sshoptions ++ - [Git.urlHostFull r, sshcmd] + return $ Just ("ssh", map Param (words sshoptions) ++ + [Param (Git.urlHostFull r), Param sshcmd]) | otherwise = return Nothing where dir = Git.workTree r shellcmd = "git-annex-shell" - shellopts = command:dir:params - sshcmd = shellcmd ++ " " ++ unwords (map shellEscape shellopts) + shellopts = (Param command):(File dir):params + sshcmd = shellcmd ++ " " ++ + unwords (map shellEscape $ toShell shellopts) {- Looks up a per-remote config option in git config. - Failing that, tries looking for a global config option. -} diff --git a/RsyncFile.hs b/RsyncFile.hs index 9de2e2c59..149b45b11 100644 --- a/RsyncFile.hs +++ b/RsyncFile.hs @@ -14,8 +14,8 @@ import Utility {- Generates parameters to make rsync use a specified command as its remote - shell. -} -rsyncShell :: [String] -> [String] -rsyncShell command = ["-e", unwords $ map escape command] +rsyncShell :: [ShellParam] -> [ShellParam] +rsyncShell command = [Param "-e", Param $ unwords $ map escape (toShell command)] where {- rsync requires some weird, non-shell like quoting in - here. A doubled single quote inside the single quoted @@ -25,22 +25,25 @@ rsyncShell command = ["-e", unwords $ map escape command] {- Runs rsync in server mode to send a file, and exits. -} rsyncServerSend :: FilePath -> IO () rsyncServerSend file = rsyncExec $ - rsyncServerParams ++ ["--sender", utilityEscape file] + rsyncServerParams ++ [Param "--sender", File file] {- Runs rsync in server mode to receive a file. -} rsyncServerReceive :: FilePath -> IO Bool -rsyncServerReceive file = rsync $ rsyncServerParams ++ [utilityEscape file] +rsyncServerReceive file = rsync $ rsyncServerParams ++ [File file] -rsyncServerParams :: [String] +rsyncServerParams :: [ShellParam] rsyncServerParams = - [ "--server" - , "-p" -- preserve permissions - , "--inplace" -- allow resuming of transfers of big files - , "-e.Lsf", "." -- other options rsync normally uses in server mode + [ Param "--server" + -- preserve permissions + , Param "-p" + -- allow resuming of transfers of big files + , Param "--inplace" + -- other options rsync normally uses in server mode + , Params "-e.Lsf ." ] -rsync :: [String] -> IO Bool -rsync params = boolSystem "rsync" params +rsync :: [ShellParam] -> IO Bool +rsync = boolSystem "rsync" -rsyncExec :: [String] -> IO () -rsyncExec params = executeFile "rsync" True params Nothing +rsyncExec :: [ShellParam] -> IO () +rsyncExec params = executeFile "rsync" True (toShell params) Nothing @@ -81,8 +81,12 @@ trustSet uuid level = do logfile <- trustLog liftIO $ safeWriteFile logfile (serialize m') g <- Annex.gitRepo - liftIO $ Git.run g ["add", logfile] - liftIO $ Git.run g ["commit", "-q", "-m", "git annex trust change", logfile] + liftIO $ Git.run g "add" [File logfile] + liftIO $ Git.run g "commit" + [ Params "-q -m" + , Param "git annex trust change" + , File logfile + ] where serialize m = unlines $ map showpair $ M.toList m showpair (u, t) = u ++ " " ++ show t diff --git a/Upgrade.hs b/Upgrade.hs index b584b2666..3c16bcc86 100644 --- a/Upgrade.hs +++ b/Upgrade.hs @@ -22,6 +22,7 @@ import qualified Annex import qualified Backend import Messages import Version +import Utility {- Uses the annex.version git config setting to automate upgrades. -} upgrade :: Annex Bool @@ -62,7 +63,7 @@ upgradeFrom0 = do link <- calcGitLink f k liftIO $ removeFile f liftIO $ createSymbolicLink link f - Annex.queue "add" ["--"] f + Annex.queue "add" [Param "--"] f fixlinks fs getKeysPresent0' :: FilePath -> Annex [Key] diff --git a/Utility.hs b/Utility.hs index b5c0dd617..90494a0c4 100644 --- a/Utility.hs +++ b/Utility.hs @@ -1,6 +1,6 @@ {- git-annex utility functions - - - Copyright 2010 Joey Hess <joey@kitenet.net> + - Copyright 2010-2011 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -50,16 +50,17 @@ import Control.Monad (liftM2) data ShellParam = Params String | Param String | File FilePath deriving (Eq, Show, Ord) -{- When converting ShellParam to a String in preparation for passing to - - a shell command, Files that start with a dash are modified to avoid - - the shell command interpreting them as options. -} +{- Used to pass a list of ShellParams to a function that runs + - a shell command and expects Strings. -} toShell :: [ShellParam] -> [String] toShell l = concat $ map unwrap l where unwrap (Param s) = [s] unwrap (Params s) = filter (not . null) (split " " s) + -- Files that start with a dash are modified to avoid + -- the shell command interpreting them as options. unwrap (File ('-':s)) = ["./-" ++ s] - unwrap (File (s)) = [s] + unwrap (File s) = [s] {- Run a system command, and returns True or False - if it succeeded or failed. diff --git a/git-annex-shell.hs b/git-annex-shell.hs index fee4091ef..aeaadcbf8 100644 --- a/git-annex-shell.hs +++ b/git-annex-shell.hs @@ -66,7 +66,7 @@ builtin cmd dir params = do external :: [String] -> IO () external params = do - ret <- boolSystem "git-shell" ("-c":(filterparams params)) + ret <- boolSystem "git-shell" $ map Param $ ("-c":filterparams params) when (not ret) $ error "git-shell failed" @@ -105,8 +105,8 @@ test_add = "git-annex add" ~: TestList [basic, sha1dup] git_annex "add" ["-q", annexedfile] @? "add failed" annexed_present annexedfile writeFile ingitfile $ content ingitfile - Utility.boolSystem "git" ["add", ingitfile] @? "git add failed" - Utility.boolSystem "git" ["commit", "-q", "-a", "-m", "commit"] @? "git commit failed" + Utility.boolSystem "git" [Utility.Param "add", Utility.File ingitfile] @? "git add failed" + Utility.boolSystem "git" [Utility.Params "commit -q -a -m commit"] @? "git commit failed" git_annex "add" ["-q", ingitfile] @? "add ingitfile should be no-op" unannexed ingitfile sha1dup = TestCase $ intmpclonerepo $ do @@ -125,7 +125,7 @@ test_setkey = "git-annex setkey/fromkey" ~: TestCase $ inmainrepo $ do let sha1 = BackendTypes.keyName $ fromJust r git_annex "setkey" ["-q", "--backend", "SHA1", "--key", sha1, tmp] @? "setkey failed" git_annex "fromkey" ["-q", "--backend", "SHA1", "--key", sha1, sha1annexedfile] @? "fromkey failed" - Utility.boolSystem "git" ["commit", "-q", "-a", "-m", "commit"] @? "git commit failed" + Utility.boolSystem "git" [Utility.Params "commit -q -a -m commit"] @? "git commit failed" annexed_present sha1annexedfile where tmp = "tmpfile" @@ -139,7 +139,7 @@ test_unannex = "git-annex unannex" ~: TestList [nocopy, withcopy] annexed_notpresent annexedfile withcopy = "with content" ~: intmpclonerepo $ do git_annex "get" ["-q", annexedfile] @? "get failed" - Utility.boolSystem "git" ["commit", "-q", "-a", "-m", "state changed"] + Utility.boolSystem "git" [Utility.Params "commit -q -a -m statechanged"] @? "git commit of state failed" annexed_present annexedfile git_annex "unannex" ["-q", annexedfile, sha1annexedfile] @? "unannex failed" @@ -154,9 +154,9 @@ test_drop = "git-annex drop" ~: TestList [noremote, withremote, untrustedremote] where noremote = "no remotes" ~: TestCase $ intmpclonerepo $ do git_annex "get" ["-q", annexedfile] @? "get failed" - Utility.boolSystem "git" ["commit", "-q", "-a", "-m", "state changed"] + Utility.boolSystem "git" [Utility.Params "commit -q -a -m statechanged"] @? "git commit of state failed" - Utility.boolSystem "git" ["remote", "rm", "origin"] + Utility.boolSystem "git" [Utility.Params "remote rm origin"] @? "git remote rm origin failed" r <- git_annex "drop" ["-q", annexedfile] not r @? "drop wrongly succeeded with no known copy of file" @@ -287,12 +287,12 @@ test_edit = "git-annex edit/commit" ~: TestList [t False, t True] then do -- pre-commit depends on the file being -- staged, normally git commit does this - Utility.boolSystem "git" ["add", annexedfile] + Utility.boolSystem "git" [Utility.Param "add", Utility.File annexedfile] @? "git add of edited file failed" git_annex "pre-commit" ["-q"] @? "pre-commit failed" else do - Utility.boolSystem "git" ["commit", "-q", "-a", "-m", "content changed"] + Utility.boolSystem "git" [Utility.Params "commit -q -a -m contentchanged"] @? "git commit of edited file failed" runchecks [checklink, checkunwritable] annexedfile c <- readFile annexedfile @@ -310,7 +310,7 @@ test_fix = "git-annex fix" ~: intmpclonerepo $ do git_annex "fix" ["-q", annexedfile] @? "fix of present file failed" annexed_present annexedfile createDirectory subdir - Utility.boolSystem "git" ["mv", annexedfile, subdir] + Utility.boolSystem "git" [Utility.Param "mv", Utility.File annexedfile, Utility.File subdir] @? "git mv failed" git_annex "fix" ["-q", newfile] @? "fix of moved file failed" runchecks [checklink, checkunwritable] newfile @@ -350,9 +350,9 @@ test_fsck = "git-annex fsck" ~: TestList [basicfsck, withlocaluntrusted, withrem where basicfsck = TestCase $ intmpclonerepo $ do git_annex "fsck" ["-q"] @? "fsck failed" - Utility.boolSystem "git" ["config", "annex.numcopies", "2"] @? "git config failed" + Utility.boolSystem "git" [Utility.Params "config annex.numcopies 2"] @? "git config failed" fsck_should_fail "numcopies unsatisfied" - Utility.boolSystem "git" ["config", "annex.numcopies", "1"] @? "git config failed" + Utility.boolSystem "git" [Utility.Params "config annex.numcopies 1"] @? "git config failed" corrupt annexedfile corrupt sha1annexedfile withlocaluntrusted = TestCase $ intmpclonerepo $ do @@ -363,7 +363,7 @@ test_fsck = "git-annex fsck" ~: TestList [basicfsck, withlocaluntrusted, withrem git_annex "trust" ["-q", "."] @? "trust of current repo failed" git_annex "fsck" ["-q", annexedfile] @? "fsck failed on file present in trusted repo" withremoteuntrusted = TestCase $ intmpclonerepo $ do - Utility.boolSystem "git" ["config", "annex.numcopies", "2"] @? "git config failed" + Utility.boolSystem "git" [Utility.Params "config annex.numcopies 2"] @? "git config failed" git_annex "get" ["-q", annexedfile] @? "get failed" git_annex "get" ["-q", sha1annexedfile] @? "get failed" git_annex "fsck" ["-q"] @? "fsck failed with numcopies=2 and 2 copies" @@ -433,9 +433,9 @@ test_unused = "git-annex unused/dropunused" ~: intmpclonerepo $ do git_annex "get" ["-q", annexedfile] @? "get of file failed" git_annex "get" ["-q", sha1annexedfile] @? "get of file failed" checkunused [] - Utility.boolSystem "git" ["rm", "-q", annexedfile] @? "git rm failed" + Utility.boolSystem "git" [Utility.Params "rm -q", Utility.File annexedfile] @? "git rm failed" checkunused [annexedfilekey] - Utility.boolSystem "git" ["rm", "-q", sha1annexedfile] @? "git rm failed" + Utility.boolSystem "git" [Utility.Params "rm -q", Utility.File sha1annexedfile] @? "git rm failed" checkunused [annexedfilekey, sha1annexedfilekey] -- good opportunity to test dropkey also @@ -511,10 +511,10 @@ setuprepo :: FilePath -> IO FilePath setuprepo dir = do cleanup dir ensuretmpdir - Utility.boolSystem "git" ["init", "-q", dir] @? "git init failed" + Utility.boolSystem "git" [Utility.Params "init -q", Utility.File dir] @? "git init failed" indir dir $ do - Utility.boolSystem "git" ["config", "user.name", "Test User"] @? "git config failed" - Utility.boolSystem "git" ["config", "user.email", "test@example.com"] @? "git config failed" + Utility.boolSystem "git" [Utility.Params "config user.name", Utility.Param "Test User"] @? "git config failed" + Utility.boolSystem "git" [Utility.Params "config user.email test@example.com"] @? "git config failed" return dir -- clones are always done as local clones; we cannot test ssh clones @@ -522,7 +522,7 @@ clonerepo :: FilePath -> FilePath -> IO FilePath clonerepo old new = do cleanup new ensuretmpdir - Utility.boolSystem "git" ["clone", "-q", old, new] @? "git clone failed" + Utility.boolSystem "git" [Utility.Params "clone -q", Utility.File old, Utility.File new] @? "git clone failed" indir new $ git_annex "init" ["-q", new] @? "git annex init failed" return new |