propellor 2.15.0 → 2.15.1

raw patch · 31 files changed

+260/−95 lines, 31 files

Files

• CHANGELOG +14/−0
• debian/changelog +14/−0
• propellor.cabal +1/−1
• src/Propellor/Debug.hs +2/−1
• src/Propellor/Engine.hs +2/−1
• src/Propellor/Git.hs +22/−8
• src/Propellor/Gpg.hs +7/−6
• src/Propellor/Info.hs +1/−0
• src/Propellor/Message.hs +3/−2
• src/Propellor/PrivData.hs +3/−2
• src/Propellor/Property.hs +2/−1
• src/Propellor/Property/Apt.hs +2/−1
• src/Propellor/Property/Chroot/Util.hs +2/−1
• src/Propellor/Property/Cmd.hs +2/−1
• src/Propellor/Property/File.hs +0/−1
• src/Propellor/Property/Gpg.hs +29/−10
• src/Propellor/Property/User.hs +25/−1
• src/Propellor/Spin.hs +18/−0
• src/Propellor/Types.hs +2/−1
• src/Propellor/Types/Dns.hs +2/−1
• src/Propellor/Types/Info.hs +2/−1
• src/Propellor/Types/Result.hs +2/−1
• src/System/Console/Concurrent/Internal.hs +2/−1
• src/Utility/Directory.hs +21/−10
• src/Utility/Exception.hs +8/−7
• src/Utility/FileMode.hs +23/−6
• src/Utility/FileSystemEncoding.hs +3/−2
• src/Utility/Path.hs +6/−6
• src/Utility/SafeCommand.hs +6/−5
• src/Utility/Tmp.hs +32/−16
• src/wrapper.hs +2/−1

@@ -1,3 +1,17 @@+propellor (2.15.1) unstable; urgency=medium++  * Added git configs propellor.spin-branch and propellor.forbid-dirty-spin.+    Thanks, Sean Whitton.+  * Added User.systemAccountFor and User.systemAccountFor' properties.+    Thanks, Félix Sipma.+  * Gpg.keyImported converted to not use a flag file and instead check+    if gpg has the provided key already.+    Thanks, Félix Sipma.+  * Merged Utility changes from git-annex.+  * Clean build with ghc 7.10.++ -- Joey Hess <id@joeyh.name>  Sat, 19 Dec 2015 16:43:09 -0400+ propellor (2.15.0) unstable; urgency=medium    * Added UncheckedProperty type, along with unchecked to indicate a

@@ -1,3 +1,17 @@+propellor (2.15.1) unstable; urgency=medium++  * Added git configs propellor.spin-branch and propellor.forbid-dirty-spin.+    Thanks, Sean Whitton.+  * Added User.systemAccountFor and User.systemAccountFor' properties.+    Thanks, Félix Sipma.+  * Gpg.keyImported converted to not use a flag file and instead check+    if gpg has the provided key already.+    Thanks, Félix Sipma.+  * Merged Utility changes from git-annex.+  * Clean build with ghc 7.10.++ -- Joey Hess <id@joeyh.name>  Sat, 19 Dec 2015 16:43:09 -0400+ propellor (2.15.0) unstable; urgency=medium    * Added UncheckedProperty type, along with unchecked to indicate a

@@ -1,5 +1,5 @@ Name: propellor-Version: 2.15.0+Version: 2.15.1 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess <id@joeyh.name>

@@ -1,6 +1,5 @@ module Propellor.Debug where -import Control.Applicative import Control.Monad.IfElse import System.IO import System.Directory@@ -8,6 +7,8 @@ import System.Log.Formatter import System.Log.Handler (setFormatter) import System.Log.Handler.Simple+import Control.Applicative+import Prelude  import Utility.Monad import Utility.Env

