split groups of related functions out of Utility

.gitignore

@@ -13,7 +13,7 @@ doc/.ikiwiki
 html
 *.tix
 .hpc
-Touch.hs
+Utility/Touch.hs
-StatFS.hs
+Utility/StatFS.hs
 Remote/S3.hs
 dist

AnnexQueue.hs

@@ -17,7 +17,7 @@ import Control.Monad (when, unless)
 import Annex
 import Messages
 import qualified Git.Queue
-import Utility
+import Utility.SafeCommand
 
 {- Adds a git command to the queue. -}
 add :: String -> [CommandParam] -> [FilePath] -> Annex ()

Backend/SHA.hs

@@ -23,7 +23,7 @@ import Content
 import Types
 import Types.Backend
 import Types.Key
-import Utility
+import Utility.SafeCommand
 import qualified Build.SysConfig as SysConfig
 
 type SHASize = Int

Branch.hs

@@ -37,6 +37,8 @@ import qualified Git
 import qualified Git.UnionMerge
 import qualified Annex
 import Utility
+import Utility.Conditional
+import Utility.SafeCommand
 import Types
 import Messages
 import Locations

Command/Add.hs

@@ -23,8 +23,9 @@ import LocationLog
 import Types
 import Content
 import Messages
-import Utility
+import Utility.Conditional
 import Utility.Touch
+import Utility.SafeCommand
 import Locations
 
 command :: [Command]

Command/AddUrl.hs

@@ -23,7 +23,7 @@ import Messages
 import Content
 import PresenceLog
 import Locations
-import Utility
+import Utility.Path
 
 command :: [Command]
 command = [repoCommand "addurl" paramPath seek "add urls to annex"]

Command/Drop.hs

@@ -15,6 +15,7 @@ import Types
 import Content
 import Messages
 import Utility
+import Utility.Conditional
 import Trust
 import Config
 

Command/DropUnused.hs

@@ -22,7 +22,7 @@ import qualified Command.Move
 import qualified Remote
 import qualified Git
 import Types.Key
-import Utility
+import Utility.Conditional
 
 type UnusedMap = M.Map String Key
 

Command/Find.hs

@@ -11,7 +11,7 @@ import Control.Monad.State (liftIO)
 
 import Command
 import Content
