use ShellParam type

So, I have a type checked safe handling of filenames starting with dashes,
throughout the code.
This commit is contained in:
Joey Hess 2011-02-28 16:10:16 -04:00
parent 7e5678bcf7
commit fcdc4797a9
24 changed files with 151 additions and 124 deletions

View file

@ -24,6 +24,7 @@ import Control.Monad.State
import qualified GitRepo as Git import qualified GitRepo as Git
import qualified GitQueue import qualified GitQueue
import qualified BackendTypes import qualified BackendTypes
import Utility
-- git-annex's monad -- git-annex's monad
type Annex = StateT AnnexState IO type Annex = StateT AnnexState IO
@ -91,7 +92,7 @@ gitRepo :: Annex Git.Repo
gitRepo = getState repo gitRepo = getState repo
{- Adds a git command to the queue. -} {- Adds a git command to the queue. -}
queue :: String -> [String] -> FilePath -> Annex () queue :: String -> [ShellParam] -> FilePath -> Annex ()
queue command params file = do queue command params file = do
state <- get state <- get
let q = repoqueue state let q = repoqueue state
@ -110,7 +111,7 @@ queueRun = do
setConfig :: String -> String -> Annex () setConfig :: String -> String -> Annex ()
setConfig k value = do setConfig k value = do
g <- Annex.gitRepo 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 -- re-read git config and update the repo's state
g' <- liftIO $ Git.configRead g g' <- liftIO $ Git.configRead g
Annex.changeState $ \s -> s { Annex.repo = g' } Annex.changeState $ \s -> s { Annex.repo = g' }

View file

