{- safely running shell commands - - Copyright 2010-2015 Joey Hess - - License: BSD-2-clause -} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.SafeCommand where import System.Exit import Utility.Process import Utility.Split import System.FilePath import Data.Char import Data.List import Control.Applicative import Prelude -- | Parameters that can be passed to a shell command. data CommandParam = Param String -- ^ A parameter | File FilePath -- ^ The name of a file 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 = map toCommand' toCommand' :: CommandParam -> String toCommand' (Param s) = 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. toCommand' (File s@(h:_)) | isAlphaNum h || h `elem` pathseps = s | otherwise = "./" ++ s where -- '/' is explicitly included because it's an alternative -- path separator on Windows. pathseps = pathSeparator:"./" toCommand' (File s) = s -- | Run a system command, and returns True or False if it succeeded or failed. -- -- This and other command running functions in this module log the commands -- run at debug level, using System.Log.Logger. boolSystem :: FilePath -> [CommandParam] -> IO Bool boolSystem command params = boolSystem' command params id boolSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO Bool boolSystem' command params mkprocess = dispatch <$> safeSystem' command params mkprocess where dispatch ExitSuccess = True dispatch _ = False boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool boolSystemEnv command params environ = boolSystem' command params $ \p -> p { env = environ } -- | Runs a system command, returning the exit status. safeSystem :: FilePath -> [CommandParam] -> IO ExitCode safeSystem command params = safeSystem' command params id safeSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO ExitCode safeSystem' command params mkprocess = do (_, _, _, pid) <- createProcess p waitForProcess pid where p = mkprocess $ proc command (toCommand params) safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode safeSystemEnv command params environ = safeSystem' command params $ \p -> p { env = environ } -- | 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 = intercalate "'\"'\"'" $ splitc '\'' 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_isomorphic_shellEscape :: String -> Bool prop_isomorphic_shellEscape s = [s] == (shellUnEscape . shellEscape) s prop_isomorphic_shellEscape_multiword :: [String] -> Bool prop_isomorphic_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s -- | Segments a list of filenames into groups that are all below the maximum -- command-line length limit. segmentXargsOrdered :: [FilePath] -> [[FilePath]] segmentXargsOrdered = reverse . map reverse . segmentXargsUnordered -- | Not preserving order is a little faster, and streams better when -- there are a great many filenames. segmentXargsUnordered :: [FilePath] -> [[FilePath]] segmentXargsUnordered l = go l [] 0 [] where go [] c _ r = (c:r) go (f:fs) c accumlen r | newlen > maxlen && len < 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 100k limit - of Linux (and OSX has a similar limit); - allows room for other parameters etc. Also allows for - eg, multibyte characters. -} maxlen = 10240