1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
{- safely running shell commands
-
- Copyright 2010-2015 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.SafeCommand where
import System.Exit
import Utility.Process
import Data.String.Utils
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 unwrap
where
unwrap (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.
unwrap (File s@(h:_))
| isAlphaNum h || h `elem` pathseps = s
| otherwise = "./" ++ s
unwrap (File s) = s
-- '/' is explicitly included because it's an alternative
-- path separator on Windows.
pathseps = pathSeparator:"./"
-- | 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 "'\"'\"'" $ 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_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
|
