Joey Hess
commit
d9af8bac5e
|
|
@ -0,0 +1,20 @@
|
|||
import Property
|
||||
import qualified Property.Apt as Apt
|
||||
import qualified Property.Ssh as Ssh
|
||||
import qualified Property.User as User
|
||||
import qualified Property.GitHome as GitHome
|
||||
|
||||
main = defaultMain
|
||||
[ Apt.stdSourcesList Apt.Unstable `onChange` Apt.upgrade
|
||||
, Apt.installed ["etckeeper"]
|
||||
, Apt.installed ["ssh"]
|
||||
, Apt.installed ["git", "myrepos"]
|
||||
, GitHome.installed "root"
|
||||
, check (Ssh.hasAuthorizedKeys "root") $
|
||||
Ssh.passwordAuthentication False
|
||||
, User.nonsystem "joey"
|
||||
, fileHasContent "/etc/sudoers" ["joey ALL=(ALL:ALL) ALL"]
|
||||
, GitHome.installed "joey"
|
||||
, Apt.removed ["exim4"] `onChange` Apt.autoRemove
|
||||
, Apt.installed ["tor"]
|
||||
]
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
build:
|
||||
# ghc --make
|
||||
|
||||
clean:
|
||||
rm -rf dist Setup tags
|
||||
find -name \*.o -exec rm {} \;
|
||||
find -name \*.hi -exec rm {} \;
|
||||
|
||||
# hothasktags chokes on some template haskell etc, so ignore errors
|
||||
tags:
|
||||
find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags > tags 2>/dev/null
|
||||
|
|
@ -0,0 +1,160 @@
|
|||
module Property where
|
||||
|
||||
import System.Directory
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import System.Console.ANSI
|
||||
import System.Exit
|
||||
import System.IO
|
||||
|
||||
import Utility.Tmp
|
||||
import Utility.Exception
|
||||
import Utility.SafeCommand
|
||||
import Utility.Monad
|
||||
|
||||
-- Ensures that the system has some property.
|
||||
-- Actions must be idempotent; will be run repeatedly.
|
||||
data Property
|
||||
= FileProperty Desc FilePath ([Line] -> [Line])
|
||||
| CmdProperty Desc String [CommandParam]
|
||||
| IOProperty Desc (IO Result)
|
||||
|
||||
data Result = NoChange | MadeChange | FailedChange
|
||||
deriving (Show, Eq)
|
||||
|
||||
type Line = String
|
||||
type Desc = String
|
||||
|
||||
combineResult :: Result -> Result -> Result
|
||||
combineResult FailedChange _ = FailedChange
|
||||
combineResult _ FailedChange = FailedChange
|
||||
combineResult MadeChange _ = MadeChange
|
||||
combineResult _ MadeChange = MadeChange
|
||||
combineResult NoChange NoChange = NoChange
|
||||
|
||||
propertyDesc :: Property -> Desc
|
||||
propertyDesc (FileProperty d _ _) = d
|
||||
propertyDesc (CmdProperty d _ _) = d
|
||||
propertyDesc (IOProperty d _) = d
|
||||
|
||||
combineProperties :: Desc -> [Property] -> Property
|
||||
combineProperties desc ps = IOProperty desc $ go ps NoChange
|
||||
where
|
||||
go [] rs = return rs
|
||||
go (l:ls) rs = do
|
||||
r <- ensureProperty l
|
||||
case r of
|
||||
FailedChange -> return FailedChange
|
||||
_ -> go ls (combineResult r rs)
|
||||
|
||||
ensureProperty :: Property -> IO Result
|
||||
ensureProperty = catchDefaultIO FailedChange . ensureProperty'
|
||||
|
||||
ensureProperty' :: Property -> IO Result
|
||||
ensureProperty' (FileProperty _ f a) = go =<< doesFileExist f
|
||||
where
|
||||
go True = do
|
||||
ls <- lines <$> readFile f
|
||||
let ls' = a ls
|
||||
if ls' == ls
|
||||
then noChange
|
||||
else makeChange $ viaTmp writeFile f (unlines ls')
|
||||
go False = makeChange $ writeFile f (unlines $ a [])
|
||||
ensureProperty' (CmdProperty _ cmd params) = ifM (boolSystem ("./" ++ cmd) params)
|
||||
( return MadeChange
|
||||
, return FailedChange
|
||||
)
|
||||
ensureProperty' (IOProperty _ a) = a
|
||||
|
||||
ensureProperties :: [Property] -> IO [(Desc, Result)]
|
||||
ensureProperties ps = zip (map propertyDesc ps) <$> mapM ensureProperty ps
|
||||
|
||||
defaultMain :: [Property] -> IO ()
|
||||
defaultMain ps = do
|
||||
r <- ensure ps NoChange
|
||||
case r of
|
||||
FailedChange -> exitWith (ExitFailure 1)
|
||||
_ -> exitWith ExitSuccess
|
||||
where
|
||||
ensure [] rs = return rs
|
||||
ensure (l:ls) rs = do
|
||||
putStr $ propertyDesc l ++ "... "
|
||||
hFlush stdout
|
||||
r <- ensureProperty l
|
||||
case r of
|
||||
FailedChange -> do
|
||||
setSGR [SetColor Foreground Vivid Red]
|
||||
putStrLn "failed"
|
||||
NoChange -> do
|
||||
setSGR [SetColor Foreground Dull Green]
|
||||
putStrLn "(ok)"
|
||||
MadeChange -> do
|
||||
setSGR [SetColor Foreground Vivid Green]
|
||||
putStrLn "(ok)"
|
||||
setSGR []
|
||||
ensure ls (combineResult r rs)
|
||||
|
||||
makeChange :: IO () -> IO Result
|
||||
makeChange a = a >> return MadeChange
|
||||
|
||||
noChange :: IO Result
|
||||
noChange = return NoChange
|
||||
|
||||
cmdProperty :: String -> [CommandParam] -> Property
|
||||
cmdProperty cmd params = CmdProperty desc cmd params
|
||||
where
|
||||
desc = unwords $ cmd : map showp params
|
||||
showp (Params s) = s
|
||||
showp (Param s) = s
|
||||
showp (File s) = s
|
||||
|
||||
{- Replaces all the content of a file. -}
|
||||
fileHasContent :: FilePath -> [Line] -> Property
|
||||
fileHasContent f newcontent = FileProperty ("replace " ++ f)
|
||||
f (\_oldcontent -> newcontent)
|
||||
|
||||
{- Ensures that a line is present in a file, adding it to the end if not. -}
|
||||
lineInFile :: FilePath -> Line -> Property
|
||||
lineInFile f l = FileProperty (f ++ " contains:" ++ l) f go
|
||||
where
|
||||
go ls
|
||||
| l `elem` ls = ls
|
||||
| otherwise = ls++[l]
|
||||
|
||||
{- Ensures that a line is not present in a file.
|
||||
- Note that the file is ensured to exist, so if it doesn't, an empty
|
||||
- file will be written. -}
|
||||
lineNotInFile :: FilePath -> Line -> Property
|
||||
lineNotInFile f l = FileProperty (f ++ " remove: " ++ l) f (filter (/= l))
|
||||
|
||||
{- Makes a perhaps non-idempotent Property be idempotent by using a flag
|
||||
- file to indicate whether it has run before.
|
||||
- Use with caution. -}
|
||||
flagFile :: Property -> FilePath -> Property
|
||||
flagFile property flagfile = IOProperty (propertyDesc property) $
|
||||
go =<< doesFileExist flagfile
|
||||
where
|
||||
go True = return NoChange
|
||||
go False = do
|
||||
r <- ensureProperty property
|
||||
when (r == MadeChange) $
|
||||
writeFile flagfile ""
|
||||
return r
|
||||
|
||||
{- Whenever a change has to be made for a Property, causes a hook
|
||||
- Property to also be run, but not otherwise. -}
|
||||
onChange :: Property -> Property -> Property
|
||||
property `onChange` hook = IOProperty (propertyDesc property) $ do
|
||||
r <- ensureProperty property
|
||||
case r of
|
||||
MadeChange -> do
|
||||
r' <- ensureProperty hook
|
||||
return $ combineResult r r'
|
||||
_ -> return r
|
||||
|
||||
{- Makes a Property only be performed when a test succeeds. -}
|
||||
check :: IO Bool -> Property -> Property
|
||||
check c property = IOProperty (propertyDesc property) $ ifM c
|
||||
( ensureProperty property
|
||||
, return NoChange
|
||||
)
|
||||
|
|
@ -0,0 +1,87 @@
|
|||
module Property.Apt where
|
||||
|
||||
import Data.Maybe
|
||||
import Control.Applicative
|
||||
import Data.List
|
||||
|
||||
import Property
|
||||
import Utility.SafeCommand
|
||||
import Utility.Process
|
||||
|
||||
sourcesList :: FilePath
|
||||
sourcesList = "/etc/apt/sources.list"
|
||||
|
||||
type Url = String
|
||||
type Section = String
|
||||
|
||||
data Suite = Stable | Testing | Unstable | Experimental
|
||||
|
||||
showSuite :: Suite -> String
|
||||
showSuite Stable = "stable"
|
||||
showSuite Testing = "testing"
|
||||
showSuite Unstable = "unstable"
|
||||
showSuite Experimental = "experimental"
|
||||
|
||||
debLine :: Suite -> Url -> [Section] -> Line
|
||||
debLine suite mirror sections = unwords $
|
||||
["deb", mirror, showSuite suite] ++ sections
|
||||
|
||||
srcLine :: Line -> Line
|
||||
srcLine l = case words l of
|
||||
("deb":rest) -> unwords $ "deb-src" : rest
|
||||
_ -> ""
|
||||
|
||||
stdSections = ["main", "contrib", "non-free"]
|
||||
|
||||
debCdn :: Suite -> [Line]
|
||||
debCdn suite = [l, srcLine l]
|
||||
where
|
||||
l = debLine suite "http://cdn.debian.net/debian" stdSections
|
||||
|
||||
{- Makes sources.list have a standard content using the mirror CDN,
|
||||
- with a particular Suite. -}
|
||||
stdSourcesList :: Suite -> Property
|
||||
stdSourcesList = setSourcesList . debCdn
|
||||
|
||||
setSourcesList :: [Line] -> Property
|
||||
setSourcesList ls = fileHasContent sourcesList ls `onChange` update
|
||||
|
||||
update :: Property
|
||||
update = cmdProperty "apt-get" [Param "update"]
|
||||
|
||||
upgrade :: Property
|
||||
upgrade = cmdProperty "apt-get" [Params "-y safe-update"]
|
||||
|
||||
type Package = String
|
||||
|
||||
installed :: [Package] -> Property
|
||||
installed ps = check (isInstallable ps) go
|
||||
where
|
||||
go = cmdProperty "apt-get" $
|
||||
[Param "-y", Param "install"] ++ map Param ps
|
||||
|
||||
removed :: [Package] -> Property
|
||||
removed ps = check (or <$> isInstalled ps) go
|
||||
where
|
||||
go = cmdProperty "apt-get" $ [Param "-y", Param "remove"] ++ map Param ps
|
||||
|
||||
isInstallable :: [Package] -> IO Bool
|
||||
isInstallable ps = do
|
||||
l <- isInstalled ps
|
||||
return $ any (== False) l && not (null l)
|
||||
|
||||
{- Note that the order of the returned list will not always
|
||||
- correspond to the order of the input list. The number of items may
|
||||
- even vary. If apt does not know about a package at all, it will not
|
||||
- be included in the result list. -}
|
||||
isInstalled :: [Package] -> IO [Bool]
|
||||
isInstalled ps = catMaybes . map parse . lines
|
||||
<$> readProcess "apt-cache" ("policy":ps)
|
||||
where
|
||||
parse l
|
||||
| "Installed: (none)" `isInfixOf` l = Just False
|
||||
| "Installed: " `isInfixOf` l = Just True
|
||||
| otherwise = Nothing
|
||||
|
||||
autoRemove :: Property
|
||||
autoRemove = cmdProperty "apt-get" [Param "-y", Param "autoremove"]
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
module Property.GitHome where
|
||||
|
||||
import System.FilePath
|
||||
import System.Directory
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
|
||||
import Property
|
||||
import Property.User
|
||||
import Utility.SafeCommand
|
||||
import Utility.Directory
|
||||
import Utility.Monad
|
||||
import Utility.Exception
|
||||
|
||||
{- Clones Joey Hess's git home directory, and runs its fixups script. -}
|
||||
installed :: UserName -> Property
|
||||
installed user = check (not <$> hasGitDir user) $
|
||||
IOProperty ("githome " ++ user) (go =<< homedir user)
|
||||
where
|
||||
go Nothing = noChange
|
||||
go (Just home) = do
|
||||
let tmpdir = home </> "githome"
|
||||
ok <- boolSystem "git" [Param "clone", Param url, Param tmpdir]
|
||||
<&&> (and <$> moveout tmpdir home)
|
||||
<&&> (catchBoolIO $ removeDirectory tmpdir >> return True)
|
||||
<&&> boolSystem "su" [Param "-c", Param "cd; bin/fixups", Param user]
|
||||
return $ if ok then MadeChange else FailedChange
|
||||
moveout tmpdir home = do
|
||||
fs <- dirContents tmpdir
|
||||
forM fs $ \f -> boolSystem "mv" [File f, File home]
|
||||
url = "git://git.kitenet.net/joey/home"
|
||||
|
||||
hasGitDir :: UserName -> IO Bool
|
||||
hasGitDir user = go =<< homedir user
|
||||
where
|
||||
go Nothing = return False
|
||||
go (Just home) = doesDirectoryExist (home </> ".git")
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
module Property.Ssh where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import System.FilePath
|
||||
|
||||
import Property
|
||||
import Property.User
|
||||
import Utility.SafeCommand
|
||||
import Utility.Exception
|
||||
|
||||
sshBool :: Bool -> String
|
||||
sshBool True = "yes"
|
||||
sshBool False = "no"
|
||||
|
||||
sshdConfig :: FilePath
|
||||
sshdConfig = "/etc/ssh/sshd_config"
|
||||
|
||||
setSshdConfig :: String -> Bool -> Property
|
||||
setSshdConfig setting allowed = combineProperties desc
|
||||
[ lineNotInFile sshdConfig (setting ++ sshBool (not allowed))
|
||||
, lineInFile sshdConfig (setting ++ sshBool allowed)
|
||||
] `onChange` restartSshd
|
||||
where
|
||||
desc = unwords [ "ssh config:", setting, sshBool allowed ]
|
||||
|
||||
permitRootLogin :: Bool -> Property
|
||||
permitRootLogin = setSshdConfig "PermitRootLogin"
|
||||
|
||||
passwordAuthentication :: Bool -> Property
|
||||
passwordAuthentication = setSshdConfig "PasswordAuthentication"
|
||||
|
||||
hasAuthorizedKeys :: UserName -> IO Bool
|
||||
hasAuthorizedKeys = go <=< homedir
|
||||
where
|
||||
go Nothing = return False
|
||||
go (Just home) = not . null <$> catchDefaultIO ""
|
||||
(readFile $ home </> ".ssh" </> "authorized_keys")
|
||||
|
||||
restartSshd :: Property
|
||||
restartSshd = CmdProperty "ssh restart" "service" [Param "sshd", Param "restart"]
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
module Property.User where
|
||||
|
||||
import Data.List
|
||||
import System.Posix
|
||||
import Control.Applicative
|
||||
import Data.Maybe
|
||||
|
||||
import Property
|
||||
import Utility.SafeCommand
|
||||
import Utility.Exception
|
||||
|
||||
type UserName = String
|
||||
|
||||
nonsystem :: UserName -> Property
|
||||
nonsystem user = check (isNothing <$> homedir user) $ cmdProperty "adduser"
|
||||
[ Param "--disabled-password"
|
||||
, Param "--gecos", Param ""
|
||||
, Param user
|
||||
]
|
||||
|
||||
homedir :: UserName -> IO (Maybe FilePath)
|
||||
homedir user = catchMaybeIO $ homeDirectory <$> getUserEntryForName user
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
This is a work in progress configuration management system using Haskell
|
||||
and Git.
|
||||
|
||||
The design is intentionally very bare bones: A git repository holds the
|
||||
source to a program that ensures that the system meets a set of properties,
|
||||
taking action as necessary when a property is not yet met.
|
||||
|
||||
Once set up, a system will have this git repository cloned to it, and
|
||||
the program will be built and run periodically by a cron job. Or something
|
||||
can ssh in and run it.
|
||||
|
||||
For bootstrapping, the program compiles to a single binary file,
|
||||
which can be transferred to a host and run.
|
||||
|
||||
Properties are defined using Haskell. There is no special language as used
|
||||
in puppet, chef, ansible, etc, just the full power of Haskell. Hopefully
|
||||
that power can be put to good use in making declarative properties that are
|
||||
powerful, nicely idempotent, and easy to adapt to a system's special needs.
|
||||
|
||||
Also avoided is any form of node classification. Ie, which hosts are part
|
||||
of which classes and share which configuration. It might be nice to use
|
||||
reclass[1], but then again a host is configured using simply haskell code,
|
||||
and it should be easy to factor out things like classes of hosts in an
|
||||
ad-hoc fashion.
|
||||
|
||||
[1] http://reclass.pantsfullofunix.net/
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
{- applicative stuff
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Utility.Applicative where
|
||||
|
||||
{- Like <$> , but supports one level of currying.
|
||||
-
|
||||
- foo v = bar <$> action v == foo = bar <$$> action
|
||||
-}
|
||||
(<$$>) :: Functor f => (a -> b) -> (c -> f a) -> c -> f b
|
||||
f <$$> v = fmap f . v
|
||||
infixr 4 <$$>
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
{- utilities for simple data types
|
||||
-
|
||||
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Utility.Data where
|
||||
|
||||
{- First item in the list that is not Nothing. -}
|
||||
firstJust :: Eq a => [Maybe a] -> Maybe a
|
||||
firstJust ms = case dropWhile (== Nothing) ms of
|
||||
[] -> Nothing
|
||||
(md:_) -> md
|
||||
|
||||
eitherToMaybe :: Either a b -> Maybe b
|
||||
eitherToMaybe = either (const Nothing) Just
|
||||
|
|
@ -0,0 +1,135 @@
|
|||
{- directory manipulation
|
||||
-
|
||||
- Copyright 2011-2014 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Utility.Directory where
|
||||
|
||||
import System.IO.Error
|
||||
import System.Directory
|
||||
import Control.Exception (throw)
|
||||
import Control.Monad
|
||||
import Control.Monad.IfElse
|
||||
import System.FilePath
|
||||
import Control.Applicative
|
||||
import System.IO.Unsafe (unsafeInterleaveIO)
|
||||
|
||||
import Utility.PosixFiles
|
||||
import Utility.SafeCommand
|
||||
import Utility.Tmp
|
||||
import Utility.Exception
|
||||
import Utility.Monad
|
||||
import Utility.Applicative
|
||||
|
||||
dirCruft :: FilePath -> Bool
|
||||
dirCruft "." = True
|
||||
dirCruft ".." = True
|
||||
dirCruft _ = False
|
||||
|
||||
{- Lists the contents of a directory.
|
||||
- Unlike getDirectoryContents, paths are not relative to the directory. -}
|
||||
dirContents :: FilePath -> IO [FilePath]
|
||||
dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
|
||||
|
||||
{- Gets files in a directory, and then its subdirectories, recursively,
|
||||
- and lazily.
|
||||
-
|
||||
- Does not follow symlinks to other subdirectories.
|
||||
-
|
||||
- When the directory does not exist, no exception is thrown,
|
||||
- instead, [] is returned. -}
|
||||
dirContentsRecursive :: FilePath -> IO [FilePath]
|
||||
dirContentsRecursive topdir = dirContentsRecursiveSkipping (const False) True topdir
|
||||
|
||||
{- Skips directories whose basenames match the skipdir. -}
|
||||
dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
|
||||
dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]
|
||||
where
|
||||
go [] = return []
|
||||
go (dir:dirs)
|
||||
| skipdir (takeFileName dir) = go dirs
|
||||
| otherwise = unsafeInterleaveIO $ do
|
||||
(files, dirs') <- collect [] []
|
||||
=<< catchDefaultIO [] (dirContents dir)
|
||||
files' <- go (dirs' ++ dirs)
|
||||
return (files ++ files')
|
||||
collect files dirs' [] = return (reverse files, reverse dirs')
|
||||
collect files dirs' (entry:entries)
|
||||
| dirCruft entry = collect files dirs' entries
|
||||
| otherwise = do
|
||||
let skip = collect (entry:files) dirs' entries
|
||||
let recurse = collect files (entry:dirs') entries
|
||||
ms <- catchMaybeIO $ getSymbolicLinkStatus entry
|
||||
case ms of
|
||||
(Just s)
|
||||
| isDirectory s -> recurse
|
||||
| isSymbolicLink s && followsubdirsymlinks ->
|
||||
ifM (doesDirectoryExist entry)
|
||||
( recurse
|
||||
, skip
|
||||
)
|
||||
_ -> skip
|
||||
|
||||
{- Gets the directory tree from a point, recursively and lazily,
|
||||
- with leaf directories **first**, skipping any whose basenames
|
||||
- match the skipdir. Does not follow symlinks. -}
|
||||
dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
|
||||
dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]
|
||||
where
|
||||
go c [] = return c
|
||||
go c (dir:dirs)
|
||||
| skipdir (takeFileName dir) = go c dirs
|
||||
| otherwise = unsafeInterleaveIO $ do
|
||||
subdirs <- go c
|
||||
=<< filterM (isDirectory <$$> getSymbolicLinkStatus)
|
||||
=<< catchDefaultIO [] (dirContents dir)
|
||||
go (subdirs++[dir]) dirs
|
||||
|
||||
{- Moves one filename to another.
|
||||
- First tries a rename, but falls back to moving across devices if needed. -}
|
||||
moveFile :: FilePath -> FilePath -> IO ()
|
||||
moveFile src dest = tryIO (rename src dest) >>= onrename
|
||||
where
|
||||
onrename (Right _) = noop
|
||||
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 undefined
|
||||
where
|
||||
rethrow = throw e
|
||||
mv tmp _ = do
|
||||
ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]
|
||||
unless ok $ do
|
||||
-- delete any partial
|
||||
_ <- tryIO $ removeFile tmp
|
||||
rethrow
|
||||
|
||||
isdir f = do
|
||||
r <- tryIO $ getFileStatus f
|
||||
case r of
|
||||
(Left _) -> return False
|
||||
(Right s) -> return $ isDirectory s
|
||||
|
||||
{- Removes a file, which may or may not exist, and does not have to
|
||||
- be a regular file.
|
||||
-
|
||||
- Note that an exception is thrown if the file exists but
|
||||
- cannot be removed. -}
|
||||
nukeFile :: FilePath -> IO ()
|
||||
nukeFile file = void $ tryWhenExists go
|
||||
where
|
||||
#ifndef mingw32_HOST_OS
|
||||
go = removeLink file
|
||||
#else
|
||||
go = removeFile file
|
||||
#endif
|
||||
|
|
@ -0,0 +1,59 @@
|
|||
{- Simple IO exception handling (and some more)
|
||||
-
|
||||
- Copyright 2011-2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Utility.Exception where
|
||||
|
||||
import Control.Exception
|
||||
import qualified Control.Exception as E
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import System.IO.Error (isDoesNotExistError)
|
||||
import Utility.Data
|
||||
|
||||
{- Catches IO errors and returns a Bool -}
|
||||
catchBoolIO :: IO Bool -> IO Bool
|
||||
catchBoolIO a = catchDefaultIO False a
|
||||
|
||||
{- Catches IO errors and returns a Maybe -}
|
||||
catchMaybeIO :: IO a -> IO (Maybe a)
|
||||
catchMaybeIO a = catchDefaultIO Nothing $ Just <$> a
|
||||
|
||||
{- Catches IO errors and returns a default value. -}
|
||||
catchDefaultIO :: a -> IO a -> IO a
|
||||
catchDefaultIO def a = catchIO a (const $ return def)
|
||||
|
||||
{- Catches IO errors and returns the error message. -}
|
||||
catchMsgIO :: IO a -> IO (Either String a)
|
||||
catchMsgIO a = either (Left . show) Right <$> tryIO a
|
||||
|
||||
{- catch specialized for IO errors only -}
|
||||
catchIO :: IO a -> (IOException -> IO a) -> IO a
|
||||
catchIO = E.catch
|
||||
|
||||
{- try specialized for IO errors only -}
|
||||
tryIO :: IO a -> IO (Either IOException a)
|
||||
tryIO = try
|
||||
|
||||
{- Catches all exceptions except for async exceptions.
|
||||
- This is often better to use than catching them all, so that
|
||||
- ThreadKilled and UserInterrupt get through.
|
||||
-}
|
||||
catchNonAsync :: IO a -> (SomeException -> IO a) -> IO a
|
||||
catchNonAsync a onerr = a `catches`
|
||||
[ Handler (\ (e :: AsyncException) -> throw e)
|
||||
, Handler (\ (e :: SomeException) -> onerr e)
|
||||
]
|
||||
|
||||
tryNonAsync :: IO a -> IO (Either SomeException a)
|
||||
tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left)
|
||||
|
||||
{- Catches only DoesNotExist exceptions, and lets all others through. -}
|
||||
tryWhenExists :: IO a -> IO (Maybe a)
|
||||
tryWhenExists a = eitherToMaybe <$>
|
||||
tryJust (guard . isDoesNotExistError) a
|
||||
|
|
@ -0,0 +1,132 @@
|
|||
{- GHC File system encoding handling.
|
||||
-
|
||||
- Copyright 2012-2014 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Utility.FileSystemEncoding (
|
||||
fileEncoding,
|
||||
withFilePath,
|
||||
md5FilePath,
|
||||
decodeBS,
|
||||
decodeW8,
|
||||
encodeW8,
|
||||
truncateFilePath,
|
||||
) where
|
||||
|
||||
import qualified GHC.Foreign as GHC
|
||||
import qualified GHC.IO.Encoding as Encoding
|
||||
import Foreign.C
|
||||
import System.IO
|
||||
import System.IO.Unsafe
|
||||
import qualified Data.Hash.MD5 as MD5
|
||||
import Data.Word
|
||||
import Data.Bits.Utils
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
#ifdef mingw32_HOST_OS
|
||||
import qualified Data.ByteString.Lazy.UTF8 as L8
|
||||
#endif
|
||||
|
||||
{- Sets a Handle to use the filesystem encoding. This causes data
|
||||
- written or read from it to be encoded/decoded the same
|
||||
- as ghc 7.4 does to filenames etc. This special encoding
|
||||
- allows "arbitrary undecodable bytes to be round-tripped through it".
|
||||
-}
|
||||
fileEncoding :: Handle -> IO ()
|
||||
#ifndef mingw32_HOST_OS
|
||||
fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding
|
||||
#else
|
||||
{- The file system encoding does not work well on Windows,
|
||||
- and Windows only has utf FilePaths anyway. -}
|
||||
fileEncoding h = hSetEncoding h Encoding.utf8
|
||||
#endif
|
||||
|
||||
{- Marshal a Haskell FilePath into a NUL terminated C string using temporary
|
||||
- storage. The FilePath is encoded using the filesystem encoding,
|
||||
- reversing the decoding that should have been done when the FilePath
|
||||
- was obtained. -}
|
||||
withFilePath :: FilePath -> (CString -> IO a) -> IO a
|
||||
withFilePath fp f = Encoding.getFileSystemEncoding
|
||||
>>= \enc -> GHC.withCString enc fp f
|
||||
|
||||
{- Encodes a FilePath into a String, applying the filesystem encoding.
|
||||
-
|
||||
- There are very few things it makes sense to do with such an encoded
|
||||
- string. It's not a legal filename; it should not be displayed.
|
||||
- So this function is not exported, but instead used by the few functions
|
||||
- that can usefully consume it.
|
||||
-
|
||||
- This use of unsafePerformIO is belived to be safe; GHC's interface
|
||||
- only allows doing this conversion with CStrings, and the CString buffer
|
||||
- is allocated, used, and deallocated within the call, with no side
|
||||
- effects.
|
||||
-}
|
||||
{-# NOINLINE _encodeFilePath #-}
|
||||
_encodeFilePath :: FilePath -> String
|
||||
_encodeFilePath fp = unsafePerformIO $ do
|
||||
enc <- Encoding.getFileSystemEncoding
|
||||
GHC.withCString enc fp $ GHC.peekCString Encoding.char8
|
||||
|
||||
{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -}
|
||||
md5FilePath :: FilePath -> MD5.Str
|
||||
md5FilePath = MD5.Str . _encodeFilePath
|
||||
|
||||
{- Decodes a ByteString into a FilePath, applying the filesystem encoding. -}
|
||||
decodeBS :: L.ByteString -> FilePath
|
||||
#ifndef mingw32_HOST_OS
|
||||
decodeBS = encodeW8 . L.unpack
|
||||
#else
|
||||
{- On Windows, we assume that the ByteString is utf-8, since Windows
|
||||
- only uses unicode for filenames. -}
|
||||
decodeBS = L8.toString
|
||||
#endif
|
||||
|
||||
{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.
|
||||
-
|
||||
- w82c produces a String, which may contain Chars that are invalid
|
||||
- unicode. From there, this is really a simple matter of applying the
|
||||
- file system encoding, only complicated by GHC's interface to doing so.
|
||||
-}
|
||||
{-# NOINLINE encodeW8 #-}
|
||||
encodeW8 :: [Word8] -> FilePath
|
||||
encodeW8 w8 = unsafePerformIO $ do
|
||||
enc <- Encoding.getFileSystemEncoding
|
||||
GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc
|
||||
|
||||
{- Useful when you want the actual number of bytes that will be used to
|
||||
- represent the FilePath on disk. -}
|
||||
decodeW8 :: FilePath -> [Word8]
|
||||
decodeW8 = s2w8 . _encodeFilePath
|
||||
|
||||
{- Truncates a FilePath to the given number of bytes (or less),
|
||||
- as represented on disk.
|
||||
-
|
||||
- Avoids returning an invalid part of a unicode byte sequence, at the
|
||||
- cost of efficiency when running on a large FilePath.
|
||||
-}
|
||||
truncateFilePath :: Int -> FilePath -> FilePath
|
||||
#ifndef mingw32_HOST_OS
|
||||
truncateFilePath n = go . reverse
|
||||
where
|
||||
go f =
|
||||
let bytes = decodeW8 f
|
||||
in if length bytes <= n
|
||||
then reverse f
|
||||
else go (drop 1 f)
|
||||
#else
|
||||
{- On Windows, count the number of bytes used by each utf8 character. -}
|
||||
truncateFilePath n = reverse . go [] n . L8.fromString
|
||||
where
|
||||
go coll cnt bs
|
||||
| cnt <= 0 = coll
|
||||
| otherwise = case L8.decode bs of
|
||||
Just (c, x) | c /= L8.replacement_char ->
|
||||
let x' = fromIntegral x
|
||||
in if cnt - x' < 0
|
||||
then coll
|
||||
else go (c:coll) (cnt - x') (L8.drop 1 bs)
|
||||
_ -> coll
|
||||
#endif
|
||||
|
|
@ -0,0 +1,148 @@
|
|||
{- misc utility functions
|
||||
-
|
||||
- Copyright 2010-2011 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Utility.Misc where
|
||||
|
||||
import System.IO
|
||||
import Control.Monad
|
||||
import Foreign
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import Control.Applicative
|
||||
import System.Exit
|
||||
#ifndef mingw32_HOST_OS
|
||||
import System.Posix.Process (getAnyProcessStatus)
|
||||
import Utility.Exception
|
||||
#endif
|
||||
|
||||
import Utility.FileSystemEncoding
|
||||
import Utility.Monad
|
||||
|
||||
{- A version of hgetContents that is not lazy. Ensures file is
|
||||
- all read before it gets closed. -}
|
||||
hGetContentsStrict :: Handle -> IO String
|
||||
hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s
|
||||
|
||||
{- A version of readFile that is not lazy. -}
|
||||
readFileStrict :: FilePath -> IO String
|
||||
readFileStrict = readFile >=> \s -> length s `seq` return s
|
||||
|
||||
{- Reads a file strictly, and using the FileSystemEncoding, so it will
|
||||
- never crash on a badly encoded file. -}
|
||||
readFileStrictAnyEncoding :: FilePath -> IO String
|
||||
readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do
|
||||
fileEncoding h
|
||||
hClose h `after` hGetContentsStrict h
|
||||
|
||||
{- Writes a file, using the FileSystemEncoding so it will never crash
|
||||
- on a badly encoded content string. -}
|
||||
writeFileAnyEncoding :: FilePath -> String -> IO ()
|
||||
writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do
|
||||
fileEncoding h
|
||||
hPutStr h content
|
||||
|
||||
{- Like break, but the item matching the condition is not included
|
||||
- in the second result list.
|
||||
-
|
||||
- separate (== ':') "foo:bar" = ("foo", "bar")
|
||||
- separate (== ':') "foobar" = ("foobar", "")
|
||||
-}
|
||||
separate :: (a -> Bool) -> [a] -> ([a], [a])
|
||||
separate c l = unbreak $ break c l
|
||||
where
|
||||
unbreak r@(a, b)
|
||||
| null b = r
|
||||
| otherwise = (a, tail b)
|
||||
|
||||
{- Breaks out the first line. -}
|
||||
firstLine :: String -> String
|
||||
firstLine = takeWhile (/= '\n')
|
||||
|
||||
{- Splits a list into segments that are delimited by items matching
|
||||
- a predicate. (The delimiters are not included in the segments.)
|
||||
- Segments may be empty. -}
|
||||
segment :: (a -> Bool) -> [a] -> [[a]]
|
||||
segment p l = map reverse $ go [] [] l
|
||||
where
|
||||
go c r [] = reverse $ c:r
|
||||
go c r (i:is)
|
||||
| p i = go [] (c:r) is
|
||||
| otherwise = go (i:c) r is
|
||||
|
||||
prop_segment_regressionTest :: Bool
|
||||
prop_segment_regressionTest = all id
|
||||
-- Even an empty list is a segment.
|
||||
[ segment (== "--") [] == [[]]
|
||||
-- There are two segements in this list, even though the first is empty.
|
||||
, segment (== "--") ["--", "foo", "bar"] == [[],["foo","bar"]]
|
||||
]
|
||||
|
||||
{- Includes the delimiters as segments of their own. -}
|
||||
segmentDelim :: (a -> Bool) -> [a] -> [[a]]
|
||||
segmentDelim p l = map reverse $ go [] [] l
|
||||
where
|
||||
go c r [] = reverse $ c:r
|
||||
go c r (i:is)
|
||||
| p i = go [] ([i]:c:r) is
|
||||
| otherwise = go (i:c) r is
|
||||
|
||||
{- Replaces multiple values in a string.
|
||||
-
|
||||
- Takes care to skip over just-replaced values, so that they are not
|
||||
- mangled. For example, massReplace [("foo", "new foo")] does not
|
||||
- replace the "new foo" with "new new foo".
|
||||
-}
|
||||
massReplace :: [(String, String)] -> String -> String
|
||||
massReplace vs = go [] vs
|
||||
where
|
||||
|
||||
go acc _ [] = concat $ reverse acc
|
||||
go acc [] (c:cs) = go ([c]:acc) vs cs
|
||||
go acc ((val, replacement):rest) s
|
||||
| val `isPrefixOf` s =
|
||||
go (replacement:acc) vs (drop (length val) s)
|
||||
| otherwise = go acc rest s
|
||||
|
||||
{- Wrapper around hGetBufSome that returns a String.
|
||||
-
|
||||
- The null string is returned on eof, otherwise returns whatever
|
||||
- data is currently available to read from the handle, or waits for
|
||||
- data to be written to it if none is currently available.
|
||||
-
|
||||
- Note on encodings: The normal encoding of the Handle is ignored;
|
||||
- each byte is converted to a Char. Not unicode clean!
|
||||
-}
|
||||
hGetSomeString :: Handle -> Int -> IO String
|
||||
hGetSomeString h sz = do
|
||||
fp <- mallocForeignPtrBytes sz
|
||||
len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz
|
||||
map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len)
|
||||
where
|
||||
peekbytes :: Int -> Ptr Word8 -> IO [Word8]
|
||||
peekbytes len buf = mapM (peekElemOff buf) [0..pred len]
|
||||
|
||||
{- Reaps any zombie git processes.
|
||||
-
|
||||
- Warning: Not thread safe. Anything that was expecting to wait
|
||||
- on a process and get back an exit status is going to be confused
|
||||
- if this reap gets there first. -}
|
||||
reapZombies :: IO ()
|
||||
#ifndef mingw32_HOST_OS
|
||||
reapZombies = do
|
||||
-- throws an exception when there are no child processes
|
||||
catchDefaultIO Nothing (getAnyProcessStatus False True)
|
||||
>>= maybe (return ()) (const reapZombies)
|
||||
|
||||
#else
|
||||
reapZombies = return ()
|
||||
#endif
|
||||
|
||||
exitBool :: Bool -> IO a
|
||||
exitBool False = exitFailure
|
||||
exitBool True = exitSuccess
|
||||
|
|
@ -0,0 +1,69 @@
|
|||
{- monadic stuff
|
||||
-
|
||||
- Copyright 2010-2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Utility.Monad where
|
||||
|
||||
import Data.Maybe
|
||||
import Control.Monad
|
||||
|
||||
{- Return the first value from a list, if any, satisfying the given
|
||||
- predicate -}
|
||||
firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
|
||||
firstM _ [] = return Nothing
|
||||
firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs)
|
||||
|
||||
{- Runs the action on values from the list until it succeeds, returning
|
||||
- its result. -}
|
||||
getM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)
|
||||
getM _ [] = return Nothing
|
||||
getM p (x:xs) = maybe (getM p xs) (return . Just) =<< p x
|
||||
|
||||
{- Returns true if any value in the list satisfies the predicate,
|
||||
- stopping once one is found. -}
|
||||
anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
|
||||
anyM p = liftM isJust . firstM p
|
||||
|
||||
allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
|
||||
allM _ [] = return True
|
||||
allM p (x:xs) = p x <&&> allM p xs
|
||||
|
||||
{- Runs an action on values from a list until it succeeds. -}
|
||||
untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool
|
||||
untilTrue = flip anyM
|
||||
|
||||
{- if with a monadic conditional. -}
|
||||
ifM :: Monad m => m Bool -> (m a, m a) -> m a
|
||||
ifM cond (thenclause, elseclause) = do
|
||||
c <- cond
|
||||
if c then thenclause else elseclause
|
||||
|
||||
{- short-circuiting monadic || -}
|
||||
(<||>) :: Monad m => m Bool -> m Bool -> m Bool
|
||||
ma <||> mb = ifM ma ( return True , mb )
|
||||
|
||||
{- short-circuiting monadic && -}
|
||||
(<&&>) :: Monad m => m Bool -> m Bool -> m Bool
|
||||
ma <&&> mb = ifM ma ( mb , return False )
|
||||
|
||||
{- Same fixity as && and || -}
|
||||
infixr 3 <&&>
|
||||
infixr 2 <||>
|
||||
|
||||
{- Runs an action, passing its value to an observer before returning it. -}
|
||||
observe :: Monad m => (a -> m b) -> m a -> m a
|
||||
observe observer a = do
|
||||
r <- a
|
||||
_ <- observer r
|
||||
return r
|
||||
|
||||
{- b `after` a runs first a, then b, and returns the value of a -}
|
||||
after :: Monad m => m b -> m a -> m a
|
||||
after = observe . const
|
||||
|
||||
{- do nothing -}
|
||||
noop :: Monad m => m ()
|
||||
noop = return ()
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
{- POSIX files (and compatablity wrappers).
|
||||
-
|
||||
- This is like System.PosixCompat.Files, except with a fixed rename.
|
||||
-
|
||||
- Copyright 2014 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Utility.PosixFiles (
|
||||
module X,
|
||||
rename
|
||||
) where
|
||||
|
||||
import System.PosixCompat.Files as X hiding (rename)
|
||||
|
||||
#ifndef mingw32_HOST_OS
|
||||
import System.Posix.Files (rename)
|
||||
#else
|
||||
import qualified System.Win32.File as Win32
|
||||
#endif
|
||||
|
||||
{- System.PosixCompat.Files.rename on Windows calls renameFile,
|
||||
- so cannot rename directories.
|
||||
-
|
||||
- Instead, use Win32 moveFile, which can. It needs to be told to overwrite
|
||||
- any existing file. -}
|
||||
#ifdef mingw32_HOST_OS
|
||||
rename :: FilePath -> FilePath -> IO ()
|
||||
rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING
|
||||
#endif
|
||||
|
|
@ -0,0 +1,360 @@
|
|||
{- System.Process enhancements, including additional ways of running
|
||||
- processes, and logging.
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP, Rank2Types #-}
|
||||
|
||||
module Utility.Process (
|
||||
module X,
|
||||
CreateProcess,
|
||||
StdHandle(..),
|
||||
readProcess,
|
||||
readProcessEnv,
|
||||
writeReadProcessEnv,
|
||||
forceSuccessProcess,
|
||||
checkSuccessProcess,
|
||||
ignoreFailureProcess,
|
||||
createProcessSuccess,
|
||||
createProcessChecked,
|
||||
createBackgroundProcess,
|
||||
processTranscript,
|
||||
processTranscript',
|
||||
withHandle,
|
||||
withBothHandles,
|
||||
withQuietOutput,
|
||||
createProcess,
|
||||
startInteractiveProcess,
|
||||
stdinHandle,
|
||||
stdoutHandle,
|
||||
stderrHandle,
|
||||
devNull,
|
||||
) where
|
||||
|
||||
import qualified System.Process
|
||||
import System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)
|
||||
import System.Process hiding (createProcess, readProcess)
|
||||
import System.Exit
|
||||
import System.IO
|
||||
import System.Log.Logger
|
||||
import Control.Concurrent
|
||||
import qualified Control.Exception as E
|
||||
import Control.Monad
|
||||
#ifndef mingw32_HOST_OS
|
||||
import System.Posix.IO
|
||||
#else
|
||||
import Control.Applicative
|
||||
#endif
|
||||
import Data.Maybe
|
||||
|
||||
import Utility.Misc
|
||||
import Utility.Exception
|
||||
|
||||
type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a
|
||||
|
||||
data StdHandle = StdinHandle | StdoutHandle | StderrHandle
|
||||
deriving (Eq)
|
||||
|
||||
{- Normally, when reading from a process, it does not need to be fed any
|
||||
- standard input. -}
|
||||
readProcess :: FilePath -> [String] -> IO String
|
||||
readProcess cmd args = readProcessEnv cmd args Nothing
|
||||
|
||||
readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String
|
||||
readProcessEnv cmd args environ =
|
||||
withHandle StdoutHandle createProcessSuccess p $ \h -> do
|
||||
output <- hGetContentsStrict h
|
||||
hClose h
|
||||
return output
|
||||
where
|
||||
p = (proc cmd args)
|
||||
{ std_out = CreatePipe
|
||||
, env = environ
|
||||
}
|
||||
|
||||
{- Runs an action to write to a process on its stdin,
|
||||
- returns its output, and also allows specifying the environment.
|
||||
-}
|
||||
writeReadProcessEnv
|
||||
:: FilePath
|
||||
-> [String]
|
||||
-> Maybe [(String, String)]
|
||||
-> (Maybe (Handle -> IO ()))
|
||||
-> (Maybe (Handle -> IO ()))
|
||||
-> IO String
|
||||
writeReadProcessEnv cmd args environ writestdin adjusthandle = do
|
||||
(Just inh, Just outh, _, pid) <- createProcess p
|
||||
|
||||
maybe (return ()) (\a -> a inh) adjusthandle
|
||||
maybe (return ()) (\a -> a outh) adjusthandle
|
||||
|
||||
-- fork off a thread to start consuming the output
|
||||
output <- hGetContents outh
|
||||
outMVar <- newEmptyMVar
|
||||
_ <- forkIO $ E.evaluate (length output) >> putMVar outMVar ()
|
||||
|
||||
-- now write and flush any input
|
||||
maybe (return ()) (\a -> a inh >> hFlush inh) writestdin
|
||||
hClose inh -- done with stdin
|
||||
|
||||
-- wait on the output
|
||||
takeMVar outMVar
|
||||
hClose outh
|
||||
|
||||
-- wait on the process
|
||||
forceSuccessProcess p pid
|
||||
|
||||
return output
|
||||
|
||||
where
|
||||
p = (proc cmd args)
|
||||
{ std_in = CreatePipe
|
||||
, std_out = CreatePipe
|
||||
, std_err = Inherit
|
||||
, env = environ
|
||||
}
|
||||
|
||||
{- Waits for a ProcessHandle, and throws an IOError if the process
|
||||
- did not exit successfully. -}
|
||||
forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()
|
||||
forceSuccessProcess p pid = do
|
||||
code <- waitForProcess pid
|
||||
case code of
|
||||
ExitSuccess -> return ()
|
||||
ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n
|
||||
|
||||
{- Waits for a ProcessHandle and returns True if it exited successfully.
|
||||
- Note that using this with createProcessChecked will throw away
|
||||
- the Bool, and is only useful to ignore the exit code of a process,
|
||||
- while still waiting for it. -}
|
||||
checkSuccessProcess :: ProcessHandle -> IO Bool
|
||||
checkSuccessProcess pid = do
|
||||
code <- waitForProcess pid
|
||||
return $ code == ExitSuccess
|
||||
|
||||
ignoreFailureProcess :: ProcessHandle -> IO Bool
|
||||
ignoreFailureProcess pid = do
|
||||
void $ waitForProcess pid
|
||||
return True
|
||||
|
||||
{- Runs createProcess, then an action on its handles, and then
|
||||
- forceSuccessProcess. -}
|
||||
createProcessSuccess :: CreateProcessRunner
|
||||
createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a
|
||||
|
||||
{- Runs createProcess, then an action on its handles, and then
|
||||
- a checker action on its exit code, which must wait for the process. -}
|
||||
createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner
|
||||
createProcessChecked checker p a = do
|
||||
t@(_, _, _, pid) <- createProcess p
|
||||
r <- tryNonAsync $ a t
|
||||
_ <- checker pid
|
||||
either E.throw return r
|
||||
|
||||
{- Leaves the process running, suitable for lazy streaming.
|
||||
- Note: Zombies will result, and must be waited on. -}
|
||||
createBackgroundProcess :: CreateProcessRunner
|
||||
createBackgroundProcess p a = a =<< createProcess p
|
||||
|
||||
{- Runs a process, optionally feeding it some input, and
|
||||
- returns a transcript combining its stdout and stderr, and
|
||||
- whether it succeeded or failed. -}
|
||||
processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
|
||||
processTranscript cmd opts input = processTranscript' cmd opts Nothing input
|
||||
|
||||
processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)
|
||||
#ifndef mingw32_HOST_OS
|
||||
{- This implementation interleves stdout and stderr in exactly the order
|
||||
- the process writes them. -}
|
||||
processTranscript' cmd opts environ input = do
|
||||
(readf, writef) <- createPipe
|
||||
readh <- fdToHandle readf
|
||||
writeh <- fdToHandle writef
|
||||
p@(_, _, _, pid) <- createProcess $
|
||||
(proc cmd opts)
|
||||
{ std_in = if isJust input then CreatePipe else Inherit
|
||||
, std_out = UseHandle writeh
|
||||
, std_err = UseHandle writeh
|
||||
, env = environ
|
||||
}
|
||||
hClose writeh
|
||||
|
||||
get <- mkreader readh
|
||||
|
||||
-- now write and flush any input
|
||||
case input of
|
||||
Just s -> do
|
||||
let inh = stdinHandle p
|
||||
unless (null s) $ do
|
||||
hPutStr inh s
|
||||
hFlush inh
|
||||
hClose inh
|
||||
Nothing -> return ()
|
||||
|
||||
transcript <- get
|
||||
|
||||
ok <- checkSuccessProcess pid
|
||||
return (transcript, ok)
|
||||
#else
|
||||
{- This implementation for Windows puts stderr after stdout. -}
|
||||
processTranscript' cmd opts environ input = do
|
||||
p@(_, _, _, pid) <- createProcess $
|
||||
(proc cmd opts)
|
||||
{ std_in = if isJust input then CreatePipe else Inherit
|
||||
, std_out = CreatePipe
|
||||
, std_err = CreatePipe
|
||||
, env = environ
|
||||
}
|
||||
|
||||
getout <- mkreader (stdoutHandle p)
|
||||
geterr <- mkreader (stderrHandle p)
|
||||
|
||||
case input of
|
||||
Just s -> do
|
||||
let inh = stdinHandle p
|
||||
unless (null s) $ do
|
||||
hPutStr inh s
|
||||
hFlush inh
|
||||
hClose inh
|
||||
Nothing -> return ()
|
||||
|
||||
transcript <- (++) <$> getout <*> geterr
|
||||
ok <- checkSuccessProcess pid
|
||||
return (transcript, ok)
|
||||
#endif
|
||||
where
|
||||
mkreader h = do
|
||||
s <- hGetContents h
|
||||
v <- newEmptyMVar
|
||||
void $ forkIO $ do
|
||||
void $ E.evaluate (length s)
|
||||
putMVar v ()
|
||||
return $ do
|
||||
takeMVar v
|
||||
return s
|
||||
|
||||
{- Runs a CreateProcessRunner, on a CreateProcess structure, that
|
||||
- is adjusted to pipe only from/to a single StdHandle, and passes
|
||||
- the resulting Handle to an action. -}
|
||||
withHandle
|
||||
:: StdHandle
|
||||
-> CreateProcessRunner
|
||||
-> CreateProcess
|
||||
-> (Handle -> IO a)
|
||||
-> IO a
|
||||
withHandle h creator p a = creator p' $ a . select
|
||||
where
|
||||
base = p
|
||||
{ std_in = Inherit
|
||||
, std_out = Inherit
|
||||
, std_err = Inherit
|
||||
}
|
||||
(select, p')
|
||||
| h == StdinHandle =
|
||||
(stdinHandle, base { std_in = CreatePipe })
|
||||
| h == StdoutHandle =
|
||||
(stdoutHandle, base { std_out = CreatePipe })
|
||||
| h == StderrHandle =
|
||||
(stderrHandle, base { std_err = CreatePipe })
|
||||
|
||||
{- Like withHandle, but passes (stdin, stdout) handles to the action. -}
|
||||
withBothHandles
|
||||
:: CreateProcessRunner
|
||||
-> CreateProcess
|
||||
-> ((Handle, Handle) -> IO a)
|
||||
-> IO a
|
||||
withBothHandles creator p a = creator p' $ a . bothHandles
|
||||
where
|
||||
p' = p
|
||||
{ std_in = CreatePipe
|
||||
, std_out = CreatePipe
|
||||
, std_err = Inherit
|
||||
}
|
||||
|
||||
{- Forces the CreateProcessRunner to run quietly;
|
||||
- both stdout and stderr are discarded. -}
|
||||
withQuietOutput
|
||||
:: CreateProcessRunner
|
||||
-> CreateProcess
|
||||
-> IO ()
|
||||
withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do
|
||||
let p' = p
|
||||
{ std_out = UseHandle nullh
|
||||
, std_err = UseHandle nullh
|
||||
}
|
||||
creator p' $ const $ return ()
|
||||
|
||||
devNull :: FilePath
|
||||
#ifndef mingw32_HOST_OS
|
||||
devNull = "/dev/null"
|
||||
#else
|
||||
devNull = "NUL"
|
||||
#endif
|
||||
|
||||
{- Extract a desired handle from createProcess's tuple.
|
||||
- These partial functions are safe as long as createProcess is run
|
||||
- with appropriate parameters to set up the desired handle.
|
||||
- Get it wrong and the runtime crash will always happen, so should be
|
||||
- easily noticed. -}
|
||||
type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle
|
||||
stdinHandle :: HandleExtractor
|
||||
stdinHandle (Just h, _, _, _) = h
|
||||
stdinHandle _ = error "expected stdinHandle"
|
||||
stdoutHandle :: HandleExtractor
|
||||
stdoutHandle (_, Just h, _, _) = h
|
||||
stdoutHandle _ = error "expected stdoutHandle"
|
||||
stderrHandle :: HandleExtractor
|
||||
stderrHandle (_, _, Just h, _) = h
|
||||
stderrHandle _ = error "expected stderrHandle"
|
||||
bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
|
||||
bothHandles (Just hin, Just hout, _, _) = (hin, hout)
|
||||
bothHandles _ = error "expected bothHandles"
|
||||
|
||||
{- Debugging trace for a CreateProcess. -}
|
||||
debugProcess :: CreateProcess -> IO ()
|
||||
debugProcess p = do
|
||||
debugM "Utility.Process" $ unwords
|
||||
[ action ++ ":"
|
||||
, showCmd p
|
||||
]
|
||||
where
|
||||
action
|
||||
| piped (std_in p) && piped (std_out p) = "chat"
|
||||
| piped (std_in p) = "feed"
|
||||
| piped (std_out p) = "read"
|
||||
| otherwise = "call"
|
||||
piped Inherit = False
|
||||
piped _ = True
|
||||
|
||||
{- Shows the command that a CreateProcess will run. -}
|
||||
showCmd :: CreateProcess -> String
|
||||
showCmd = go . cmdspec
|
||||
where
|
||||
go (ShellCommand s) = s
|
||||
go (RawCommand c ps) = c ++ " " ++ show ps
|
||||
|
||||
{- Starts an interactive process. Unlike runInteractiveProcess in
|
||||
- System.Process, stderr is inherited. -}
|
||||
startInteractiveProcess
|
||||
:: FilePath
|
||||
-> [String]
|
||||
-> Maybe [(String, String)]
|
||||
-> IO (ProcessHandle, Handle, Handle)
|
||||
startInteractiveProcess cmd args environ = do
|
||||
let p = (proc cmd args)
|
||||
{ std_in = CreatePipe
|
||||
, std_out = CreatePipe
|
||||
, std_err = Inherit
|
||||
, env = environ
|
||||
}
|
||||
(Just from, Just to, _, pid) <- createProcess p
|
||||
return (pid, to, from)
|
||||
|
||||
{- Wrapper around System.Process function that does debug logging. -}
|
||||
createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
|
||||
createProcess p = do
|
||||
debugProcess p
|
||||
System.Process.createProcess p
|
||||
|
|
@ -0,0 +1,120 @@
|
|||
{- safely running shell commands
|
||||
-
|
||||
- Copyright 2010-2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Utility.SafeCommand where
|
||||
|
||||
import System.Exit
|
||||
import Utility.Process
|
||||
import System.Process (env)
|
||||
import Data.String.Utils
|
||||
import Control.Applicative
|
||||
import System.FilePath
|
||||
import Data.Char
|
||||
|
||||
{- 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 = concatMap unwrap
|
||||
where
|
||||
unwrap (Param s) = [s]
|
||||
unwrap (Params s) = filter (not . null) (split " " 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.
|
||||
-}
|
||||
boolSystem :: FilePath -> [CommandParam] -> IO Bool
|
||||
boolSystem command params = boolSystemEnv command params Nothing
|
||||
|
||||
boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
|
||||
boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ
|
||||
where
|
||||
dispatch ExitSuccess = True
|
||||
dispatch _ = False
|
||||
|
||||
{- Runs a system command, returning the exit status. -}
|
||||
safeSystem :: FilePath -> [CommandParam] -> IO ExitCode
|
||||
safeSystem command params = safeSystemEnv command params Nothing
|
||||
|
||||
safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode
|
||||
safeSystemEnv command params environ = do
|
||||
(_, _, _, pid) <- createProcess (proc command $ toCommand params)
|
||||
{ env = environ }
|
||||
waitForProcess pid
|
||||
|
||||
{- 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 = 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
|
||||
|
||||
{- Segements a list of filenames into groups that are all below the manximum
|
||||
- command-line length limit. Does not preserve order. -}
|
||||
segmentXargs :: [FilePath] -> [[FilePath]]
|
||||
segmentXargs l = go l [] 0 []
|
||||
where
|
||||
go [] c _ r = c:r
|
||||
go (f:fs) c accumlen r
|
||||
| len < maxlen && newlen > 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 Linux's 20k limit;
|
||||
- allows room for other parameters etc. -}
|
||||
maxlen = 10240
|
||||
|
|
@ -0,0 +1,100 @@
|
|||
{- Temporary files and directories.
|
||||
-
|
||||
- Copyright 2010-2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Utility.Tmp where
|
||||
|
||||
import Control.Exception (bracket)
|
||||
import System.IO
|
||||
import System.Directory
|
||||
import Control.Monad.IfElse
|
||||
import System.FilePath
|
||||
|
||||
import Utility.Exception
|
||||
import Utility.FileSystemEncoding
|
||||
import Utility.PosixFiles
|
||||
|
||||
type Template = String
|
||||
|
||||
{- Runs an action like writeFile, writing to a temp file first and
|
||||
- then moving it into place. The temp file is stored in the same
|
||||
- directory as the final file to avoid cross-device renames. -}
|
||||
viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO ()
|
||||
viaTmp a file content = do
|
||||
let (dir, base) = splitFileName file
|
||||
createDirectoryIfMissing True dir
|
||||
(tmpfile, handle) <- openTempFile dir (base ++ ".tmp")
|
||||
hClose handle
|
||||
a tmpfile content
|
||||
rename tmpfile file
|
||||
|
||||
{- Runs an action with a tmp file located in the system's tmp directory
|
||||
- (or in "." if there is none) then removes the file. -}
|
||||
withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a
|
||||
withTmpFile template a = do
|
||||
tmpdir <- catchDefaultIO "." getTemporaryDirectory
|
||||
withTmpFileIn tmpdir template a
|
||||
|
||||
{- Runs an action with a tmp file located in the specified directory,
|
||||
- then removes the file. -}
|
||||
withTmpFileIn :: FilePath -> Template -> (FilePath -> Handle -> IO a) -> IO a
|
||||
withTmpFileIn tmpdir template a = bracket create remove use
|
||||
where
|
||||
create = openTempFile tmpdir template
|
||||
remove (name, handle) = do
|
||||
hClose handle
|
||||
catchBoolIO (removeFile name >> return True)
|
||||
use (name, handle) = a name handle
|
||||
|
||||
{- Runs an action with a tmp directory located within the system's tmp
|
||||
- directory (or within "." if there is none), then removes the tmp
|
||||
- directory and all its contents. -}
|
||||
withTmpDir :: Template -> (FilePath -> IO a) -> IO a
|
||||
withTmpDir template a = do
|
||||
tmpdir <- catchDefaultIO "." getTemporaryDirectory
|
||||
withTmpDirIn tmpdir template a
|
||||
|
||||
{- Runs an action with a tmp directory located within a specified directory,
|
||||
- then removes the tmp directory and all its contents. -}
|
||||
withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a
|
||||
withTmpDirIn tmpdir template = bracket create remove
|
||||
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)
|
||||
|
||||
{- 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
|
||||
- will be longer, and may exceed the maximum filename length.
|
||||
-
|
||||
- This generates a template that is never too long.
|
||||
- (Well, it allocates 20 characters for use in making a unique temp file,
|
||||
- anyway, which is enough for the current implementation and any
|
||||
- likely implementation.)
|
||||
-}
|
||||
relatedTemplate :: FilePath -> FilePath
|
||||
relatedTemplate f
|
||||
| len > 20 = truncateFilePath (len - 20) f
|
||||
| otherwise = f
|
||||
where
|
||||
len = length f
|
||||
Loading…
Reference in New Issue