@@ -14,12 +14,13 @@ import System.Exit import System.IO import Data.Monoid-import Control.Applicative import "mtl" Control.Monad.RWS.Strict import System.PosixCompat import System.Posix.IO import System.FilePath import System.Directory+import Control.Applicative+import Prelude  import Propellor.Types import Propellor.Message

@@ -29,17 +29,31 @@ 	void $ boolSystem "git" [Param "config", Param (branchval "remote"), Param "origin"] 	void $ boolSystem "git" [Param "config", Param (branchval "merge"), Param $ "refs/heads/"++branch] +getGitConfigValue :: String -> IO (Maybe String)+getGitConfigValue key = do+	value <- catchMaybeIO $+		takeWhile (/= '\n')+			<$> readProcess "git" ["config", key]+	return $ case value of+		Just v | not (null v) -> Just v+		_ -> Nothing++-- `git config --bool propellor.blah` outputs "false" if propellor.blah is unset+-- i.e. the git convention is that the default value of any git-config setting+-- is "false".  So we don't need a Maybe Bool here.+getGitConfigBool :: String -> IO Bool+getGitConfigBool key = do+	value <- catchMaybeIO $+		takeWhile (/= '\n')+			<$> readProcess "git" ["config", "--bool", key]+	return $ case value of+		Just "true" -> True+		_ -> False+ getRepoUrl :: IO (Maybe String)-getRepoUrl = getM get urls+getRepoUrl = getM getGitConfigValue urls   where 	urls = ["remote.deploy.url", "remote.origin.url"]-	get u = do-		v <- catchMaybeIO $ -			takeWhile (/= '\n') -				<$> readProcess "git" ["config", u]-		return $ case v of-			Just url | not (null url) -> Just url-			_ -> Nothing  hasOrigin :: IO Bool hasOrigin = catchDefaultIO False $ do

@@ -1,6 +1,5 @@ module Propellor.Gpg where -import Control.Applicative import System.IO import System.FilePath import System.Directory@@ -9,6 +8,8 @@ import Control.Monad import System.Console.Concurrent import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..))+import Control.Applicative+import Prelude  import Propellor.PrivData.Paths import Propellor.Message@@ -79,12 +80,12 @@ 	]   where 	rmkeyring = boolSystem "gpg" $-		(map Param useKeyringOpts) ++ +		(map Param useKeyringOpts) ++ 		[ Param "--batch" 		, Param "--yes" 		, Param "--delete-key", Param keyid 		]-	+ 	gitconfig = ifM ((==) (keyid++"\n", True) <$> processTranscript "git" ["config", "user.signingkey"] Nothing) 		( boolSystem "git" 			[ Param "config"@@ -92,7 +93,7 @@ 			, Param "user.signingkey" 			] 		, return True-		)	+		)  reencryptPrivData :: IO Bool reencryptPrivData = ifM (doesFileExist privDataFile)@@ -101,7 +102,7 @@ 		gitAdd privDataFile 	, return True 	)-	+ gitAdd :: FilePath -> IO Bool gitAdd f = boolSystem "git" 	[ Param "add"@@ -125,7 +126,7 @@ -- Automatically sign the commit if there'a a keyring. gitCommit :: Maybe String -> [CommandParam] -> IO Bool gitCommit msg ps = do-	let ps' = Param "commit" : ps ++ +	let ps' = Param "commit" : ps ++ 		maybe [] (\m -> [Param "-m", Param m]) msg 	ps'' <- gpgSignParams ps' 	if isNothing msg

@@ -11,6 +11,7 @@ import Data.Maybe import Data.Monoid import Control.Applicative+import Prelude  pureInfoProperty :: (IsInfo v) => Desc -> v -> Property HasInfo pureInfoProperty desc v = pureInfoProperty' desc (addInfo mempty v)

@@ -22,10 +22,11 @@ import System.Console.ANSI import System.IO import Control.Monad.IO.Class (liftIO, MonadIO)-import Control.Applicative import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent import System.Console.Concurrent+import Control.Applicative+import Prelude  import Propellor.Types import Utility.PartialPrelude@@ -41,7 +42,7 @@ globalMessageHandle :: MVar MessageHandle globalMessageHandle = unsafePerformIO $  	newMVar =<< MessageHandle-		<$> hIsTerminalDevice stdout+		<$> catchDefaultIO False (hIsTerminalDevice stdout)  -- | Gets the global MessageHandle. getMessageHandle :: IO MessageHandle

@@ -23,11 +23,9 @@ 	forceHostContext, ) where -import Control.Applicative import System.IO import System.Directory import Data.Maybe-import Data.Monoid import Data.List import Data.Typeable import Control.Monad@@ -38,6 +36,9 @@ import qualified Data.ByteString.Lazy as L import System.Console.Concurrent import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..))+import Control.Applicative+import Data.Monoid+import Prelude  import Propellor.Types import Propellor.Types.PrivData

