ebd778c519
A git pathspec is a filename, except when it starts with ':', it's taken to refer to a branch, etc. Rather than special case ':', any filename starting with anything unusual is prefixed with "./" This could have been a real mess to deal with, but luckily SafeCommand is already extensively used and so we know at the type level the difference between parameters that are files, and parameters that are command options. Testing did show that Git.Queue was not using SafeCommand on filenames fed to xargs. (Filenames starting with '-' worked before only because -- was used to separate filenames from options when calling eg git add.) The test suite now passes with filenames starting with ':'. However, I did not keep that change to it, because such filenames are probably not legal on windows, and I have enough ugly windows ifdefs in there as it is. This commit was sponsored by Otavio Salvador. Thanks!
118 lines
3.8 KiB
Haskell
118 lines
3.8 KiB
Haskell
{- safely running shell commands
|
|
-
|
|
- Copyright 2010-2013 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Utility.SafeCommand where
|
|
|
|
import System.Exit
|
|
import Utility.Process
|
|
import System.Process (env)
|
|
import Data.String.Utils
|
|
import Control.Applicative
|
|
import System.FilePath
|
|
import Data.Char
|
|
|
|
{- A type for parameters passed to a shell command. A command can
|
|
- be passed either some Params (multiple parameters can be included,
|
|
- whitespace-separated, or a single Param (for when parameters contain
|
|
- whitespace), or a File.
|
|
-}
|
|
data CommandParam = Params String | Param String | File FilePath
|
|
deriving (Eq, Show, Ord)
|
|
|
|
{- Used to pass a list of CommandParams to a function that runs
|
|
- a command and expects Strings. -}
|
|
toCommand :: [CommandParam] -> [String]
|
|
toCommand = concatMap unwrap
|
|
where
|
|
unwrap (Param s) = [s]
|
|
unwrap (Params s) = filter (not . null) (split " " s)
|
|
-- Files that start with a non-alphanumeric that is not a path
|
|
-- separator are modified to avoid the command interpreting them as
|
|
-- options or other special constructs.
|
|
unwrap (File s@(h:_))
|
|
| isAlphaNum h || h `elem` pathseps = [s]
|
|
| otherwise = ["./" ++ s]
|
|
unwrap (File s) = [s]
|
|
pathseps = [pathSeparator, '.']
|
|
|
|
{- Run a system command, and returns True or False
|
|
- if it succeeded or failed.
|
|
-}
|
|
boolSystem :: FilePath -> [CommandParam] -> IO Bool
|
|
boolSystem command params = boolSystemEnv command params Nothing
|
|
|
|
boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
|
|
boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ
|
|
where
|
|
dispatch ExitSuccess = True
|
|
dispatch _ = False
|
|
|
|
{- Runs a system command, returning the exit status. -}
|
|
safeSystem :: FilePath -> [CommandParam] -> IO ExitCode
|
|
safeSystem command params = safeSystemEnv command params Nothing
|
|
|
|
safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode
|
|
safeSystemEnv command params environ = do
|
|
(_, _, _, pid) <- createProcess (proc command $ toCommand params)
|
|
{ env = environ }
|
|
waitForProcess pid
|
|
|
|
{- Wraps a shell command line inside sh -c, allowing it to be run in a
|
|
- login shell that may not support POSIX shell, eg csh. -}
|
|
shellWrap :: String -> String
|
|
shellWrap cmdline = "sh -c " ++ shellEscape cmdline
|
|
|
|
{- Escapes a filename or other parameter to be safely able to be exposed to
|
|
- the shell.
|
|
-
|
|
- This method works for POSIX shells, as well as other shells like csh.
|
|
-}
|
|
shellEscape :: String -> String
|
|
shellEscape f = "'" ++ escaped ++ "'"
|
|
where
|
|
-- replace ' with '"'"'
|
|
escaped = join "'\"'\"'" $ split "'" f
|
|
|
|
{- Unescapes a set of shellEscaped words or filenames. -}
|
|
shellUnEscape :: String -> [String]
|
|
shellUnEscape [] = []
|
|
shellUnEscape s = word : shellUnEscape rest
|
|
where
|
|
(word, rest) = findword "" s
|
|
findword w [] = (w, "")
|
|
findword w (c:cs)
|
|
| c == ' ' = (w, cs)
|
|
| c == '\'' = inquote c w cs
|
|
| c == '"' = inquote c w cs
|
|
| otherwise = findword (w++[c]) cs
|
|
inquote _ w [] = (w, "")
|
|
inquote q w (c:cs)
|
|
| c == q = findword w cs
|
|
| otherwise = inquote q (w++[c]) cs
|
|
|
|
{- For quickcheck. -}
|
|
prop_idempotent_shellEscape :: String -> Bool
|
|
prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s
|
|
prop_idempotent_shellEscape_multiword :: [String] -> Bool
|
|
prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s
|
|
|
|
{- Segements a list of filenames into groups that are all below the manximum
|
|
- command-line length limit. Does not preserve order. -}
|
|
segmentXargs :: [FilePath] -> [[FilePath]]
|
|
segmentXargs l = go l [] 0 []
|
|
where
|
|
go [] c _ r = c:r
|
|
go (f:fs) c accumlen r
|
|
| len < maxlen && newlen > maxlen = go (f:fs) [] 0 (c:r)
|
|
| otherwise = go fs (f:c) newlen r
|
|
where
|
|
len = length f
|
|
newlen = accumlen + len
|
|
|
|
{- 10k of filenames per command, well under Linux's 20k limit;
|
|
- allows room for other parameters etc. -}
|
|
maxlen = 10240
|