diff options
Diffstat (limited to 'Utility')
| -rw-r--r-- | Utility/CoProcess.hs | 14 | ||||
| -rw-r--r-- | Utility/DirWatcher.hs | 36 | ||||
| -rw-r--r-- | Utility/DiskFree.hs | 2 | ||||
| -rw-r--r-- | Utility/Gpg.hs | 38 | ||||
| -rw-r--r-- | Utility/INotify.hs | 7 | ||||
| -rw-r--r-- | Utility/Kqueue.hs | 68 | ||||
| -rw-r--r-- | Utility/Lsof.hs | 10 | ||||
| -rw-r--r-- | Utility/Misc.hs | 2 | ||||
| -rw-r--r-- | Utility/Mounts.hsc | 69 | ||||
| -rw-r--r-- | Utility/Parallel.hs | 35 | ||||
| -rw-r--r-- | Utility/Process.hs | 214 | ||||
| -rw-r--r-- | Utility/SafeCommand.hs | 45 | ||||
| -rw-r--r-- | Utility/TSet.hs | 39 | ||||
| -rw-r--r-- | Utility/TempFile.hs | 2 | ||||
| -rw-r--r-- | Utility/Types/DirWatcher.hs | 3 | ||||
| -rw-r--r-- | Utility/libmounts.c | 103 | ||||
| -rw-r--r-- | Utility/libmounts.h | 33 |
17 files changed, 613 insertions, 107 deletions
diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs index 9fa8d864f..67f861bb3 100644 --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -13,23 +13,23 @@ module Utility.CoProcess ( query ) where -import System.Cmd.Utils - import Common -type CoProcessHandle = (PipeHandle, Handle, Handle) +type CoProcessHandle = (ProcessHandle, Handle, Handle, CreateProcess) start :: FilePath -> [String] -> IO CoProcessHandle -start command params = hPipeBoth command params +start command params = do + (from, to, _err, pid) <- runInteractiveProcess command params Nothing Nothing + return (pid, to, from, proc command params) stop :: CoProcessHandle -> IO () -stop (pid, from, to) = do +stop (pid, from, to, p) = do hClose to hClose from - forceSuccess pid + forceSuccessProcess p pid query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b -query (_, from, to) send receive = do +query (_, from, to, _) send receive = do _ <- send to hFlush to receive from diff --git a/Utility/DirWatcher.hs b/Utility/DirWatcher.hs index 11ce7baef..213aeb50a 100644 --- a/Utility/DirWatcher.hs +++ b/Utility/DirWatcher.hs @@ -17,10 +17,10 @@ import Utility.Types.DirWatcher #if WITH_INOTIFY import qualified Utility.INotify as INotify import qualified System.INotify as INotify -import Utility.ThreadScheduler #endif #if WITH_KQUEUE import qualified Utility.Kqueue as Kqueue +import Control.Concurrent #endif type Pruner = FilePath -> Bool @@ -72,19 +72,41 @@ closingTracked = undefined #endif #endif +/* Starts a watcher thread. The runStartup action is passed a scanner action + * to run, that will return once the initial directory scan is complete. + * Once runStartup returns, the watcher thread continues running, + * and processing events. Returns a DirWatcherHandle that can be used + * to shutdown later. */ #if WITH_INOTIFY -watchDir :: FilePath -> Pruner -> WatchHooks -> (IO () -> IO ()) -> IO () -watchDir dir prune hooks runstartup = INotify.withINotify $ \i -> do +type DirWatcherHandle = INotify.INotify +watchDir :: FilePath -> Pruner -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle +watchDir dir prune hooks runstartup = do + i <- INotify.initINotify runstartup $ INotify.watchDir i dir prune hooks - waitForTermination -- Let the inotify thread run. + return i #else #if WITH_KQUEUE -watchDir :: FilePath -> Pruner -> WatchHooks -> (IO Kqueue.Kqueue -> IO Kqueue.Kqueue) -> IO () +type DirWatcherHandle = ThreadId +watchDir :: FilePath -> Pruner -> WatchHooks -> (IO Kqueue.Kqueue -> IO Kqueue.Kqueue) -> IO DirWatcherHandle watchDir dir ignored hooks runstartup = do kq <- runstartup $ Kqueue.initKqueue dir ignored - Kqueue.runHooks kq hooks + forkIO $ Kqueue.runHooks kq hooks #else -watchDir :: FilePath -> Pruner -> WatchHooks -> (IO () -> IO ()) -> IO () +type DirWatcherHandle = () +watchDir :: FilePath -> Pruner -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle watchDir = undefined #endif #endif + +#if WITH_INOTIFY +stopWatchDir :: DirWatcherHandle -> IO () +stopWatchDir = INotify.killINotify +#else +#if WITH_KQUEUE +stopWatchDir :: DirWatcherHandle -> IO () +stopWatchDir = killThread +#else +stopWatchDir :: DirWatcherHandle -> IO () +stopWatchDir = undefined +#endif +#endif diff --git a/Utility/DiskFree.hs b/Utility/DiskFree.hs index ff7070562..18c7f2ee6 100644 --- a/Utility/DiskFree.hs +++ b/Utility/DiskFree.hs @@ -15,7 +15,7 @@ import Foreign.C.Types import Foreign.C.String import Foreign.C.Error -foreign import ccall unsafe "libdiskfree.h diskfree" c_diskfree +foreign import ccall safe "libdiskfree.h diskfree" c_diskfree :: CString -> IO CULLong getDiskFree :: FilePath -> IO (Maybe Integer) diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index e13afe5d4..eed77805c 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -11,8 +11,7 @@ import qualified Data.ByteString.Lazy as L import System.Posix.Types import Control.Applicative import Control.Concurrent -import Control.Exception (finally, bracket) -import System.Exit +import Control.Exception (bracket) import System.Posix.Env (setEnv, unsetEnv, getEnv) import Common @@ -39,18 +38,21 @@ stdParams params = do readStrict :: [CommandParam] -> IO String readStrict params = do params' <- stdParams params - pOpen ReadFromPipe "gpg" params' hGetContentsStrict + withHandle StdoutHandle createProcessSuccess (proc "gpg" params') $ \h -> do + hSetBinaryMode h True + hGetContentsStrict h {- Runs gpg, piping an input value to it, and returning its stdout, - strictly. -} pipeStrict :: [CommandParam] -> String -> IO String pipeStrict params input = do params' <- stdParams params - (pid, fromh, toh) <- hPipeBoth "gpg" params' - _ <- forkIO $ finally (hPutStr toh input) (hClose toh) - output <- hGetContentsStrict fromh - forceSuccess pid - return output + withBothHandles createProcessSuccess (proc "gpg" params') $ \(to, from) -> do + hSetBinaryMode to True + hSetBinaryMode from True + hPutStr to input + hClose to + hGetContentsStrict from {- Runs gpg with some parameters, first feeding it a passphrase via - --passphrase-fd, then feeding it an input, and passing a handle @@ -70,19 +72,13 @@ passphraseHandle params passphrase a b = do let passphrasefd = [Param "--passphrase-fd", Param $ show pfd] params' <- stdParams $ passphrasefd ++ params - (pid, fromh, toh) <- hPipeBoth "gpg" params' - pid2 <- forkProcess $ do - L.hPut toh =<< a - hClose toh - exitSuccess - hClose toh - ret <- b fromh - - -- cleanup - forceSuccess pid - _ <- getProcessStatus True False pid2 - closeFd frompipe - return ret + closeFd frompipe `after` + withBothHandles createProcessSuccess (proc "gpg" params') go + where + go (to, from) = do + L.hPut to =<< a + hClose to + b from {- Finds gpg public keys matching some string. (Could be an email address, - a key id, or a name. -} diff --git a/Utility/INotify.hs b/Utility/INotify.hs index bf87f4e71..6af022819 100644 --- a/Utility/INotify.hs +++ b/Utility/INotify.hs @@ -160,12 +160,9 @@ tooManyWatches hook dir = do querySysctl :: Read a => [CommandParam] -> IO (Maybe a) querySysctl ps = do - v <- catchMaybeIO $ hPipeFrom "sysctl" $ toCommand ps + v <- catchMaybeIO $ readProcess "sysctl" (toCommand ps) case v of Nothing -> return Nothing - Just (pid, h) -> do - val <- parsesysctl <$> hGetContentsStrict h - void $ getProcessStatus True False $ processID pid - return val + Just s -> return $ parsesysctl s where parsesysctl s = readish =<< lastMaybe (words s) diff --git a/Utility/Kqueue.hs b/Utility/Kqueue.hs index 7e7e653ec..f44893195 100644 --- a/Utility/Kqueue.hs +++ b/Utility/Kqueue.hs @@ -14,8 +14,6 @@ module Utility.Kqueue ( waitChange, Change(..), changedFile, - isAdd, - isDelete, runHooks, ) where @@ -34,19 +32,19 @@ import Control.Concurrent data Change = Deleted FilePath + | DeletedDir FilePath | Added FilePath deriving (Show) isAdd :: Change -> Bool isAdd (Added _) = True isAdd (Deleted _) = False - -isDelete :: Change -> Bool -isDelete = not . isAdd +isAdd (DeletedDir _) = False changedFile :: Change -> FilePath changedFile (Added f) = f changedFile (Deleted f) = f +changedFile (DeletedDir f) = f data Kqueue = Kqueue { kqueueFd :: Fd @@ -59,27 +57,43 @@ type Pruner = FilePath -> Bool type DirMap = M.Map Fd DirInfo -{- A directory, and its last known contents (with filenames relative to it) -} +{- Enough information to uniquely identify a file in a directory, + - but not too much. -} +data DirEnt = DirEnt + { dirEnt :: FilePath -- relative to the parent directory + , _dirInode :: FileID -- included to notice file replacements + , isSubDir :: Bool + } + deriving (Eq, Ord, Show) + +{- A directory, and its last known contents. -} data DirInfo = DirInfo { dirName :: FilePath - , dirCache :: S.Set FilePath + , dirCache :: S.Set DirEnt } deriving (Show) getDirInfo :: FilePath -> IO DirInfo getDirInfo dir = do - contents <- S.fromList . filter (not . dirCruft) - <$> getDirectoryContents dir + l <- filter (not . dirCruft) <$> getDirectoryContents dir + contents <- S.fromList . catMaybes <$> mapM getDirEnt l return $ DirInfo dir contents + where + getDirEnt f = catchMaybeIO $ do + s <- getFileStatus (dir </> f) + return $ DirEnt f (fileID s) (isDirectory s) {- Difference between the dirCaches of two DirInfos. -} (//) :: DirInfo -> DirInfo -> [Change] oldc // newc = deleted ++ added where - deleted = calc Deleted oldc newc - added = calc Added newc oldc - calc a x y = map a . map (dirName x </>) $ - S.toList $ S.difference (dirCache x) (dirCache y) + deleted = calc gendel oldc newc + added = calc genadd newc oldc + gendel x = (if isSubDir x then DeletedDir else Deleted) $ + dirName oldc </> dirEnt x + genadd x = Added $ dirName newc </> dirEnt x + calc a x y = map a $ S.toList $ + S.difference (dirCache x) (dirCache y) {- Builds a map of directories in a tree, possibly pruning some. - Opens each directory in the tree, and records its current contents. -} @@ -99,7 +113,7 @@ scanRecursive topdir prune = M.fromList <$> walk [] [topdir] case mfd of Nothing -> walk c rest Just fd -> do - let subdirs = map (dir </>) $ + let subdirs = map (dir </>) . map dirEnt $ S.toList $ dirCache info walk ((fd, info):c) (subdirs ++ rest) @@ -123,15 +137,16 @@ removeSubDir dirmap dir = do findDirContents :: DirMap -> FilePath -> [FilePath] findDirContents dirmap dir = concatMap absolutecontents $ search where - absolutecontents i = map (dirName i </>) (S.toList $ dirCache i) + absolutecontents i = map (dirName i </>) + (map dirEnt $ S.toList $ dirCache i) search = map snd $ M.toList $ M.filter (\i -> dirName i == dir) dirmap -foreign import ccall unsafe "libkqueue.h init_kqueue" c_init_kqueue +foreign import ccall safe "libkqueue.h init_kqueue" c_init_kqueue :: IO Fd -foreign import ccall unsafe "libkqueue.h addfds_kqueue" c_addfds_kqueue +foreign import ccall safe "libkqueue.h addfds_kqueue" c_addfds_kqueue :: Fd -> CInt -> Ptr Fd -> IO () -foreign import ccall unsafe "libkqueue.h waitchange_kqueue" c_waitchange_kqueue +foreign import ccall safe "libkqueue.h waitchange_kqueue" c_waitchange_kqueue :: Fd -> IO Fd {- Initializes a Kqueue to watch a directory, and all its subdirectories. -} @@ -224,12 +239,14 @@ runHooks kq hooks = do (q', changes) <- waitChange q forM_ changes $ dispatch (kqueueMap q') loop q' - -- Kqueue returns changes for both whole directories - -- being added and deleted, and individual files being - -- added and deleted. - dispatch dirmap change - | isAdd change = withstatus change $ dispatchadd dirmap - | otherwise = callhook delDirHook Nothing change + + dispatch _ change@(Deleted _) = + callhook delHook Nothing change + dispatch _ change@(DeletedDir _) = + callhook delDirHook Nothing change + dispatch dirmap change@(Added _) = + withstatus change $ dispatchadd dirmap + dispatchadd dirmap change s | Files.isSymbolicLink s = callhook addSymlinkHook (Just s) change @@ -237,12 +254,15 @@ runHooks kq hooks = do | Files.isRegularFile s = callhook addHook (Just s) change | otherwise = noop + recursiveadd dirmap change = do let contents = findDirContents dirmap $ changedFile change forM_ contents $ \f -> withstatus (Added f) $ dispatchadd dirmap + callhook h s change = case h hooks of Nothing -> noop Just a -> a (changedFile change) s + withstatus change a = maybe noop (a change) =<< (catchMaybeIO (getSymbolicLinkStatus (changedFile change))) diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs index 0061dfe57..ce6a16283 100644 --- a/Utility/Lsof.hs +++ b/Utility/Lsof.hs @@ -33,11 +33,11 @@ queryDir path = query ["+d", path] - Note: If lsof is not available, this always returns [] ! -} query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)] -query opts = do - (pid, s) <- pipeFrom "lsof" ("-F0can" : opts) - let !r = parse s - void $ getProcessStatus True False $ processID pid - return r +query opts = + withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $ \h -> do + parse <$> hGetContentsStrict h + where + p = proc "lsof" ("-F0can" : opts) {- Parsing null-delimited output like: - diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 3b359139b..e11586467 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -33,7 +33,7 @@ separate c l = unbreak $ break c l | otherwise = (a, tail b) {- Breaks out the first line. -} -firstLine :: String-> String +firstLine :: String -> String firstLine = takeWhile (/= '\n') {- Splits a list into segments that are delimited by items matching diff --git a/Utility/Mounts.hsc b/Utility/Mounts.hsc new file mode 100644 index 000000000..6b69e844a --- /dev/null +++ b/Utility/Mounts.hsc @@ -0,0 +1,69 @@ +{- Interface to mtab (and fstab) + - + - Derived from hsshellscript, originally written by + - Volker Wysk <hsss@volker-wysk.de> + - + - Modified to support BSD and Mac OS X by + - Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU LGPL version 2.1 or higher. + -} + +{-# LANGUAGE ForeignFunctionInterface #-} + +module Utility.Mounts ( + Mntent(..), + getMounts +) where + +import Control.Monad +import Foreign +import Foreign.C +import GHC.IO hiding (finally, bracket) +import Prelude hiding (catch) + +#include "libmounts.h" + +{- This is a stripped down mntent, containing only + - fields available everywhere. -} +data Mntent = Mntent + { mnt_fsname :: String + , mnt_dir :: String + , mnt_type :: String + } deriving (Read, Show, Eq, Ord) + +getMounts :: IO [Mntent] +getMounts = do + h <- c_mounts_start + when (h == nullPtr) $ + throwErrno "getMounts" + mntent <- getmntent h [] + _ <- c_mounts_end h + return mntent + + where + getmntent h c = do + ptr <- c_mounts_next h + if (ptr == nullPtr) + then return $ reverse c + else do + mnt_fsname_str <- #{peek struct mntent, mnt_fsname} ptr >>= peekCString + mnt_dir_str <- #{peek struct mntent, mnt_dir} ptr >>= peekCString + mnt_type_str <- #{peek struct mntent, mnt_type} ptr >>= peekCString + let ent = Mntent + { mnt_fsname = mnt_fsname_str + , mnt_dir = mnt_dir_str + , mnt_type = mnt_type_str + } + getmntent h (ent:c) + +{- Using unsafe imports because the C functions are belived to never block. + - Note that getmntinfo is called with MNT_NOWAIT to avoid possibly blocking; + - while getmntent only accesses a file in /etc (or /proc) that should not + - block. -} +foreign import ccall unsafe "libmounts.h mounts_start" c_mounts_start + :: IO (Ptr ()) +foreign import ccall unsafe "libmounts.h mounts_next" c_mounts_next + :: Ptr () -> IO (Ptr ()) +foreign import ccall unsafe "libmounts.h mounts_end" c_mounts_end + :: Ptr () -> IO CInt diff --git a/Utility/Parallel.hs b/Utility/Parallel.hs new file mode 100644 index 000000000..fcab2a90a --- /dev/null +++ b/Utility/Parallel.hs @@ -0,0 +1,35 @@ +{- parallel processing via threads + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Parallel where + +import Common + +import Control.Concurrent +import Control.Exception + +{- Runs an action in parallel with a set of values, in a set of threads. + - In order for the actions to truely run in parallel, requires GHC's + - threaded runtime, + - + - Returns the values partitioned into ones with which the action succeeded, + - and ones with which it failed. -} +inParallel :: (v -> IO ()) -> [v] -> IO ([v], [v]) +inParallel a l = do + mvars <- mapM thread l + statuses <- mapM takeMVar mvars + return $ reduce $ partition snd $ zip l statuses + where + reduce (x,y) = (map fst x, map fst y) + thread v = do + mvar <- newEmptyMVar + _ <- forkIO $ do + r <- try (a v) :: IO (Either SomeException ()) + case r of + Left _ -> putMVar mvar False + Right _ -> putMVar mvar True + return mvar diff --git a/Utility/Process.hs b/Utility/Process.hs new file mode 100644 index 000000000..5c29bbdfb --- /dev/null +++ b/Utility/Process.hs @@ -0,0 +1,214 @@ +{- 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 Rank2Types #-} + +module Utility.Process ( + module X, + CreateProcess, + StdHandle(..), + readProcessEnv, + forceSuccessProcess, + checkSuccessProcess, + createProcessSuccess, + createProcessChecked, + createBackgroundProcess, + withHandle, + withBothHandles, + createProcess, + runInteractiveProcess, + writeReadProcess, + readProcess +) 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, runInteractiveProcess, readProcess) +import System.Exit +import System.IO +import System.Log.Logger + +import Utility.Misc + +type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a + +data StdHandle = StdinHandle | StdoutHandle | StderrHandle + deriving (Eq) + +{- Like readProcess, but allows specifying the environment, and does + - not mess with stdin. -} +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 + } + +{- Waits for a ProcessHandle, and throws an exception 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 -> error $ showCmd p ++ " exited " ++ show n + +{- Waits for a ProcessHandle and returns True if it exited successfully. -} +checkSuccessProcess :: ProcessHandle -> IO Bool +checkSuccessProcess pid = do + code <- waitForProcess pid + return $ code == ExitSuccess + +{- 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 + - an action on its exit code. -} +createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner +createProcessChecked checker p a = do + t@(_, _, _, pid) <- createProcess p + r <- a t + _ <- checker pid + 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 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 + } + +{- 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 + , maybe "" show (env 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 + +{- Wrappers for System.Process functions that do debug logging. + - + - More could be added, but these are the only ones I usually need. + -} + +createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcess p = do + debugProcess p + System.Process.createProcess p + +runInteractiveProcess + :: FilePath + -> [String] + -> Maybe FilePath + -> Maybe [(String, String)] + -> IO (Handle, Handle, Handle, ProcessHandle) +runInteractiveProcess f args c e = do + debugProcess $ (proc f args) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + System.Process.runInteractiveProcess f args c e + +{- I think this is a more descriptive name than System.Process.readProcess. -} +writeReadProcess + :: FilePath + -> [String] + -> String + -> IO String +writeReadProcess f args input = do + debugProcess $ (proc f args) { std_out = CreatePipe, std_in = CreatePipe } + System.Process.readProcess f args input + +{- Normally, when reading from a process, it does not need to be fed any + - input. -} +readProcess + :: FilePath + -> [String] + -> IO String +readProcess f args = do + debugProcess $ (proc f args) { std_out = CreatePipe } + System.Process.readProcess f args [] diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs index aedf27137..19dd707b8 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -1,6 +1,6 @@ {- safely running shell commands - - - Copyright 2010-2011 Joey Hess <joey@kitenet.net> + - Copyright 2010-2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -8,11 +8,9 @@ module Utility.SafeCommand where import System.Exit -import qualified System.Posix.Process -import System.Posix.Process hiding (executeFile) -import System.Posix.Signals +import Utility.Process +import System.Process (env) import Data.String.Utils -import System.Log.Logger import Control.Applicative {- A type for parameters passed to a shell command. A command can @@ -42,7 +40,7 @@ boolSystem :: FilePath -> [CommandParam] -> IO Bool boolSystem command params = boolSystemEnv command params Nothing boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool -boolSystemEnv command params env = dispatch <$> safeSystemEnv command params env +boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ where dispatch ExitSuccess = True dispatch _ = False @@ -51,36 +49,13 @@ boolSystemEnv command params env = dispatch <$> safeSystemEnv command params env safeSystem :: FilePath -> [CommandParam] -> IO ExitCode safeSystem command params = safeSystemEnv command params Nothing -{- SIGINT(ctrl-c) is allowed to propigate and will terminate the program. -} +{- Unlike many implementations of system, SIGINT(ctrl-c) is allowed + - to propigate and will terminate the program. -} safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode -safeSystemEnv 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 code) -> return code - _ -> error $ "unknown error running " ++ command - 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 +safeSystemEnv command params environ = do + (_, _, _, pid) <- createProcess (proc command $ toCommand params) + { env = environ } + waitForProcess pid {- Escapes a filename or other parameter to be safely able to be exposed to - the shell. -} diff --git a/Utility/TSet.hs b/Utility/TSet.hs new file mode 100644 index 000000000..24d345477 --- /dev/null +++ b/Utility/TSet.hs @@ -0,0 +1,39 @@ +{- Transactional sets + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + -} + +module Utility.TSet where + +import Common + +import Control.Concurrent.STM + +type TSet = TChan + +runTSet :: STM a -> IO a +runTSet = atomically + +newTSet :: IO (TSet a) +newTSet = atomically newTChan + +{- Gets the contents of the TSet. Blocks until at least one item is + - present. -} +getTSet :: TSet a -> IO [a] +getTSet tset = runTSet $ do + c <- readTChan tset + go [c] + where + go l = do + v <- tryReadTChan tset + case v of + Nothing -> return l + Just c -> go (c:l) + +{- Puts items into a TSet. -} +putTSet :: TSet a -> [a] -> IO () +putTSet tset vs = runTSet $ mapM_ (writeTChan tset) vs + +{- Put a single item into a TSet. -} +putTSet1 :: TSet a -> a -> IO () +putTSet1 tset v = void $ runTSet $ writeTChan tset v diff --git a/Utility/TempFile.hs b/Utility/TempFile.hs index 4dcbf1cca..62e0fc859 100644 --- a/Utility/TempFile.hs +++ b/Utility/TempFile.hs @@ -9,7 +9,7 @@ module Utility.TempFile where import Control.Exception (bracket) import System.IO -import System.Posix.Process hiding (executeFile) +import System.Posix.Process import System.Directory import Utility.Exception diff --git a/Utility/Types/DirWatcher.hs b/Utility/Types/DirWatcher.hs index c828a0593..ba7eae6a1 100644 --- a/Utility/Types/DirWatcher.hs +++ b/Utility/Types/DirWatcher.hs @@ -20,3 +20,6 @@ data WatchHooks = WatchHooks , delDirHook :: Hook FilePath , errHook :: Hook String -- error message } + +mkWatchHooks :: WatchHooks +mkWatchHooks = WatchHooks Nothing Nothing Nothing Nothing Nothing diff --git a/Utility/libmounts.c b/Utility/libmounts.c new file mode 100644 index 000000000..8669f33ea --- /dev/null +++ b/Utility/libmounts.c @@ -0,0 +1,103 @@ +/* mounted filesystems, C mini-library + * + * Copyright (c) 1980, 1989, 1993, 1994 + * The Regents of the University of California. All rights reserved. + * Copyright (c) 2001 + * David Rufino <daverufino@btinternet.com> + * Copyright 2012 + * Joey Hess <joey@kitenet.net> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. Neither the name of the University nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +#include "libmounts.h" + +#ifdef GETMNTENT +/* direct passthrough the getmntent */ +FILE *mounts_start (void) { + return setmntent("/etc/mtab", "r"); +} +int mounts_end (FILE *fp) { + return endmntent(fp); +} +struct mntent *mounts_next (FILE *fp) { + return getmntent(fp); +} +#endif + +#ifdef GETMNTINFO +/* getmntent emulation using getmntinfo */ +FILE *mounts_start (void) { + return ((FILE *)0x1); /* dummy non-NULL FILE pointer, not used */ +} +int mounts_end (FILE *fp) { + return 1; +} + +static struct mntent _mntent; + +static struct mntent *statfs_to_mntent (struct statfs *mntbuf) { + _mntent.mnt_fsname = mntbuf->f_mntfromname; + _mntent.mnt_dir = mntbuf->f_mntonname; + _mntent.mnt_type = mntbuf->f_fstypename; + + _mntent.mnt_opts = '\0'; + _mntent.mnt_freq = 0; + _mntent.mnt_passno = 0; + + return (&_mntent); +} + +static int pos = -1; +static int mntsize = -1; +struct statfs *mntbuf = NULL; + +struct mntent *mounts_next (FILE *fp) { + + if (pos == -1 || mntsize == -1) + mntsize = getmntinfo(&mntbuf, MNT_NOWAIT); + ++pos; + if (pos == mntsize) { + pos = mntsize = -1; + mntbuf = NULL; + return NULL; + } + + return (statfs_to_mntent(&mntbuf[pos])); +} +#endif + +#ifdef UNKNOWN +/* dummy, do-nothing version */ +FILE *mounts_start (void) { + return ((FILE *)0x1); +} +int mounts_end (FILE *fp) { + return 1; +} +struct mntent *mounts_next (FILE *fp) { + return NULL; +} +#endif diff --git a/Utility/libmounts.h b/Utility/libmounts.h new file mode 100644 index 000000000..b65978629 --- /dev/null +++ b/Utility/libmounts.h @@ -0,0 +1,33 @@ +/* Include appropriate headers for the OS, and define what will be used. */ +#if defined (__FreeBSD__) || defined (__APPLE__) +# include <sys/param.h> +# include <sys/ucred.h> +# include <sys/mount.h> +# define GETMNTINFO +#else +#if defined (__linux__) || defined (__FreeBSD_kernel__) +/* Linux or Debian kFreeBSD */ +#include <mntent.h> +# define GETMNTENT +#else +# warning mounts listing code not available for this OS +# define UNKNOWN +#endif +#endif + +#include <stdio.h> + +#ifndef GETMNTENT +struct mntent { + char *mnt_fsname; + char *mnt_dir; + char *mnt_type; + char *mnt_opts; /* not filled in */ + int mnt_freq; /* not filled in */ + int mnt_passno; /* not filled in */ +}; +#endif + +FILE *mounts_start (void); +int mounts_end (FILE *fp); +struct mntent *mounts_next (FILE *fp); |