@@ -38,12 +38,13 @@ import System.Directory import System.FilePath import Control.Monad-import Control.Applicative import Data.Monoid import Control.Monad.IfElse import "mtl" Control.Monad.RWS.Strict import System.Posix.Files import qualified Data.Hash.MD5 as MD5+import Control.Applicative+import Prelude  import Propellor.Types import Propellor.Types.ResultCheck

@@ -3,10 +3,11 @@ module Propellor.Property.Apt where  import Data.Maybe-import Control.Applicative import Data.List import System.IO import Control.Monad+import Control.Applicative+import Prelude  import Propellor.Base import qualified Propellor.Property.File as File

@@ -6,8 +6,9 @@ import Utility.Env import Utility.Directory -import Control.Applicative import System.Directory+import Control.Applicative+import Prelude  -- | When chrooting, it's useful to ensure that PATH has all the standard -- directories in it. This adds those directories to whatever PATH is

@@ -44,9 +44,10 @@ 	waitForProcess, ) where -import Control.Applicative import Data.List import "mtl" Control.Monad.Reader+import Control.Applicative+import Prelude  import Propellor.Types import Propellor.Property

@@ -4,7 +4,6 @@ import Utility.FileMode  import System.Posix.Files-import System.PosixCompat.Types import System.Exit  type Line = String

@@ -12,6 +12,8 @@ -- A numeric id, or a description of the key, in a form understood by gpg. newtype GpgKeyId = GpgKeyId { getGpgKeyId :: String } +data GpgKeyType = GpgPubKey | GpgPrivKey+ -- | Sets up a user with a gpg key from the privdata. -- -- Note that if a secret key is exported using gpg -a --export-secret-key,@@ -21,21 +23,38 @@ -- Recommend only using this for low-value dedicated role keys. -- No attempt has been made to scrub the key out of memory once it's used. keyImported :: GpgKeyId -> User -> Property HasInfo-keyImported (GpgKeyId keyid) user@(User u) = flagFile' prop genflag+keyImported key@(GpgKeyId keyid) user@(User u) = prop 	`requires` installed   where 	desc = u ++ " has gpg key " ++ show keyid-	genflag = do-		d <- dotDir user-		return $ d </> ".propellor-imported-keyid-" ++ keyid 	prop = withPrivData src (Context keyid) $ \getkey ->-		property desc $ getkey $ \key -> makeChange $-			withHandle StdinHandle createProcessSuccess-				(proc "su" ["-c", "gpg --import", u]) $ \h -> do-					fileEncoding h-					hPutStr h (unlines (privDataLines key))-					hClose h+		property desc $ getkey $ \key' -> do+			let keylines = privDataLines key'+			ifM (liftIO $ hasGpgKey (parse keylines))+				( return NoChange+				, makeChange $ withHandle StdinHandle createProcessSuccess+					(proc "su" ["-c", "gpg --import", u]) $ \h -> do+						fileEncoding h+						hPutStr h (unlines keylines)+						hClose h+				) 	src = PrivDataSource GpgKey "Either a gpg public key, exported with gpg --export -a, or a gpg private key, exported with gpg --export-secret-key -a"++	parse ("-----BEGIN PGP PUBLIC KEY BLOCK-----":_) = Just GpgPubKey+	parse ("-----BEGIN PGP PRIVATE KEY BLOCK-----":_) = Just GpgPrivKey+	parse _ = Nothing++	hasGpgKey Nothing = error $ "Failed to run gpg parser on armored key " ++ keyid+	hasGpgKey (Just GpgPubKey) = hasPubKey key user+	hasGpgKey (Just GpgPrivKey) = hasPrivKey key user++hasPrivKey :: GpgKeyId -> User -> IO Bool+hasPrivKey (GpgKeyId keyid) (User u) = catchBoolIO $+	snd <$> processTranscript "su" ["-c", "gpg --list-secret-keys " ++ shellEscape keyid, u] Nothing++hasPubKey :: GpgKeyId -> User -> IO Bool+hasPubKey (GpgKeyId keyid) (User u) = catchBoolIO $+	snd <$> processTranscript "su" ["-c", "gpg --list-public-keys " ++ shellEscape keyid, u] Nothing  dotDir :: User -> IO FilePath dotDir (User u) = do