@ -32,7 +32,7 @@ backend = Backend.File.backend {
sha1 :: FilePath -> Annex String sha1 :: FilePath -> Annex String
sha1 file = do sha1 file = do
showNote "checksum..." showNote "checksum..."
liftIO $ pOpen ReadFromPipe "sha1sum" [utilityEscape file] $ \h -> do liftIO $ pOpen ReadFromPipe "sha1sum" (toShell [File file]) $ \h -> do
line <- hGetLine h line <- hGetLine h
let bits = split " " line let bits = split " " line
if null bits if null bits

View file

@ -51,6 +51,6 @@ downloadUrl :: Key -> FilePath -> Annex Bool
downloadUrl key file = do downloadUrl key file = do
showNote "downloading" showNote "downloading"
showProgress -- make way for curl progress bar showProgress -- make way for curl progress bar
liftIO $ boolSystem "curl" ["-#", "-o", utilityEscape file, url] liftIO $ boolSystem "curl" [Params "-# -o", File file, File url]
where where
url = join ":" $ drop 1 $ split ":" $ show key url = join ":" $ drop 1 $ split ":" $ show key

View file

@ -17,6 +17,7 @@ import LocationLog
import Types import Types
import Content import Content
import Messages import Messages
import Utility
command :: [Command] command :: [Command]
command = [Command "add" paramPath seek "add files to annex"] command = [Command "add" paramPath seek "add files to annex"]
@ -52,5 +53,5 @@ cleanup file key = do
link <- calcGitLink file key link <- calcGitLink file key
liftIO $ createSymbolicLink link file liftIO $ createSymbolicLink link file
Annex.queue "add" ["--"] file Annex.queue "add" [Param "--"] file
return True return True

View file

@ -44,5 +44,5 @@ perform file link = do
cleanup :: FilePath -> CommandCleanup cleanup :: FilePath -> CommandCleanup
cleanup file = do cleanup file = do
Annex.queue "add" ["--"] file Annex.queue "add" [Param "--"] file
return True return True

View file

@ -47,5 +47,5 @@ perform file = do
cleanup :: FilePath -> CommandCleanup cleanup :: FilePath -> CommandCleanup
cleanup file = do cleanup file = do
Annex.queue "add" ["--"] file Annex.queue "add" [Param "--"] file
return True return True

View file

@ -51,8 +51,12 @@ cleanup :: CommandCleanup
cleanup = do cleanup = do
g <- Annex.gitRepo g <- Annex.gitRepo
logfile <- uuidLog logfile <- uuidLog
liftIO $ Git.run g ["add", logfile] liftIO $ Git.run g "add" [File logfile]
liftIO $ Git.run g ["commit", "-q", "-m", "git annex init", logfile] liftIO $ Git.run g "commit"
[ Params "-q -m"
, Param "git annex init"
, File logfile
]
return True return True
{- configure git to use union merge driver on state files, if it is not {- configure git to use union merge driver on state files, if it is not
@ -72,9 +76,12 @@ gitAttributesWrite repo = do
where where
attributes = Git.attributes repo attributes = Git.attributes repo
commit = do commit = do
Git.run repo ["add", attributes] Git.run repo "add" [Param attributes]
Git.run repo ["commit", "-q", "-m", "git-annex setup", Git.run repo "commit"
attributes] [ Params "-q -m"
, Param "git-annex setup"
, Param attributes
]
attrLine :: String attrLine :: String
attrLine = stateDir </> "*.log merge=union" attrLine = stateDir </> "*.log merge=union"

View file

@ -14,6 +14,7 @@ import Command
import Messages import Messages
import qualified Annex import qualified Annex
import qualified GitRepo as Git import qualified GitRepo as Git
import Utility
command :: [Command] command :: [Command]
command = [Command "lock" paramPath seek "undo unlock command"] command = [Command "lock" paramPath seek "undo unlock command"]
@ -32,7 +33,7 @@ perform file = do
liftIO $ removeFile file liftIO $ removeFile file
g <- Annex.gitRepo g <- Annex.gitRepo
-- first reset the file to drop any changes checked into the index -- 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 -- checkout the symlink
liftIO $ Git.run g ["checkout", "--", file] liftIO $ Git.run g "checkout" [Param "--", File file]
return $ Just $ return True -- no cleanup needed return $ Just $ return True -- no cleanup needed

View file

@ -44,7 +44,7 @@ start = do
liftIO $ writeFile file (drawMap rs umap trusted) liftIO $ writeFile file (drawMap rs umap trusted)
showLongNote $ "running: dot -Tx11 " ++ file showLongNote $ "running: dot -Tx11 " ++ file
showProgress showProgress
r <- liftIO $ boolSystem "dot" ["-Tx11", file] r <- liftIO $ boolSystem "dot" [Param "-Tx11", File file]
return $ Just $ return $ Just $ return r return $ Just $ return $ Just $ return r
where where
file = "map.dot" file = "map.dot"
@ -198,7 +198,7 @@ tryScan r
Left _ -> return Nothing Left _ -> return Nothing
Right r' -> return $ Just r' Right r' -> return $ Just r'
pipedconfig cmd params = safely $ pipedconfig cmd params = safely $
pOpen ReadFromPipe cmd params $ pOpen ReadFromPipe cmd (toShell params) $
Git.hConfigRead r Git.hConfigRead r
configlist = configlist =
@ -208,8 +208,9 @@ tryScan r
let sshcmd = let sshcmd =
"cd " ++ shellEscape(Git.workTree r) ++ " && " ++ "cd " ++ shellEscape(Git.workTree r) ++ " && " ++
"git config --list" "git config --list"
liftIO $ pipedconfig "ssh" $ liftIO $ pipedconfig "ssh" $ map Param $
words sshoptions ++ [Git.urlHostFull r, sshcmd] words sshoptions ++
[Git.urlHostFull r, sshcmd]
-- First, try sshing and running git config manually, -- First, try sshing and running git config manually,
-- only fall back to git-annex-shell configlist if that -- only fall back to git-annex-shell configlist if that

View file

@ -56,7 +56,7 @@ remoteHasKey remote key present = do
g <- Annex.gitRepo g <- Annex.gitRepo
remoteuuid <- getUUID remote remoteuuid <- getUUID remote
logfile <- liftIO $ logChange g key remoteuuid status logfile <- liftIO $ logChange g key remoteuuid status
Annex.queue "add" ["--"] logfile Annex.queue "add" [Param "--"] logfile
where where
status = if present then ValuePresent else ValueMissing status = if present then ValuePresent else ValueMissing
@ -130,9 +130,10 @@ fromPerform src move key = do
fromCleanup :: Git.Repo -> Bool -> Key -> CommandCleanup fromCleanup :: Git.Repo -> Bool -> Key -> CommandCleanup
fromCleanup src True key = do fromCleanup src True key = do
ok <- Remotes.onRemote src (boolSystem, False) "dropkey" ok <- Remotes.onRemote src (boolSystem, False) "dropkey"
["--quiet", "--force", [ Params "--quiet --force"
"--backend=" ++ backendName key, , Param $ "--backend=" ++ backendName key
keyName key] , Param $ keyName key
]
-- better safe than sorry: assume the src dropped the key -- better safe than sorry: assume the src dropped the key
-- even if it seemed to fail; the failure could have occurred -- even if it seemed to fail; the failure could have occurred
-- after it really dropped it -- after it really dropped it

View file

@ -15,6 +15,7 @@ import qualified GitRepo as Git
import qualified Command.Add import qualified Command.Add
import qualified Command.Fix import qualified Command.Fix
import Messages import Messages
import Utility
command :: [Command] command :: [Command]
command = [Command "pre-commit" paramPath seek "run by git pre-commit hook"] 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 -- drop that and run command queued by Add.state to
-- stage the symlink -- stage the symlink
g <- Annex.gitRepo g <- Annex.gitRepo
liftIO $ Git.run g ["reset", "-q", "--", file] liftIO $ Git.run g "reset" [Params "-q --", File file]
Annex.queueRun Annex.queueRun
return True return True

View file

@ -36,7 +36,7 @@ perform file = do
ok <- getViaTmp key $ \dest -> do ok <- getViaTmp key $ \dest -> do
if dest /= file if dest /= file
then liftIO $ then liftIO $
boolSystem "mv" [utilityEscape file, utilityEscape dest] boolSystem "mv" [File file, File dest]
else return True else return True
if ok if ok
then return $ Just $ cleanup then return $ Just $ cleanup

View file

@ -58,7 +58,7 @@ cleanup file key = do
g <- Annex.gitRepo g <- Annex.gitRepo
liftIO $ removeFile file 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 -- git rm deletes empty directories; put them back
liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ createDirectoryIfMissing True (parentDir file)
@ -68,6 +68,6 @@ cleanup file key = do
-- Commit staged changes at end to avoid confusing the -- Commit staged changes at end to avoid confusing the
-- pre-commit hook if this file is later added back to -- pre-commit hook if this file is later added back to
-- git as a normal, non-annexed file. -- 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 return True

View file

@ -60,7 +60,7 @@ logStatus key status = do
g <- Annex.gitRepo g <- Annex.gitRepo
u <- getUUID g u <- getUUID g
logfile <- liftIO $ logChange g key u status 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, {- Runs an action, passing it a temporary filename to download,
- and if the action succeeds, moves the temp file into - and if the action succeeds, moves the temp file into

View file

@ -20,14 +20,12 @@ copyFile src dest = do
e <- doesFileExist dest e <- doesFileExist dest
when e $ when e $
removeFile dest removeFile dest
boolSystem "cp" opts boolSystem "cp" [params, File src, File dest]
where where
opts = if SysConfig.cp_reflink_auto params = if SysConfig.cp_reflink_auto
then ["--reflink=auto", src', dest'] then Params "--reflink=auto"
else if SysConfig.cp_a else if SysConfig.cp_a
then ["-a", src', dest'] then Params "-a"
else if SysConfig.cp_p else if SysConfig.cp_p
then ["-p", src', dest'] then Params "-p"
else [src', dest'] else Params ""
src' = utilityEscape src
dest' = utilityEscape dest

View file

@ -17,6 +17,7 @@ import System.IO
import System.Cmd.Utils import System.Cmd.Utils
import Data.String.Utils import Data.String.Utils
import Control.Monad (unless, forM_) import Control.Monad (unless, forM_)
import Utility
import qualified GitRepo as Git 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. -} - is not included, and must be able to be appended after the params. -}
data Action = Action { data Action = Action {
getSubcommand :: String, getSubcommand :: String,
getParams :: [String] getParams :: [ShellParam]
} deriving (Show, Eq, Ord) } deriving (Show, Eq, Ord)
{- A queue of actions to perform (in any order) on a git repository, {- A queue of actions to perform (in any order) on a git repository,
@ -37,7 +38,7 @@ empty :: Queue
empty = M.empty empty = M.empty
{- Adds an action to a queue. -} {- 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 add queue subcommand params file = M.insertWith (++) action [file] queue
where where
action = Action subcommand params action = Action subcommand params
@ -55,7 +56,7 @@ runAction :: Git.Repo -> Action -> [FilePath] -> IO ()
runAction repo action files = do runAction repo action files = do
unless (null files) runxargs unless (null files) runxargs
where where
runxargs = pOpen WriteToPipe "xargs" ("-0":gitcmd) feedxargs runxargs = pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs
gitcmd = "git" : Git.gitCommandLine repo params = toShell $ Git.gitCommandLine repo
(getSubcommand action:getParams action) (Param (getSubcommand action):getParams action)
feedxargs h = hPutStr h $ join "\0" files feedxargs h = hPutStr h $ join "\0" files

View file

@ -243,16 +243,18 @@ urlPath Repo { location = Url u } = uriPath u
urlPath repo = assertUrl repo $ error "internal" urlPath repo = assertUrl repo $ error "internal"
{- Constructs a git command line operating on the specified repo. -} {- 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 = gitCommandLine repo@(Repo { location = Dir d} ) params =
-- force use of specified repo via --git-dir and --work-tree -- 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" gitCommandLine repo _ = assertLocal repo $ error "internal"
{- Runs git in the specified repo, throwing an error if it fails. -} {- Runs git in the specified repo, throwing an error if it fails. -}
run :: Repo -> [String] -> IO () run :: Repo -> String -> [ShellParam] -> IO ()
run repo params = assertLocal repo $ do run repo subcommand params = assertLocal repo $ do
ok <- boolSystem "git" (gitCommandLine repo params) ok <- boolSystem "git" (gitCommandLine repo ((Param subcommand):params))
unless ok $ error $ "git " ++ show params ++ " failed" unless ok $ error $ "git " ++ show params ++ " failed"
{- Runs a git subcommand and returns it output, lazily. {- 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 - Note that this leaves the git process running, and so zombies will
- result unless reap is called. - result unless reap is called.
-} -}
pipeRead :: Repo -> [String] -> IO String pipeRead :: Repo -> [ShellParam] -> IO String
pipeRead repo params = assertLocal repo $ do pipeRead repo params = assertLocal repo $ do
(_, s) <- pipeFrom "git" (gitCommandLine repo params) (_, s) <- pipeFrom "git" $ toShell $ gitCommandLine repo params
return s return s
{- Reaps any zombie git processes. -} {- Reaps any zombie git processes. -}
@ -277,13 +279,13 @@ reap = do
{- Scans for files that are checked into git at the specified locations. -} {- Scans for files that are checked into git at the specified locations. -}
inRepo :: Repo -> [FilePath] -> IO [FilePath] inRepo :: Repo -> [FilePath] -> IO [FilePath]
inRepo repo l = pipeNullSplit repo $ 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, {- Scans for files at the specified locations that are not checked into git,
- and not gitignored. -} - and not gitignored. -}
notInRepo :: Repo -> [FilePath] -> IO [FilePath] notInRepo :: Repo -> [FilePath] -> IO [FilePath]
notInRepo repo l = pipeNullSplit repo $ 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. -} {- Returns a list of all files that are staged for commit. -}
stagedFiles :: Repo -> [FilePath] -> IO [FilePath] 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, {- Returns a list of the files, staged for commit, that are being added,
- moved, or changed (but not deleted), from the specified locations. -} - moved, or changed (but not deleted), from the specified locations. -}
stagedFilesNotDeleted :: Repo -> [FilePath] -> IO [FilePath] 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 stagedFiles' repo l middle = pipeNullSplit repo $ start ++ middle ++ end
where where
start = ["diff", "--cached", "--name-only", "-z"] start = [Params "diff --cached --name-only -z"]
end = ["--"] ++ l end = [Param "--"] ++ map File l
{- Returns a list of files that have unstaged changes. -} {- Returns a list of files that have unstaged changes. -}
changedUnstagedFiles :: Repo -> [FilePath] -> IO [FilePath] changedUnstagedFiles :: Repo -> [FilePath] -> IO [FilePath]
changedUnstagedFiles repo l = pipeNullSplit repo $ 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 {- Returns a list of the files in the specified locations that are staged
- for commit, and whose type has changed. -} - for commit, and whose type has changed. -}
typeChangedStagedFiles :: Repo -> [FilePath] -> IO [FilePath] 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 {- Returns a list of the files in the specified locations whose type has
- changed. Files only staged for commit will not be included. -} - changed. Files only staged for commit will not be included. -}
typeChangedFiles :: Repo -> [FilePath] -> IO [FilePath] typeChangedFiles :: Repo -> [FilePath] -> IO [FilePath]
typeChangedFiles repo l = typeChangedFiles' repo l [] 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 typeChangedFiles' repo l middle = pipeNullSplit repo $ start ++ middle ++ end
where where
start = ["diff", "--name-only", "--diff-filter=T", "-z"] start = [Params "diff --name-only --diff-filter=T -z"]
end = ["--"] ++ l end = [Param "--"] ++ map File l
{- Reads null terminated output of a git command (as enabled by the -z {- Reads null terminated output of a git command (as enabled by the -z
- parameter), and splits it into a list of files. -} - parameter), and splits it into a list of files. -}
pipeNullSplit :: Repo -> [String] -> IO [FilePath] pipeNullSplit :: Repo -> [ShellParam] -> IO [FilePath]
pipeNullSplit repo params = do pipeNullSplit repo params = do
fs0 <- pipeRead repo params fs0 <- pipeRead repo params
return $ split0 fs0 return $ split0 fs0
@ -408,11 +410,11 @@ checkAttr repo attr files = do
-- directory. Convert to absolute, and then convert the filenames -- directory. Convert to absolute, and then convert the filenames
-- in its output back to relative. -- in its output back to relative.
absfiles <- mapM absPath files absfiles <- mapM absPath files
(_, s) <- pipeBoth "git" params $ join "\0" absfiles (_, s) <- pipeBoth "git" (toShell params) $ join "\0" absfiles
cwd <- getCurrentDirectory cwd <- getCurrentDirectory
return $ map (topair $ cwd++"/") $ lines s return $ map (topair $ cwd++"/") $ lines s
where 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) topair cwd l = (relfile, value)
where where
relfile relfile

