summaryrefslogtreecommitdiff
path: root/Utility.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Utility.hs')
-rw-r--r--Utility.hs215
1 files changed, 2 insertions, 213 deletions
diff --git a/Utility.hs b/Utility.hs
index 8a332601b..788dc4103 100644
--- a/Utility.hs
+++ b/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,
- whenM,
- (>>?),
- unlessM,
- (>>!),
-
- prop_idempotent_shellEscape,
- prop_idempotent_shellEscape_multiword,
- prop_parentDir_basics,
- prop_relPathDirToFile_basics
+ catchBool
) 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 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
+import Utility.Path
{- 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 >>!