@@ -18,6 +18,30 @@ 		, u 		] +systemAccountFor :: User -> Property NoInfo+systemAccountFor user@(User u) = systemAccountFor' user Nothing (Just (Group u))++systemAccountFor' :: User -> Maybe FilePath -> Maybe Group -> Property NoInfo+systemAccountFor' (User u) mhome mgroup = check nouser go+	`describe` ("system account for " ++ u)+  where+	nouser = isNothing <$> catchMaybeIO (getUserEntryForName u)+	go = cmdProperty "adduser" $+		[ "--system" ]+		+++		"--home" : maybe+			["/nonexistent", "--no-create-home"]+			( \h -> [ h ] )+			mhome+		+++		maybe [] ( \(Group g) -> ["--ingroup", g] ) mgroup+		+++		[ "--shell", "/usr/bin/nologin"+		, "--disabled-login"+		, "--disabled-password"+		, u+		]+ -- | Removes user home directory!! Use with caution. nuked :: User -> Eep -> Property NoInfo nuked user@(User u) _ = check hashomedir go@@ -131,7 +155,7 @@ 	desc = "user " ++ u ++ " is in standard desktop groups" 	-- This list comes from user-setup's debconf 	-- template named "passwd/user-default-groups"-	desktopgroups = +	desktopgroups = 		[ "audio" 		, "cdrom" 		, "dip"

@@ -32,6 +32,24 @@  commitSpin :: IO () commitSpin = do+	-- safety check #1: check we're on the configured spin branch+	spinBranch <- getGitConfigValue "propellor.spin-branch"+	case spinBranch of+		Nothing -> return () -- just a noop+		Just b -> do+			currentBranch <- getCurrentBranch+			when (b /= currentBranch) $+				error ("spin aborted: check out "+ 					++ b ++ " branch first")++	-- safety check #2: check we can commit with a dirty tree+	noDirtySpin <- getGitConfigBool "propellor.forbid-dirty-spin"+	when noDirtySpin $ do+		status <- takeWhile (/= '\n')+			<$> readProcess "git" ["status", "--porcelain"]+		when (not . null $ status) $+			error "spin aborted: commit changes first"+ 	void $ actionMessage "Git commit" $ 		gitCommit (Just spinCommitMessage)  			[Param "--allow-empty", Param "-a"]

@@ -39,10 +39,11 @@ 	) where  import Data.Monoid-import Control.Applicative import "mtl" Control.Monad.RWS.Strict import Control.Monad.Catch import Data.Typeable+import Control.Applicative+import Prelude  import Propellor.Types.Info import Propellor.Types.OS