View file

@ -64,7 +64,7 @@ tryGitConfigRead r
Left _ -> return r Left _ -> return r
Right r' -> return r' Right r' -> return r'
pipedconfig cmd params = safely $ pipedconfig cmd params = safely $
pOpen ReadFromPipe cmd params $ pOpen ReadFromPipe cmd (toShell params) $
Git.hConfigRead r Git.hConfigRead r
store a = do store a = do
r' <- a r' <- a
@ -154,7 +154,7 @@ inAnnex r key = if Git.repoIsUrl r
checkremote = do checkremote = do
showNote ("checking " ++ Git.repoDescribe r ++ "...") showNote ("checking " ++ Git.repoDescribe r ++ "...")
inannex <- onRemote r (boolSystem, False) "inannex" inannex <- onRemote r (boolSystem, False) "inannex"
["--backend=" ++ backendName key, keyName key] [Param ("--backend=" ++ backendName key), Param (keyName key)]
return $ Right inannex return $ Right inannex
{- Cost Ordered list of remotes. -} {- 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 {- Generates rsync parameters that ssh to the remote and asks it
- to either receive or send the key's content. -} - 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 rsyncParams r sending key file = do
-- Note that the command is terminated with "--", because Just (shellcmd, shellparams) <- git_annex_shell r
-- rsync will tack on its own options to this command,
-- and they need to be ignored.
shellcmd <- git_annex_shell r
(if sending then "sendkey" else "recvkey") (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. -- Convert the ssh command into rsync command line.
let eparam = rsyncShell $ fromJust shellcmd let eparam = rsyncShell (Param shellcmd:shellparams)
o <- repoConfig r "rsync-options" "" o <- repoConfig r "rsync-options" ""
let base = options ++ words o ++ eparam let base = options ++ map Param (words o) ++ eparam
if sending if sending
then return $ base ++ [dummy, file] then return $ base ++ [dummy, File file]
else return $ base ++ [file, dummy] else return $ base ++ [File file, dummy]
where where
-- inplace makes rsync resume partial files -- inplace makes rsync resume partial files
options = ["-p", "--progress", "--inplace"] options = [Params "-p --progress --inplace"]
-- the rsync shell parameter controls where rsync -- the rsync shell parameter controls where rsync
-- goes, so the source/dest parameter can be a dummy value, -- goes, so the source/dest parameter can be a dummy value,
-- that just enables remote rsync mode. -- that just enables remote rsync mode.
dummy = ":" dummy = Param ":"
{- Uses a supplied function to run a git-annex-shell command on a remote. {- 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. -} - a specified error value. -}
onRemote onRemote
:: Git.Repo :: Git.Repo
-> (String -> [String] -> IO a, a) -> (FilePath -> [ShellParam] -> IO a, a)
-> String -> String
-> [String] -> [ShellParam]
-> Annex a -> Annex a
onRemote r (with, errorval) command params = do onRemote r (with, errorval) command params = do
s <- git_annex_shell r command params s <- git_annex_shell r command params
case s of case s of
Just shellcmd -> liftIO $ with (shellcmd !! 0) (tail shellcmd) Just (c, ps) -> liftIO $ with c ps
Nothing -> return errorval Nothing -> return errorval
{- Generates parameters to run a git-annex-shell command on a remote. -} {- 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 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 | Git.repoIsSsh r = do
sshoptions <- repoConfig r "ssh-options" "" sshoptions <- repoConfig r "ssh-options" ""
return $ Just $ ["ssh"] ++ words sshoptions ++ return $ Just ("ssh", map Param (words sshoptions) ++
[Git.urlHostFull r, sshcmd] [Param (Git.urlHostFull r), Param sshcmd])
| otherwise = return Nothing | otherwise = return Nothing
where where
dir = Git.workTree r dir = Git.workTree r
shellcmd = "git-annex-shell" shellcmd = "git-annex-shell"
shellopts = command:dir:params shellopts = (Param command):(File dir):params
sshcmd = shellcmd ++ " " ++ unwords (map shellEscape shellopts) sshcmd = shellcmd ++ " " ++
unwords (map shellEscape $ toShell shellopts)
{- Looks up a per-remote config option in git config. {- Looks up a per-remote config option in git config.
- Failing that, tries looking for a global config option. -} - Failing that, tries looking for a global config option. -}

View file

@ -14,8 +14,8 @@ import Utility
{- Generates parameters to make rsync use a specified command as its remote {- Generates parameters to make rsync use a specified command as its remote
- shell. -} - shell. -}
rsyncShell :: [String] -> [String] rsyncShell :: [ShellParam] -> [ShellParam]
rsyncShell command = ["-e", unwords $ map escape command] rsyncShell command = [Param "-e", Param $ unwords $ map escape (toShell command)]
where where
{- rsync requires some weird, non-shell like quoting in {- rsync requires some weird, non-shell like quoting in
- here. A doubled single quote inside the single quoted - 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. -} {- Runs rsync in server mode to send a file, and exits. -}
rsyncServerSend :: FilePath -> IO () rsyncServerSend :: FilePath -> IO ()
rsyncServerSend file = rsyncExec $ rsyncServerSend file = rsyncExec $
rsyncServerParams ++ ["--sender", utilityEscape file] rsyncServerParams ++ [Param "--sender", File file]
{- Runs rsync in server mode to receive a file. -} {- Runs rsync in server mode to receive a file. -}
rsyncServerReceive :: FilePath -> IO Bool rsyncServerReceive :: FilePath -> IO Bool
rsyncServerReceive file = rsync $ rsyncServerParams ++ [utilityEscape file] rsyncServerReceive file = rsync $ rsyncServerParams ++ [File file]
rsyncServerParams :: [String] rsyncServerParams :: [ShellParam]
rsyncServerParams = rsyncServerParams =
[ "--server" [ Param "--server"
, "-p" -- preserve permissions -- preserve permissions
, "--inplace" -- allow resuming of transfers of big files , Param "-p"
, "-e.Lsf", "." -- other options rsync normally uses in server mode -- 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 :: [ShellParam] -> IO Bool
rsync params = boolSystem "rsync" params rsync = boolSystem "rsync"
rsyncExec :: [String] -> IO () rsyncExec :: [ShellParam] -> IO ()
rsyncExec params = executeFile "rsync" True params Nothing rsyncExec params = executeFile "rsync" True (toShell params) Nothing

View file

@ -81,8 +81,12 @@ trustSet uuid level = do
logfile <- trustLog logfile <- trustLog
liftIO $ safeWriteFile logfile (serialize m') liftIO $ safeWriteFile logfile (serialize m')
g <- Annex.gitRepo g <- Annex.gitRepo
liftIO $ Git.run g ["add", logfile] liftIO $ Git.run g "add" [File logfile]
liftIO $ Git.run g ["commit", "-q", "-m", "git annex trust change", logfile] liftIO $ Git.run g "commit"
[ Params "-q -m"
, Param "git annex trust change"
, File logfile
]
where where
serialize m = unlines $ map showpair $ M.toList m serialize m = unlines $ map showpair $ M.toList m
showpair (u, t) = u ++ " " ++ show t showpair (u, t) = u ++ " " ++ show t

View file

@ -22,6 +22,7 @@ import qualified Annex
import qualified Backend import qualified Backend
import Messages import Messages
import Version import Version
import Utility
{- Uses the annex.version git config setting to automate upgrades. -} {- Uses the annex.version git config setting to automate upgrades. -}
upgrade :: Annex Bool upgrade :: Annex Bool
@ -62,7 +63,7 @@ upgradeFrom0 = do
link <- calcGitLink f k link <- calcGitLink f k
liftIO $ removeFile f liftIO $ removeFile f
liftIO $ createSymbolicLink link f liftIO $ createSymbolicLink link f
Annex.queue "add" ["--"] f Annex.queue "add" [Param "--"] f
fixlinks fs fixlinks fs
getKeysPresent0' :: FilePath -> Annex [Key] getKeysPresent0' :: FilePath -> Annex [Key]

View file

@ -1,6 +1,6 @@
{- git-annex utility functions {- 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. - 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 data ShellParam = Params String | Param String | File FilePath
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
{- When converting ShellParam to a String in preparation for passing to {- Used to pass a list of ShellParams to a function that runs
- a shell command, Files that start with a dash are modified to avoid - a shell command and expects Strings. -}
- the shell command interpreting them as options. -}
toShell :: [ShellParam] -> [String] toShell :: [ShellParam] -> [String]
toShell l = concat $ map unwrap l toShell l = concat $ map unwrap l
where where
unwrap (Param s) = [s] unwrap (Param s) = [s]
unwrap (Params s) = filter (not . null) (split " " 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] unwrap (File s) = [s]
{- Run a system command, and returns True or False {- Run a system command, and returns True or False
- if it succeeded or failed. - if it succeeded or failed.

View file

@ -66,7 +66,7 @@ builtin cmd dir params = do
external :: [String] -> IO () external :: [String] -> IO ()
external params = do external params = do
ret <- boolSystem "git-shell" ("-c":(filterparams params)) ret <- boolSystem "git-shell" $ map Param $ ("-c":filterparams params)
when (not ret) $ when (not ret) $
error "git-shell failed" error "git-shell failed"

36
test.hs
View file

@ -105,8 +105,8 @@ test_add = "git-annex add" ~: TestList [basic, sha1dup]
git_annex "add" ["-q", annexedfile] @? "add failed" git_annex "add" ["-q", annexedfile] @? "add failed"
annexed_present annexedfile annexed_present annexedfile
writeFile ingitfile $ content ingitfile writeFile ingitfile $ content ingitfile
Utility.boolSystem "git" ["add", ingitfile] @? "git add failed" Utility.boolSystem "git" [Utility.Param "add", Utility.File ingitfile] @? "git add 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"
git_annex "add" ["-q", ingitfile] @? "add ingitfile should be no-op" git_annex "add" ["-q", ingitfile] @? "add ingitfile should be no-op"
unannexed ingitfile unannexed ingitfile
sha1dup = TestCase $ intmpclonerepo $ do sha1dup = TestCase $ intmpclonerepo $ do
@ -125,7 +125,7 @@ test_setkey = "git-annex setkey/fromkey" ~: TestCase $ inmainrepo $ do
let sha1 = BackendTypes.keyName $ fromJust r let sha1 = BackendTypes.keyName $ fromJust r
git_annex "setkey" ["-q", "--backend", "SHA1", "--key", sha1, tmp] @? "setkey failed" git_annex "setkey" ["-q", "--backend", "SHA1", "--key", sha1, tmp] @? "setkey failed"
git_annex "fromkey" ["-q", "--backend", "SHA1", "--key", sha1, sha1annexedfile] @? "fromkey 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 annexed_present sha1annexedfile
where where
tmp = "tmpfile" tmp = "tmpfile"
@ -139,7 +139,7 @@ test_unannex = "git-annex unannex" ~: TestList [nocopy, withcopy]
annexed_notpresent annexedfile annexed_notpresent annexedfile
withcopy = "with content" ~: intmpclonerepo $ do withcopy = "with content" ~: intmpclonerepo $ do
git_annex "get" ["-q", annexedfile] @? "get failed" 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" @? "git commit of state failed"
annexed_present annexedfile annexed_present annexedfile
git_annex "unannex" ["-q", annexedfile, sha1annexedfile] @? "unannex failed" git_annex "unannex" ["-q", annexedfile, sha1annexedfile] @? "unannex failed"
@ -154,9 +154,9 @@ test_drop = "git-annex drop" ~: TestList [noremote, withremote, untrustedremote]
where where
noremote = "no remotes" ~: TestCase $ intmpclonerepo $ do noremote = "no remotes" ~: TestCase $ intmpclonerepo $ do
git_annex "get" ["-q", annexedfile] @? "get failed" 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" @? "git commit of state failed"
Utility.boolSystem "git" ["remote", "rm", "origin"] Utility.boolSystem "git" [Utility.Params "remote rm origin"]
@? "git remote rm origin failed" @? "git remote rm origin failed"
r <- git_annex "drop" ["-q", annexedfile] r <- git_annex "drop" ["-q", annexedfile]
not r @? "drop wrongly succeeded with no known copy of file" 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 then do
-- pre-commit depends on the file being -- pre-commit depends on the file being
-- staged, normally git commit does this -- 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 add of edited file failed"
git_annex "pre-commit" ["-q"] git_annex "pre-commit" ["-q"]
@? "pre-commit failed" @? "pre-commit failed"
else do 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" @? "git commit of edited file failed"
runchecks [checklink, checkunwritable] annexedfile runchecks [checklink, checkunwritable] annexedfile
c <- readFile 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" git_annex "fix" ["-q", annexedfile] @? "fix of present file failed"
annexed_present annexedfile annexed_present annexedfile
createDirectory subdir createDirectory subdir
Utility.boolSystem "git" ["mv", annexedfile, subdir] Utility.boolSystem "git" [Utility.Param "mv", Utility.File annexedfile, Utility.File subdir]
@? "git mv failed" @? "git mv failed"
git_annex "fix" ["-q", newfile] @? "fix of moved file failed" git_annex "fix" ["-q", newfile] @? "fix of moved file failed"
runchecks [checklink, checkunwritable] newfile runchecks [checklink, checkunwritable] newfile
@ -350,9 +350,9 @@ test_fsck = "git-annex fsck" ~: TestList [basicfsck, withlocaluntrusted, withrem
where where
basicfsck = TestCase $ intmpclonerepo $ do basicfsck = TestCase $ intmpclonerepo $ do
git_annex "fsck" ["-q"] @? "fsck failed" 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" 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 annexedfile
corrupt sha1annexedfile corrupt sha1annexedfile
withlocaluntrusted = TestCase $ intmpclonerepo $ do 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 "trust" ["-q", "."] @? "trust of current repo failed"
git_annex "fsck" ["-q", annexedfile] @? "fsck failed on file present in trusted repo" git_annex "fsck" ["-q", annexedfile] @? "fsck failed on file present in trusted repo"
withremoteuntrusted = TestCase $ intmpclonerepo $ do 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", annexedfile] @? "get failed"
git_annex "get" ["-q", sha1annexedfile] @? "get failed" git_annex "get" ["-q", sha1annexedfile] @? "get failed"
git_annex "fsck" ["-q"] @? "fsck failed with numcopies=2 and 2 copies" 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", annexedfile] @? "get of file failed"
git_annex "get" ["-q", sha1annexedfile] @? "get of file failed" git_annex "get" ["-q", sha1annexedfile] @? "get of file failed"
checkunused [] 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] 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] checkunused [annexedfilekey, sha1annexedfilekey]
-- good opportunity to test dropkey also -- good opportunity to test dropkey also
@ -511,10 +511,10 @@ setuprepo :: FilePath -> IO FilePath
setuprepo dir = do setuprepo dir = do
cleanup dir cleanup dir
ensuretmpdir 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 indir dir $ do
Utility.boolSystem "git" ["config", "user.name", "Test User"] @? "git config failed" Utility.boolSystem "git" [Utility.Params "config user.name", Utility.Param "Test User"] @? "git config failed"
Utility.boolSystem "git" ["config", "user.email", "test@example.com"] @? "git config failed" Utility.boolSystem "git" [Utility.Params "config user.email test@example.com"] @? "git config failed"
return dir return dir
-- clones are always done as local clones; we cannot test ssh clones -- 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 clonerepo old new = do
cleanup new cleanup new
ensuretmpdir 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" indir new $ git_annex "init" ["-q", new] @? "git annex init failed"
return new return new