This commit is contained in:
Joey Hess 2011-02-28 16:25:31 -04:00
parent fcdc4797a9
commit 4cd96ad2db
8 changed files with 36 additions and 36 deletions

View file

@ -92,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 -> [ShellParam] -> FilePath -> Annex () queue :: String -> [CommandParam] -> FilePath -> Annex ()
queue command params file = do queue command params file = do
state <- get state <- get
let q = repoqueue state let q = repoqueue state

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" (toShell [File file]) $ \h -> do liftIO $ pOpen ReadFromPipe "sha1sum" (toCommand [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

@ -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 (toShell params) $ pOpen ReadFromPipe cmd (toCommand params) $
Git.hConfigRead r Git.hConfigRead r
configlist = configlist =

View file

@ -25,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 :: [ShellParam] getParams :: [CommandParam]
} 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,
@ -38,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 -> [ShellParam] -> FilePath -> Queue add :: Queue -> String -> [CommandParam] -> 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
@ -57,6 +57,6 @@ runAction repo action files = do
unless (null files) runxargs unless (null files) runxargs
where where
runxargs = pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs runxargs = pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs
params = toShell $ Git.gitCommandLine repo params = toCommand $ Git.gitCommandLine repo
(Param (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,7 +243,7 @@ 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 -> [ShellParam] -> [ShellParam] gitCommandLine :: Repo -> [CommandParam] -> [CommandParam]
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
[ Param ("--git-dir=" ++ d ++ "/" ++ gitDir repo) [ Param ("--git-dir=" ++ d ++ "/" ++ gitDir repo)
@ -252,7 +252,7 @@ gitCommandLine repo@(Repo { location = Dir 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 -> [ShellParam] -> IO () run :: Repo -> String -> [CommandParam] -> IO ()
run repo subcommand params = assertLocal repo $ do run repo subcommand params = assertLocal repo $ do
ok <- boolSystem "git" (gitCommandLine repo ((Param subcommand):params)) ok <- boolSystem "git" (gitCommandLine repo ((Param subcommand):params))
unless ok $ error $ "git " ++ show params ++ " failed" unless ok $ error $ "git " ++ show params ++ " failed"
@ -262,9 +262,9 @@ run repo subcommand 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 -> [ShellParam] -> IO String pipeRead :: Repo -> [CommandParam] -> IO String
pipeRead repo params = assertLocal repo $ do pipeRead repo params = assertLocal repo $ do
(_, s) <- pipeFrom "git" $ toShell $ gitCommandLine repo params (_, s) <- pipeFrom "git" $ toCommand $ gitCommandLine repo params
return s return s
{- Reaps any zombie git processes. -} {- Reaps any zombie git processes. -}
@ -296,7 +296,7 @@ stagedFiles repo l = stagedFiles' repo l []
stagedFilesNotDeleted :: Repo -> [FilePath] -> IO [FilePath] stagedFilesNotDeleted :: Repo -> [FilePath] -> IO [FilePath]
stagedFilesNotDeleted repo l = stagedFiles' repo l [Param "--diff-filter=ACMRT"] stagedFilesNotDeleted repo l = stagedFiles' repo l [Param "--diff-filter=ACMRT"]
stagedFiles' :: Repo -> [FilePath] -> [ShellParam] -> IO [FilePath] stagedFiles' :: Repo -> [FilePath] -> [CommandParam] -> IO [FilePath]
stagedFiles' repo l middle = pipeNullSplit repo $ start ++ middle ++ end stagedFiles' repo l middle = pipeNullSplit repo $ start ++ middle ++ end
where where
start = [Params "diff --cached --name-only -z"] start = [Params "diff --cached --name-only -z"]
@ -317,7 +317,7 @@ typeChangedStagedFiles repo l = typeChangedFiles' repo l [Param "--cached"]
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] -> [ShellParam] -> IO [FilePath] typeChangedFiles' :: Repo -> [FilePath] -> [CommandParam] -> IO [FilePath]
typeChangedFiles' repo l middle = pipeNullSplit repo $ start ++ middle ++ end typeChangedFiles' repo l middle = pipeNullSplit repo $ start ++ middle ++ end
where where
start = [Params "diff --name-only --diff-filter=T -z"] start = [Params "diff --name-only --diff-filter=T -z"]
@ -325,7 +325,7 @@ typeChangedFiles' repo l middle = pipeNullSplit repo $ start ++ middle ++ end
{- 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 -> [ShellParam] -> IO [FilePath] pipeNullSplit :: Repo -> [CommandParam] -> IO [FilePath]
pipeNullSplit repo params = do pipeNullSplit repo params = do
fs0 <- pipeRead repo params fs0 <- pipeRead repo params
return $ split0 fs0 return $ split0 fs0
@ -410,7 +410,7 @@ 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" (toShell params) $ join "\0" absfiles (_, s) <- pipeBoth "git" (toCommand params) $ join "\0" absfiles
cwd <- getCurrentDirectory cwd <- getCurrentDirectory
return $ map (topair $ cwd++"/") $ lines s return $ map (topair $ cwd++"/") $ lines s
where where

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 (toShell params) $ pOpen ReadFromPipe cmd (toCommand params) $
Git.hConfigRead r Git.hConfigRead r
store a = do store a = do
r' <- a r' <- a
@ -263,7 +263,7 @@ 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 [ShellParam] rsyncParams :: Git.Repo -> Bool -> Key -> FilePath -> Annex [CommandParam]
rsyncParams r sending key file = do rsyncParams r sending key file = do
Just (shellcmd, shellparams) <- git_annex_shell r Just (shellcmd, shellparams) <- git_annex_shell r
(if sending then "sendkey" else "recvkey") (if sending then "sendkey" else "recvkey")
@ -295,9 +295,9 @@ rsyncParams r sending key file = do
- a specified error value. -} - a specified error value. -}
onRemote onRemote
:: Git.Repo :: Git.Repo
-> (FilePath -> [ShellParam] -> IO a, a) -> (FilePath -> [CommandParam] -> IO a, a)
-> String -> String
-> [ShellParam] -> [CommandParam]
-> 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
@ -306,7 +306,7 @@ onRemote r (with, errorval) command params = do
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 -> [ShellParam] -> Annex (Maybe (FilePath, [ShellParam])) git_annex_shell :: Git.Repo -> String -> [CommandParam] -> Annex (Maybe (FilePath, [CommandParam]))
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
@ -319,7 +319,7 @@ git_annex_shell r command params
shellcmd = "git-annex-shell" shellcmd = "git-annex-shell"
shellopts = (Param command):(File dir):params shellopts = (Param command):(File dir):params
sshcmd = shellcmd ++ " " ++ sshcmd = shellcmd ++ " " ++
unwords (map shellEscape $ toShell shellopts) unwords (map shellEscape $ toCommand 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 :: [ShellParam] -> [ShellParam] rsyncShell :: [CommandParam] -> [CommandParam]
rsyncShell command = [Param "-e", Param $ unwords $ map escape (toShell command)] rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand 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
@ -31,7 +31,7 @@ rsyncServerSend file = rsyncExec $
rsyncServerReceive :: FilePath -> IO Bool rsyncServerReceive :: FilePath -> IO Bool
rsyncServerReceive file = rsync $ rsyncServerParams ++ [File file] rsyncServerReceive file = rsync $ rsyncServerParams ++ [File file]
rsyncServerParams :: [ShellParam] rsyncServerParams :: [CommandParam]
rsyncServerParams = rsyncServerParams =
[ Param "--server" [ Param "--server"
-- preserve permissions -- preserve permissions
@ -42,8 +42,8 @@ rsyncServerParams =
, Params "-e.Lsf ." , Params "-e.Lsf ."
] ]
rsync :: [ShellParam] -> IO Bool rsync :: [CommandParam] -> IO Bool
rsync = boolSystem "rsync" rsync = boolSystem "rsync"
rsyncExec :: [ShellParam] -> IO () rsyncExec :: [CommandParam] -> IO ()
rsyncExec params = executeFile "rsync" True (toShell params) Nothing rsyncExec params = executeFile "rsync" True (toCommand params) Nothing

View file

@ -6,8 +6,8 @@
-} -}
module Utility ( module Utility (
ShellParam(..), CommandParam(..),
toShell, toCommand,
hGetContentsStrict, hGetContentsStrict,
readFileStrict, readFileStrict,
parentDir, parentDir,
@ -47,18 +47,18 @@ import Control.Monad (liftM2)
- whitespace-separated, or a single Param (for when parameters contain - whitespace-separated, or a single Param (for when parameters contain
- whitespace), or a File. - whitespace), or a File.
-} -}
data ShellParam = Params String | Param String | File FilePath data CommandParam = Params String | Param String | File FilePath
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
{- Used to pass a list of ShellParams to a function that runs {- Used to pass a list of CommandParams to a function that runs
- a shell command and expects Strings. -} - a command and expects Strings. -}
toShell :: [ShellParam] -> [String] toCommand :: [CommandParam] -> [String]
toShell l = concat $ map unwrap l toCommand 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 -- Files that start with a dash are modified to avoid
-- the shell command interpreting them as options. -- the command interpreting them as options.
unwrap (File ('-':s)) = ["./-" ++ s] unwrap (File ('-':s)) = ["./-" ++ s]
unwrap (File s) = [s] unwrap (File s) = [s]
@ -67,7 +67,7 @@ toShell l = concat $ map unwrap l
- -
- SIGINT(ctrl-c) is allowed to propigate and will terminate the program. - SIGINT(ctrl-c) is allowed to propigate and will terminate the program.
-} -}
boolSystem :: FilePath -> [ShellParam] -> IO Bool boolSystem :: FilePath -> [CommandParam] -> IO Bool
boolSystem command params = do boolSystem command params = do
-- Going low-level because all the high-level system functions -- Going low-level because all the high-level system functions
-- block SIGINT etc. We need to block SIGCHLD, but allow -- block SIGINT etc. We need to block SIGCHLD, but allow
@ -88,7 +88,7 @@ boolSystem command params = do
setSignalMask oldset setSignalMask oldset
childaction oldint oldset = do childaction oldint oldset = do
restoresignals oldint oldset restoresignals oldint oldset
executeFile command True (toShell params) Nothing executeFile command True (toCommand params) Nothing
{- Escapes a filename to be safely able to be exposed to the shell. -} {- Escapes a filename to be safely able to be exposed to the shell. -}
shellEscape :: FilePath -> String shellEscape :: FilePath -> String