@@ -7,11 +7,12 @@ import Propellor.Types.Info  import Data.Word-import Data.Monoid import qualified Data.Map as M import qualified Data.Set as S import Data.List import Data.String.Utils (split, replace)+import Data.Monoid+import Prelude  type Domain = String 

@@ -13,8 +13,9 @@ ) where  import Data.Dynamic-import Data.Monoid import Data.Maybe+import Data.Monoid+import Prelude  -- | Information about a Host, which can be provided by its properties. newtype Info = Info [InfoEntry]

@@ -1,7 +1,8 @@ module Propellor.Types.Result where -import Data.Monoid import System.Console.ANSI+import Data.Monoid+import Prelude  -- | There can be three results of satisfying a Property. data Result = NoChange | MadeChange | FailedChange

@@ -19,7 +19,6 @@ import System.Exit import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO)-import Control.Applicative import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent import Control.Concurrent.STM@@ -30,6 +29,8 @@ import qualified System.Process as P import qualified Data.Text as T import qualified Data.Text.IO as T+import Control.Applicative+import Prelude  import Utility.Monad import Utility.Exception

@@ -13,7 +13,6 @@ import System.IO.Error import System.Directory import Control.Monad-import Control.Monad.IfElse import System.FilePath import Control.Applicative import Control.Concurrent@@ -25,10 +24,11 @@ import qualified System.Win32 as Win32 #else import qualified System.Posix as Posix+import Utility.SafeCommand+import Control.Monad.IfElse #endif  import Utility.PosixFiles-import Utility.SafeCommand import Utility.Tmp import Utility.Exception import Utility.Monad@@ -107,21 +107,32 @@ 	onrename (Left e) 		| isPermissionError e = rethrow 		| isDoesNotExistError e = rethrow-		| otherwise = do-			-- copyFile is likely not as optimised as-			-- the mv command, so we'll use the latter.-			-- But, mv will move into a directory if-			-- dest is one, which is not desired.-			whenM (isdir dest) rethrow-			viaTmp mv dest ""+		| otherwise = viaTmp mv dest "" 	  where 		rethrow = throwM e+ 		mv tmp _ = do+		-- copyFile is likely not as optimised as+		-- the mv command, so we'll use the command.+		--+		-- But, while Windows has a "mv", it does not seem very+		-- reliable, so use copyFile there.+#ifndef mingw32_HOST_OS	+			-- If dest is a directory, mv would move the file+			-- into it, which is not desired.+			whenM (isdir dest) rethrow 			ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]+			let e' = e+#else+			r <- tryIO $ copyFile src tmp+			let (ok, e') = case r of+				Left err -> (False, err)+				Right _ -> (True, e)+#endif 			unless ok $ do 				-- delete any partial 				_ <- tryIO $ removeFile tmp-				rethrow+				throwM e'  	isdir f = do 		r <- tryIO $ getFileStatus f

@@ -20,7 +20,8 @@ 	catchNonAsync, 	tryNonAsync, 	tryWhenExists,-	catchHardwareFault,+	catchIOErrorType,+	IOErrorType(..) ) where  import Control.Monad.Catch as X hiding (Handler)@@ -88,11 +89,11 @@ 	v <- tryJust (guard . isDoesNotExistError) a 	return (eitherToMaybe v) -{- Catches only exceptions caused by hardware faults.- - Ie, disk IO error. -}-catchHardwareFault :: MonadCatch m => m a -> (IOException -> m a) -> m a-catchHardwareFault a onhardwareerr = catchIO a onlyhw+{- Catches only IO exceptions of a particular type.+ - Ie, use HardwareFault to catch disk IO errors. -}+catchIOErrorType :: MonadCatch m => IOErrorType -> (IOException -> m a) -> m a -> m a+catchIOErrorType errtype onmatchingerr a = catchIO a onlymatching   where-	onlyhw e-		| ioeGetErrorType e == HardwareFault = onhardwareerr e+	onlymatching e+		| ioeGetErrorType e == errtype = onmatchingerr e 		| otherwise = throwM e

