{-# 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
data CommandParam
= Param String
| File FilePath
deriving (Eq, Show, Ord)
toCommand :: [CommandParam] -> [String]
toCommand = map toCommand'
toCommand' :: CommandParam -> String
toCommand' (Param s) = s
toCommand' (File s@(h:_))
| isAlphaNum h || h `elem` pathseps = s
| otherwise = "./" ++ s
where
pathseps = pathSeparator:"./"
toCommand' (File s) = s
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 }
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 }
shellWrap :: String -> String
shellWrap cmdline = "sh -c " ++ shellEscape cmdline
shellEscape :: String -> String
shellEscape f = "'" ++ escaped ++ "'"
where
escaped = intercalate "'\"'\"'" $ splitc '\'' f
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
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
segmentXargsOrdered :: [FilePath] -> [[FilePath]]
segmentXargsOrdered = reverse . map reverse . segmentXargsUnordered
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
maxlen = 10240