From 203148363f459635b1be40b8c6ed376073230dda Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 22 Aug 2011 16:14:12 -0400 Subject: split groups of related functions out of Utility --- Utility/Conditional.hs | 26 +++++++++++++ Utility/CopyFile.hs | 3 +- Utility/Path.hs | 92 +++++++++++++++++++++++++++++++++++++++++++ Utility/RsyncFile.hs | 2 +- Utility/SafeCommand.hs | 104 +++++++++++++++++++++++++++++++++++++++++++++++++ Utility/Ssh.hs | 2 +- Utility/Url.hs | 2 +- 7 files changed, 227 insertions(+), 4 deletions(-) create mode 100644 Utility/Conditional.hs create mode 100644 Utility/Path.hs create mode 100644 Utility/SafeCommand.hs (limited to 'Utility') diff --git a/Utility/Conditional.hs b/Utility/Conditional.hs new file mode 100644 index 000000000..85e39ec64 --- /dev/null +++ b/Utility/Conditional.hs @@ -0,0 +1,26 @@ +{- monadic conditional operators + - + - Copyright 2011 Joey Hess + - + - 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 >>! diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs index befb00f8f..901935719 100644 --- a/Utility/CopyFile.hs +++ b/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, diff --git a/Utility/Path.hs b/Utility/Path.hs new file mode 100644 index 000000000..517c175bc --- /dev/null +++ b/Utility/Path.hs @@ -0,0 +1,92 @@ +{- path manipulation + - + - Copyright 2010-2011 Joey Hess + - + - 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 diff --git a/Utility/RsyncFile.hs b/Utility/RsyncFile.hs index 6e21ba063..b6c2267e8 100644 --- a/Utility/RsyncFile.hs +++ b/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. -} diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs new file mode 100644 index 000000000..ba9362603 --- /dev/null +++ b/Utility/SafeCommand.hs @@ -0,0 +1,104 @@ +{- safely running shell commands + - + - Copyright 2010-2011 Joey Hess + - + - 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 diff --git a/Utility/Ssh.hs b/Utility/Ssh.hs index 6cbc362a0..05269552c 100644 --- a/Utility/Ssh.hs +++ b/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 diff --git a/Utility/Url.hs b/Utility/Url.hs index 5954e0ff7..69b53c34c 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -19,7 +19,7 @@ import Network.URI import Types import Messages -import Utility +import Utility.SafeCommand type URLString = String -- cgit v1.2.3