@@ -7,7 +7,10 @@  {-# LANGUAGE CPP #-} -module Utility.FileMode where+module Utility.FileMode (+	module Utility.FileMode,+	FileMode,+) where  import System.IO import Control.Monad@@ -17,18 +20,32 @@ import System.Posix.Files #endif import Foreign (complement)+import Control.Monad.IO.Class (liftIO, MonadIO)+import Control.Monad.Catch  import Utility.Exception  {- Applies a conversion function to a file's mode. -} modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO ()-modifyFileMode f convert = do+modifyFileMode f convert = void $ modifyFileMode' f convert++modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode+modifyFileMode' f convert = do 	s <- getFileStatus f 	let old = fileMode s 	let new = convert old 	when (new /= old) $ 		setFileMode f new+	return old +{- Runs an action after changing a file's mode, then restores the old mode. -}+withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a+withModifiedFileMode file convert a = bracket setup cleanup go+  where+	setup = modifyFileMode' file convert+	cleanup oldmode = modifyFileMode file (const oldmode)+	go _ = a+ {- Adds the specified FileModes to the input mode, leaving the rest  - unchanged. -} addModes :: [FileMode] -> FileMode -> FileMode@@ -92,7 +109,7 @@  {- Runs an action without that pesky umask influencing it, unless the  - passed FileMode is the standard one. -}-noUmask :: FileMode -> IO a -> IO a+noUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a #ifndef mingw32_HOST_OS noUmask mode a 	| mode == stdFileMode = a@@ -101,12 +118,12 @@ noUmask _ a = a #endif -withUmask :: FileMode -> IO a -> IO a+withUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a #ifndef mingw32_HOST_OS withUmask umask a = bracket setup cleanup go   where-	setup = setFileCreationMask umask-	cleanup = setFileCreationMask+	setup = liftIO $ setFileCreationMask umask+	cleanup = liftIO . setFileCreationMask 	go _ = a #else withUmask _ a = a

@@ -29,6 +29,7 @@ import qualified Data.Hash.MD5 as MD5 import Data.Word import Data.Bits.Utils+import Data.List import Data.List.Utils import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS@@ -125,12 +126,12 @@  {- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} encodeW8NUL :: [Word8] -> FilePath-encodeW8NUL = join nul . map encodeW8 . split (s2w8 nul)+encodeW8NUL = intercalate nul . map encodeW8 . split (s2w8 nul)   where 	nul = ['\NUL']  decodeW8NUL :: FilePath -> [Word8]-decodeW8NUL = join (s2w8 nul) . map decodeW8 . split nul+decodeW8NUL = intercalate (s2w8 nul) . map decodeW8 . split nul   where 	nul = ['\NUL'] 

@@ -30,8 +30,8 @@ import Utility.Monad import Utility.UserInfo -{- Simplifies a path, removing any ".." or ".", and removing the trailing- - path separator.+{- Simplifies a path, removing any "." component, collapsing "dir/..", + - and removing the trailing path separator.  -  - On Windows, preserves whichever style of path separator might be used in  - the input FilePaths. This is done because some programs in Windows@@ -50,7 +50,8 @@  	norm c [] = reverse c 	norm c (p:ps)-		| p' == ".." = norm (drop 1 c) ps+		| p' == ".." && not (null c) && dropTrailingPathSeparator (c !! 0) /= ".." = +			norm (drop 1 c) ps 		| p' == "." = norm c ps 		| otherwise = norm (p:c) ps 	  where@@ -88,7 +89,7 @@ upFrom :: FilePath -> Maybe FilePath upFrom dir 	| length dirs < 2 = Nothing-	| otherwise = Just $ joinDrive drive (join s $ init dirs)+	| otherwise = Just $ joinDrive drive (intercalate s $ init dirs)   where 	-- on Unix, the drive will be "/" when the dir is absolute, otherwise "" 	(drive, path) = splitDrive dir@@ -148,7 +149,7 @@ relPathDirToFileAbs :: FilePath -> FilePath -> FilePath relPathDirToFileAbs from to 	| takeDrive from /= takeDrive to = to-	| otherwise = join s $ dotdots ++ uncommon+	| otherwise = intercalate s $ dotdots ++ uncommon   where 	s = [pathSeparator] 	pfrom = split s from@@ -287,7 +288,6 @@ 	if l <= 0 		then return 255 		else return $ minimum [l, 255]-  where #endif  {- Given a string that we'd like to use as the basis for FilePath, but that

@@ -14,6 +14,7 @@ import Data.String.Utils import System.FilePath import Data.Char+import Data.List import Control.Applicative import Prelude @@ -85,7 +86,7 @@ shellEscape f = "'" ++ escaped ++ "'"   where 	-- replace ' with '"'"'-	escaped = join "'\"'\"'" $ split "'" f+	escaped = intercalate "'\"'\"'" $ split "'" f  -- | Unescapes a set of shellEscaped words or filenames. shellUnEscape :: String -> [String]@@ -105,10 +106,10 @@ 		| 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+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.

@@ -15,6 +15,9 @@ import Control.Monad.IfElse import System.FilePath import Control.Monad.IO.Class+#ifndef mingw32_HOST_OS+import System.Posix.Temp (mkdtemp)+#endif  import Utility.Exception import Utility.FileSystemEncoding@@ -64,32 +67,45 @@  - directory and all its contents. -} withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a withTmpDir template a = do-	tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory-	withTmpDirIn tmpdir template a+	topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory+#ifndef mingw32_HOST_OS+	-- Use mkdtemp to create a temp directory securely in /tmp.+	bracket+		(liftIO $ mkdtemp $ topleveltmpdir </> template)+		removeTmpDir+		a+#else+	withTmpDirIn topleveltmpdir template a+#endif  {- Runs an action with a tmp directory located within a specified directory,  - then removes the tmp directory and all its contents. -} withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a-withTmpDirIn tmpdir template = bracketIO create remove+withTmpDirIn tmpdir template = bracketIO create removeTmpDir   where-	remove d = whenM (doesDirectoryExist d) $ do-#if mingw32_HOST_OS-		-- Windows will often refuse to delete a file-		-- after a process has just written to it and exited.-		-- Because it's crap, presumably. So, ignore failure-		-- to delete the temp directory.-		_ <- tryIO $ removeDirectoryRecursive d-		return ()-#else-		removeDirectoryRecursive d-#endif 	create = do 		createDirectoryIfMissing True tmpdir 		makenewdir (tmpdir </> template) (0 :: Int) 	makenewdir t n = do 		let dir = t ++ "." ++ show n-		either (const $ makenewdir t $ n + 1) (const $ return dir)-			=<< tryIO (createDirectory dir)+		catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do+			createDirectory dir+			return dir++{- Deletes the entire contents of the the temporary directory, if it+ - exists. -}+removeTmpDir :: MonadIO m => FilePath -> m ()+removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do+#if mingw32_HOST_OS+	-- Windows will often refuse to delete a file+	-- after a process has just written to it and exited.+	-- Because it's crap, presumably. So, ignore failure+	-- to delete the temp directory.+	_ <- tryIO $ removeDirectoryRecursive tmpdir+	return ()+#else+	removeDirectoryRecursive tmpdir+#endif  {- It's not safe to use a FilePath of an existing file as the template  - for openTempFile, because if the FilePath is really long, the tmpfile

@@ -24,13 +24,14 @@  import Control.Monad import Control.Monad.IfElse-import Control.Applicative import System.Directory import System.FilePath import System.Environment (getArgs) import System.Exit import System.Posix.Directory import System.IO+import Control.Applicative+import Prelude  distdir :: FilePath distdir = "/usr/src/propellor"