-import Utility
+import Utility.Conditional
 
 command :: [Command]
 command = [repoCommand "find" (paramOptional $ paramRepeating paramPath) seek

Command/Fix.hs

@@ -13,7 +13,8 @@ import System.Directory
 
 import Command
 import qualified AnnexQueue
-import Utility
+import Utility.Path
+import Utility.SafeCommand
 import Content
 import Messages
 

Command/FromKey.hs

@@ -14,10 +14,11 @@ import Control.Monad (unless)
 
 import Command
 import qualified AnnexQueue
-import Utility
+import Utility.SafeCommand
 import Content
 import Messages
 import Types.Key
+import Utility.Path
 
 command :: [Command]
 command = [repoCommand "fromkey" paramPath seek

Command/Fsck.hs

@@ -27,6 +27,7 @@ import LocationLog
 import Locations
 import Trust
 import Utility.DataUnits
+import Utility.Path
 import Config
 
 command :: [Command]

Command/Lock.hs

@@ -13,7 +13,7 @@ import System.Directory
 import Command
 import Messages
 import qualified AnnexQueue
-import Utility
+import Utility.SafeCommand
 	
 command :: [Command]
 command = [repoCommand "lock" paramPath seek "undo unlock command"]

Command/Map.hs

@@ -19,7 +19,7 @@ import qualified Annex
 import qualified Git
 import Messages
 import Types
-import Utility
+import Utility.SafeCommand
 import UUID
 import Trust
 import Utility.Ssh

Command/Migrate.hs

@@ -20,7 +20,7 @@ import Locations
 import Types
 import Content
 import Messages
-import Utility
+import Utility.Conditional
 import qualified Command.Add
 
 command :: [Command]

Command/RecvKey.hs

@@ -13,8 +13,8 @@ import System.Exit
 import Command
 import CmdLine
 import Content
-import Utility
 import Utility.RsyncFile
+import Utility.Conditional
 
 command :: [Command]
 command = [repoCommand "recvkey" paramKey seek

Command/SendKey.hs

@@ -14,8 +14,8 @@ import Locations
 import qualified Annex
 import Command
 import Content
-import Utility
 import Utility.RsyncFile
+import Utility.Conditional
 import Messages
 
 command :: [Command]

Command/SetKey.hs

@@ -10,7 +10,7 @@ module Command.SetKey where
 import Control.Monad.State (liftIO)
 
 import Command
-import Utility
+import Utility.SafeCommand
 import LocationLog
 import Content
 import Messages

Command/Unannex.hs

@@ -16,7 +16,8 @@ import Command
 import qualified Command.Drop
 import qualified Annex
 import qualified AnnexQueue
-import Utility
+import Utility.SafeCommand
+import Utility.Path
 import LocationLog
 import Types
 import Content

Command/Uninit.hs

@@ -12,7 +12,7 @@ import System.Directory
 import System.Exit
 
 import Command
-import Utility
+import Utility.SafeCommand
 import qualified Git
 import qualified Annex
 import qualified Command.Unannex

Command/Unlock.hs

@@ -16,8 +16,9 @@ import Types
 import Messages
 import Locations
 import Content
+import Utility.Conditional
 import Utility.CopyFile
-import Utility
+import Utility.Path
 
 command :: [Command]
 command =

Config.hs

@@ -16,6 +16,7 @@ import qualified Git
 import qualified Annex
 import Types
 import Utility
+import Utility.SafeCommand
 
 type ConfigKey = String
 

Content.hs

@@ -41,7 +41,9 @@ import qualified Annex
 import qualified AnnexQueue
 import qualified Branch
 import Utility
+import Utility.Conditional
 import Utility.StatFS
+import Utility.Path
 import Types.Key
 import Utility.DataUnits
 import Config

Crypto.hs

@@ -48,6 +48,7 @@ import Types.Key
 import Types.Remote
 import Utility
 import Utility.Base64
+import Utility.SafeCommand
 import Types.Crypto
 
 {- The first half of a Cipher is used for HMAC; the remainder

Git.hs

@@ -85,6 +85,9 @@ import System.Exit
 import System.Posix.Env (setEnv, unsetEnv, getEnv)
 
 import Utility
+import Utility.Path
+import Utility.Conditional
+import Utility.SafeCommand
 
 {- There are two types of repositories; those on local disk and those
  - accessed via an URL. -}

Git/LsFiles.hs

@@ -16,7 +16,7 @@ module Git.LsFiles (
 ) where
 
 import Git
-import Utility
+import Utility.SafeCommand
 
 {- Scans for files that are checked into git at the specified locations. -}
 inRepo :: Repo -> [FilePath] -> IO [FilePath]

Git/Queue.hs

@@ -19,15 +19,15 @@ import System.IO
 import System.Cmd.Utils
 import Data.String.Utils
 import Control.Monad (forM_)
-import Utility
+import Utility.SafeCommand
 
 import Git
 
 {- An action to perform in a git repository. The file to act on
  - is not included, and must be able to be appended after the params. -}
-data Action = Action {
+data Action = Action
-		getSubcommand :: String,
+	{ getSubcommand :: String
-		getParams :: [CommandParam]
+	, getParams :: [CommandParam]
 	} deriving (Show, Eq, Ord)
 
 {- A queue of actions to perform (in any order) on a git repository,

Git/UnionMerge.hs

@@ -18,7 +18,7 @@ import Data.Maybe
 import Data.String.Utils
 
 import Git
-import Utility
+import Utility.SafeCommand
 
 {- Performs a union merge between two branches, staging it in the index.
  - Any previously staged changes in the index will be lost.

Init.hs

@@ -22,6 +22,7 @@ import Version
 import Messages
 import Types
 import Utility
+import Utility.Conditional
 import UUID
 
 initialize :: Annex ()

Remote/Bup.hs

@@ -29,6 +29,8 @@ import UUID
 import Locations
 import Config
 import Utility
+import Utility.Conditional
+import Utility.SafeCommand
 import Messages
 import Utility.Ssh
 import Remote.Helper.Special

Remote/Directory.hs

@@ -27,6 +27,8 @@ import Utility.CopyFile
 import Config
 import Content
 import Utility
+import Utility.Conditional
+import Utility.Path
 import Remote.Helper.Special
 import Remote.Helper.Encryptable
 import Crypto

Remote/Git.hs

@@ -26,6 +26,8 @@ import Messages
 import Utility.CopyFile
 import Utility.RsyncFile
 import Utility.Ssh
+import Utility.SafeCommand
+import Utility.Path
 import qualified Utility.Url as Url
 import Config
 import Init

Remote/Helper/Special.hs

@@ -17,7 +17,7 @@ import Types.Remote
 import qualified Git
 import qualified Annex
 import UUID
-import Utility
+import Utility.SafeCommand
 
 {- Special remotes don't have a configured url, so Git.Repo does not
  - automatically generate remotes for them. This looks for a different

Remote/Hook.hs

@@ -28,6 +28,7 @@ import Locations
 import Config
 import Content
 import Utility
+import Utility.SafeCommand
 import Remote.Helper.Special
 import Remote.Helper.Encryptable
 import Crypto

Remote/Rsync.hs

@@ -26,11 +26,14 @@ import Locations
 import Config
 import Content
 import Utility
+import Utility.Conditional
 import Remote.Helper.Special
 import Remote.Helper.Encryptable
 import Crypto
 import Messages
 import Utility.RsyncFile
+import Utility.SafeCommand
+import Utility.Path
 
 type RsyncUrl = String
 

Upgrade/V1.hs

@@ -31,6 +31,8 @@ import Backend
 import Messages
 import Version
 import Utility
+import Utility.SafeCommand
+import Utility.Path
 import qualified Upgrade.V2
 
 -- v2 adds hashing of filenames of content and location log files.

Upgrade/V2.hs

@@ -20,6 +20,8 @@ import qualified Git
 import qualified Branch
 import Messages
 import Utility
+import Utility.Conditional
+import Utility.SafeCommand
 import LocationLog
 import Content
 

Utility.hs

@@ -6,20 +6,8 @@
  -}
 
 module Utility (
-	CommandParam(..),
-	toCommand,
 	hGetContentsStrict,
 	readFileStrict,
-	parentDir,
-	absPath,
-	absPathFrom,
-	relPathCwdToFile,
-	relPathDirToFile,
-	boolSystem,
-	boolSystemEnv,
-	executeFile,
-	shellEscape,
-	shellUnEscape,
 	unsetFileMode,
 	readMaybe,
 	viaTmp,
@@ -27,125 +15,19 @@ module Utility (
 	dirContains,
 	dirContents,
 	myHomeDir,
-	catchBool,
+	catchBool
-	whenM,
-	(>>?),
-	unlessM,
-	(>>!),
-	
-	prop_idempotent_shellEscape,
-	prop_idempotent_shellEscape_multiword,
-	prop_parentDir_basics,
-	prop_relPathDirToFile_basics
 ) where
 
 import IO (bracket)
 import System.IO
-import System.Exit
-import qualified System.Posix.Process
 import System.Posix.Process hiding (executeFile)
-import System.Posix.Signals
 import System.Posix.Files
 import System.Posix.Types
 import System.Posix.User
-import Data.String.Utils
-import System.Path
 import System.FilePath
 import System.Directory
 import Foreign (complement)
-import Data.List
+import Utility.Path
-import Data.Maybe
-import Control.Monad (liftM2, when, unless)
-import System.Log.Logger
-
-{- 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 = (>>= unwrap)
-	where
-		unwrap (Param s) = [s]
-		unwrap (Params s) = filter (not . null) (split " " s)
-		-- Files that start with a dash are modified to avoid
-		-- the command interpreting them as options.
-		unwrap (File s@('-':_)) = ["./" ++ s]
-		unwrap (File s) = [s]
-
-{- Run a system command, and returns True or False
- - if it succeeded or failed.
- -
- - SIGINT(ctrl-c) is allowed to propigate and will terminate the program.
- -}
-boolSystem :: FilePath -> [CommandParam] -> IO Bool
-boolSystem command params = boolSystemEnv command params Nothing
-
-boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
-boolSystemEnv command params env = do
-	-- Going low-level because all the high-level system functions
-	-- block SIGINT etc. We need to block SIGCHLD, but allow
-	-- SIGINT to do its default program termination.
-	let sigset = addSignal sigCHLD emptySignalSet
-	oldint <- installHandler sigINT Default Nothing
-	oldset <- getSignalMask
-	blockSignals sigset
-	childpid <- forkProcess $ childaction oldint oldset
-	mps <- getProcessStatus True False childpid
-	restoresignals oldint oldset
-	case mps of
-		Just (Exited ExitSuccess) -> return True
-		_ -> return False
-	where
-		restoresignals oldint oldset = do
-			_ <- installHandler sigINT oldint Nothing
-			setSignalMask oldset
-		childaction oldint oldset = do
-			restoresignals oldint oldset
-			executeFile command True (toCommand params) env
-
-{- executeFile with debug logging -}
-executeFile :: FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
-executeFile c path p e = do
-	debugM "Utility.executeFile" $
-		"Running: " ++ c ++ " " ++ show p ++ " " ++ maybe "" show e
-	System.Posix.Process.executeFile c path p e
-
-{- Escapes a filename or other parameter to be safely able to be exposed to
- - the shell. -}
-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
 
 {- A version of hgetContents that is not lazy. Ensures file is 
  - all read before it gets closed. -}
@@ -156,82 +38,6 @@ hGetContentsStrict h  = hGetContents h >>= \s -> length s `seq` return s
 readFileStrict :: FilePath -> IO String
 readFileStrict f = readFile f >>= \s -> length s `seq` return s
 
-{- Returns the parent directory of a path. Parent of / is "" -}
-parentDir :: FilePath -> FilePath
-parentDir dir =
-	if not $ null dirs
-	then slash ++ join s (take (length dirs - 1) dirs)
-	else ""
-		where
-			dirs = filter (not . null) $ split s dir
-			slash = if isAbsolute dir then s else ""
-			s = [pathSeparator]
-
-prop_parentDir_basics :: FilePath -> Bool
-prop_parentDir_basics dir
-	| null dir = True
-	| dir == "/" = parentDir dir == ""
-	| otherwise = p /= dir
-	where
-		p = parentDir dir
-
-{- Checks if the first FilePath is, or could be said to contain the second.
- - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
- - are all equivilant.
- -}
-dirContains :: FilePath -> FilePath -> Bool
-dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b'
-	where
-		norm p = fromMaybe "" $ absNormPath p "."
-		a' = norm a
-		b' = norm b
-
-{- Converts a filename into a normalized, absolute path. -}
-absPath :: FilePath -> IO FilePath
-absPath file = do
-	cwd <- getCurrentDirectory
-	return $ absPathFrom cwd file
-
-{- Converts a filename into a normalized, absolute path
- - from the specified cwd. -}
-absPathFrom :: FilePath -> FilePath -> FilePath
-absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file
-	where
-		bad = error $ "unable to normalize " ++ file
-
-{- Constructs a relative path from the CWD to a file.
- -
- - For example, assuming CWD is /tmp/foo/bar:
- -    relPathCwdToFile "/tmp/foo" == ".."
- -    relPathCwdToFile "/tmp/foo/bar" == "" 
- -}
-relPathCwdToFile :: FilePath -> IO FilePath
-relPathCwdToFile f = liftM2 relPathDirToFile getCurrentDirectory (absPath f)
-
-{- Constructs a relative path from a directory to a file.
- -
- - Both must be absolute, and normalized (eg with absNormpath).
- -}
-relPathDirToFile :: FilePath -> FilePath -> FilePath
-relPathDirToFile from to = path
-	where
-		s = [pathSeparator]
-		pfrom = split s from
-		pto = split s to
-		common = map fst $ filter same $ zip pfrom pto
-		same (c,d) = c == d
-		uncommon = drop numcommon pto
-		dotdots = replicate (length pfrom - numcommon) ".."
-		numcommon = length common
-		path = join s $ dotdots ++ uncommon
-
-prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
-prop_relPathDirToFile_basics from to
-	| from == to = null r
-	| otherwise = not (null r)
-	where
-		r = relPathDirToFile from to 
-
 {- Removes a FileMode from a file.
  - For example, call with otherWriteMode to chmod o-w -}
 unsetFileMode :: FilePath -> FileMode -> IO ()
@@ -288,20 +94,3 @@ myHomeDir = do
 {- Catches IO errors and returns a Bool -}
 catchBool :: IO Bool -> IO Bool
 catchBool = flip catch (const $ return False)
-
-{- when with a monadic conditional -}
-whenM :: Monad m => m Bool -> m () -> m ()
-whenM c a = c >>= flip when a
-
-unlessM :: Monad m => m Bool -> m () -> m ()
-unlessM c a = c >>= flip unless a
-
-(>>?) :: Monad m => m Bool -> m () -> m ()
-(>>?) = whenM
-
-(>>!) :: Monad m => m Bool -> m () -> m ()
-(>>!) = unlessM
-
--- low fixity allows eg, foo bar >>! error $ "failed " ++ meep
-infixr 0 >>?
-infixr 0 >>!

Utility/Conditional.hs

@@ -0,0 +1,26 @@
+{- monadic conditional operators
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Conditional where
+
+import Control.Monad (when, unless)
+
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM c a = c >>= flip when a
+
+unlessM :: Monad m => m Bool -> m () -> m ()
+unlessM c a = c >>= flip unless a
+
+(>>?) :: Monad m => m Bool -> m () -> m ()
+(>>?) = whenM
+
+(>>!) :: Monad m => m Bool -> m () -> m ()
+(>>!) = unlessM
+
+-- low fixity allows eg, foo bar >>! error $ "failed " ++ meep
+infixr 0 >>?
+infixr 0 >>!

Utility/CopyFile.hs

@@ -9,7 +9,8 @@ module Utility.CopyFile (copyFile) where
 
 import System.Directory (doesFileExist, removeFile)
 
-import Utility
+import Utility.Conditional
+import Utility.SafeCommand
 import qualified Build.SysConfig as SysConfig
 
 {- The cp command is used, because I hate reinventing the wheel,

Utility/Path.hs

@@ -0,0 +1,92 @@
+{- path manipulation
+ -
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Path where
+
+import Data.String.Utils
+import System.Path
+import System.FilePath
+import System.Directory
+import Data.List
+import Data.Maybe
+import Control.Monad (liftM2)
+
+{- Returns the parent directory of a path. Parent of / is "" -}
+parentDir :: FilePath -> FilePath
+parentDir dir =
+	if not $ null dirs
+	then slash ++ join s (take (length dirs - 1) dirs)
+	else ""
+		where
+			dirs = filter (not . null) $ split s dir
+			slash = if isAbsolute dir then s else ""
+			s = [pathSeparator]
+
+prop_parentDir_basics :: FilePath -> Bool
+prop_parentDir_basics dir
+	| null dir = True
+	| dir == "/" = parentDir dir == ""
+	| otherwise = p /= dir
+	where
+		p = parentDir dir
+
+{- Checks if the first FilePath is, or could be said to contain the second.
+ - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
+ - are all equivilant.
+ -}
+dirContains :: FilePath -> FilePath -> Bool
+dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b'
+	where
+		norm p = fromMaybe "" $ absNormPath p "."
+		a' = norm a
+		b' = norm b
+
+{- Converts a filename into a normalized, absolute path. -}
+absPath :: FilePath -> IO FilePath
+absPath file = do
+	cwd <- getCurrentDirectory
+	return $ absPathFrom cwd file
+
+{- Converts a filename into a normalized, absolute path
+ - from the specified cwd. -}
+absPathFrom :: FilePath -> FilePath -> FilePath
+absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file
+	where
+		bad = error $ "unable to normalize " ++ file
+
+{- Constructs a relative path from the CWD to a file.
+ -
+ - For example, assuming CWD is /tmp/foo/bar:
+ -    relPathCwdToFile "/tmp/foo" == ".."
+ -    relPathCwdToFile "/tmp/foo/bar" == "" 
+ -}
+relPathCwdToFile :: FilePath -> IO FilePath
+relPathCwdToFile f = liftM2 relPathDirToFile getCurrentDirectory (absPath f)
+
+{- Constructs a relative path from a directory to a file.
+ -
+ - Both must be absolute, and normalized (eg with absNormpath).
+ -}
+relPathDirToFile :: FilePath -> FilePath -> FilePath
+relPathDirToFile from to = path
+	where
+		s = [pathSeparator]
+		pfrom = split s from
+		pto = split s to
+		common = map fst $ filter same $ zip pfrom pto
+		same (c,d) = c == d
+		uncommon = drop numcommon pto
+		dotdots = replicate (length pfrom - numcommon) ".."
+		numcommon = length common
+		path = join s $ dotdots ++ uncommon
+
+prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
+prop_relPathDirToFile_basics from to
+	| from == to = null r
+	| otherwise = not (null r)
+	where
+		r = relPathDirToFile from to 

Utility/RsyncFile.hs

@@ -9,7 +9,7 @@ module Utility.RsyncFile where
 
 import Data.String.Utils
 
-import Utility
+import Utility.SafeCommand
 
 {- Generates parameters to make rsync use a specified command as its remote
  - shell. -}

Utility/SafeCommand.hs

@@ -0,0 +1,104 @@
+{- safely running shell commands
+ -
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.SafeCommand where
+
+import System.Exit
+import qualified System.Posix.Process
+import System.Posix.Process hiding (executeFile)
+import System.Posix.Signals
+import Data.String.Utils
+import System.Log.Logger
+
+{- 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 = (>>= unwrap)
+	where
+		unwrap (Param s) = [s]
+		unwrap (Params s) = filter (not . null) (split " " s)
+		-- Files that start with a dash are modified to avoid
+		-- the command interpreting them as options.
+		unwrap (File s@('-':_)) = ["./" ++ s]
+		unwrap (File s) = [s]
+
+{- Run a system command, and returns True or False
+ - if it succeeded or failed.
+ -
+ - SIGINT(ctrl-c) is allowed to propigate and will terminate the program.
+ -}
+boolSystem :: FilePath -> [CommandParam] -> IO Bool
+boolSystem command params = boolSystemEnv command params Nothing
+
+boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
+boolSystemEnv command params env = do
+	-- Going low-level because all the high-level system functions
+	-- block SIGINT etc. We need to block SIGCHLD, but allow
+	-- SIGINT to do its default program termination.
+	let sigset = addSignal sigCHLD emptySignalSet
+	oldint <- installHandler sigINT Default Nothing
+	oldset <- getSignalMask
+	blockSignals sigset
+	childpid <- forkProcess $ childaction oldint oldset
+	mps <- getProcessStatus True False childpid
+	restoresignals oldint oldset
+	case mps of
+		Just (Exited ExitSuccess) -> return True
+		_ -> return False
+	where
+		restoresignals oldint oldset = do
+			_ <- installHandler sigINT oldint Nothing
+			setSignalMask oldset
+		childaction oldint oldset = do
+			restoresignals oldint oldset
+			executeFile command True (toCommand params) env
+
+{- executeFile with debug logging -}
+executeFile :: FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
+executeFile c path p e = do
+	debugM "Utility.SafeCommand.executeFile" $
+		"Running: " ++ c ++ " " ++ show p ++ " " ++ maybe "" show e
+	System.Posix.Process.executeFile c path p e
+
+{- Escapes a filename or other parameter to be safely able to be exposed to
+ - the shell. -}
+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

Utility/Ssh.hs

@@ -10,7 +10,7 @@ module Utility.Ssh where
 import Control.Monad.State (liftIO)
 
 import qualified Git
-import Utility
+import Utility.SafeCommand
 import Types
 import Config
 

Utility/Url.hs

@@ -19,7 +19,7 @@ import Network.URI
 
 import Types
 import Messages
-import Utility
+import Utility.SafeCommand
 
 type URLString = String
 

git-annex-shell.hs

@@ -11,7 +11,8 @@ import Data.List
 import qualified Git
 import CmdLine
 import Command
-import Utility
+import Utility.Conditional
+import Utility.SafeCommand
 import Options
 
 import qualified Command.ConfigList

test.hs

@@ -24,11 +24,12 @@ import qualified Data.Map as M
 import System.Path (recurseDir)
 import System.IO.HVFS (SystemFS(..))
 
+import Utility.SafeCommand
+
 import qualified Annex
 import qualified Backend
 import qualified Git
 import qualified Locations
-import qualified Utility
 import qualified Types.Backend
 import qualified Types
 import qualified GitAnnex
@@ -42,6 +43,7 @@ import qualified Command.DropUnused
 import qualified Types.Key
 import qualified Config
 import qualified Crypto
+import qualified Utility.Path
 
 -- for quickcheck
 instance Arbitrary Types.Key.Key where
@@ -72,11 +74,12 @@ quickcheck = TestLabel "quickcheck" $ TestList
 	[ qctest "prop_idempotent_deencode" Git.prop_idempotent_deencode
 	, qctest "prop_idempotent_fileKey" Locations.prop_idempotent_fileKey
 	, qctest "prop_idempotent_key_read_show" Types.Key.prop_idempotent_key_read_show
-	, qctest "prop_idempotent_shellEscape" Utility.prop_idempotent_shellEscape
+	, qctest "prop_idempotent_shellEscape" Utility.SafeCommand.prop_idempotent_shellEscape
-	, qctest "prop_idempotent_shellEscape_multiword" Utility.prop_idempotent_shellEscape_multiword
+	, qctest "prop_idempotent_shellEscape_multiword" Utility.SafeCommand.prop_idempotent_shellEscape_multiword
 	, qctest "prop_idempotent_configEscape" RemoteLog.prop_idempotent_configEscape
-	, qctest "prop_parentDir_basics" Utility.prop_parentDir_basics
+	, qctest "prop_parentDir_basics" Utility.Path.prop_parentDir_basics
-	, qctest "prop_relPathDirToFile_basics" Utility.prop_relPathDirToFile_basics
+
+	, qctest "prop_relPathDirToFile_basics" Utility.Path.prop_relPathDirToFile_basics
 	, qctest "prop_cost_sane" Config.prop_cost_sane
 	, qctest "prop_hmacWithCipher_sane" Crypto.prop_hmacWithCipher_sane
 	]
@@ -117,8 +120,8 @@ test_add = "git-annex add" ~: TestList [basic, sha1dup, subdirs]
 			git_annex "add" ["-q", annexedfile] @? "add failed"
 			annexed_present annexedfile
 			writeFile ingitfile $ content ingitfile
-			Utility.boolSystem "git" [Utility.Param "add", Utility.File ingitfile] @? "git add failed"
+			boolSystem "git" [Param "add", File ingitfile] @? "git add failed"
-			Utility.boolSystem "git" [Utility.Params "commit -q -a -m commit"] @? "git commit failed"
+			boolSystem "git" [Params "commit -q -a -m commit"] @? "git commit failed"
 			git_annex "add" ["-q", ingitfile] @? "add ingitfile should be no-op"
 			unannexed ingitfile
 		sha1dup = TestCase $ intmpclonerepo $ do
@@ -145,7 +148,7 @@ test_setkey = "git-annex setkey/fromkey" ~: TestCase $ inmainrepo $ do
 	let key = show $ fromJust r
 	git_annex "setkey" ["-q", "--key", key, tmp] @? "setkey failed"
 	git_annex "fromkey" ["-q", "--key", key, sha1annexedfile] @? "fromkey failed"
-	Utility.boolSystem "git" [Utility.Params "commit -q -a -m commit"] @? "git commit failed"
+	boolSystem "git" [Params "commit -q -a -m commit"] @? "git commit failed"
 	annexed_present sha1annexedfile
 	where
 		tmp = "tmpfile"
@@ -172,7 +175,7 @@ test_drop = "git-annex drop" ~: TestList [noremote, withremote, untrustedremote]
 	where
 		noremote = "no remotes" ~: TestCase $ intmpclonerepo $ do
 			git_annex "get" ["-q", annexedfile] @? "get failed"
-			Utility.boolSystem "git" [Utility.Params "remote rm origin"]
+			boolSystem "git" [Params "remote rm origin"]
 				@? "git remote rm origin failed"
 			r <- git_annex "drop" ["-q", annexedfile]
 			not r @? "drop wrongly succeeded with no known copy of file"
@@ -303,12 +306,12 @@ test_edit = "git-annex edit/commit" ~: TestList [t False, t True]
 			then do
 				-- pre-commit depends on the file being
 				-- staged, normally git commit does this
-				Utility.boolSystem "git" [Utility.Param "add", Utility.File annexedfile]
+				boolSystem "git" [Param "add", File annexedfile]
 					@? "git add of edited file failed"
 				git_annex "pre-commit" ["-q"]
 					@? "pre-commit failed"
 			else do
-				Utility.boolSystem "git" [Utility.Params "commit -q -a -m contentchanged"]
+				boolSystem "git" [Params "commit -q -a -m contentchanged"]
 					@? "git commit of edited file failed"
 		runchecks [checklink, checkunwritable] annexedfile
 		c <- readFile annexedfile
@@ -326,7 +329,7 @@ test_fix = "git-annex fix" ~: intmpclonerepo $ do
 	git_annex "fix" ["-q", annexedfile] @? "fix of present file failed"
 	annexed_present annexedfile
 	createDirectory subdir
-	Utility.boolSystem "git" [Utility.Param "mv", Utility.File annexedfile, Utility.File subdir]
+	boolSystem "git" [Param "mv", File annexedfile, File subdir]
 		@? "git mv failed"
 	git_annex "fix" ["-q", newfile] @? "fix of moved file failed"
 	runchecks [checklink, checkunwritable] newfile
@@ -364,9 +367,9 @@ test_fsck = "git-annex fsck" ~: TestList [basicfsck, withlocaluntrusted, withrem
 	where
 		basicfsck = TestCase $ intmpclonerepo $ do
 			git_annex "fsck" ["-q"] @? "fsck failed"
-			Utility.boolSystem "git" [Utility.Params "config annex.numcopies 2"] @? "git config failed"
+			boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed"
 			fsck_should_fail "numcopies unsatisfied"
-			Utility.boolSystem "git" [Utility.Params "config annex.numcopies 1"] @? "git config failed"
+			boolSystem "git" [Params "config annex.numcopies 1"] @? "git config failed"
 			corrupt annexedfile
 			corrupt sha1annexedfile
 		withlocaluntrusted = TestCase $ intmpclonerepo $ do
@@ -377,7 +380,7 @@ test_fsck = "git-annex fsck" ~: TestList [basicfsck, withlocaluntrusted, withrem
 			git_annex "trust" ["-q", "."] @? "trust of current repo failed"
 			git_annex "fsck" ["-q", annexedfile] @? "fsck failed on file present in trusted repo"
 		withremoteuntrusted = TestCase $ intmpclonerepo $ do
-			Utility.boolSystem "git" [Utility.Params "config annex.numcopies 2"] @? "git config failed"
+			boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed"
 			git_annex "get" ["-q", annexedfile] @? "get failed"
 			git_annex "get" ["-q", sha1annexedfile] @? "get failed"
 			git_annex "fsck" ["-q"] @? "fsck failed with numcopies=2 and 2 copies"
@@ -448,9 +451,9 @@ test_unused = "git-annex unused/dropunused" ~: intmpclonerepo $ do
 	git_annex "get" ["-q", annexedfile] @? "get of file failed"
 	git_annex "get" ["-q", sha1annexedfile] @? "get of file failed"
 	checkunused []
-	Utility.boolSystem "git" [Utility.Params "rm -q", Utility.File annexedfile] @? "git rm failed"
+	boolSystem "git" [Params "rm -q", File annexedfile] @? "git rm failed"
 	checkunused [annexedfilekey]
-	Utility.boolSystem "git" [Utility.Params "rm -q", Utility.File sha1annexedfile] @? "git rm failed"
+	boolSystem "git" [Params "rm -q", File sha1annexedfile] @? "git rm failed"
 	checkunused [annexedfilekey, sha1annexedfilekey]
 
 	-- good opportunity to test dropkey also
@@ -526,10 +529,10 @@ setuprepo :: FilePath -> IO FilePath
 setuprepo dir = do
 	cleanup dir
 	ensuretmpdir
-	Utility.boolSystem "git" [Utility.Params "init -q", Utility.File dir] @? "git init failed"
+	boolSystem "git" [Params "init -q", File dir] @? "git init failed"
 	indir dir $ do
-		Utility.boolSystem "git" [Utility.Params "config user.name", Utility.Param "Test User"] @? "git config failed"
+		boolSystem "git" [Params "config user.name", Param "Test User"] @? "git config failed"
-		Utility.boolSystem "git" [Utility.Params "config user.email test@example.com"] @? "git config failed"
+		boolSystem "git" [Params "config user.email test@example.com"] @? "git config failed"
 	return dir
 
 -- clones are always done as local clones; we cannot test ssh clones
@@ -537,7 +540,7 @@ clonerepo :: FilePath -> FilePath -> IO FilePath
 clonerepo old new = do
 	cleanup new
 	ensuretmpdir
-	Utility.boolSystem "git" [Utility.Params "clone -q", Utility.File old, Utility.File new] @? "git clone failed"
+	boolSystem "git" [Params "clone -q", File old, File new] @? "git clone failed"
 	indir new $ git_annex "init" ["-q", new] @? "git annex init failed"
 	return new