diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ Summary: This library is licensed under Apache-2.0, BSD2, and MIT. Some code in this library is derived from the process library, whose license -is in the "The process Library" section. +is in the "Library" section. ----------------------------------------------------------------------------- @@ -268,10 +268,10 @@ ----------------------------------------------------------------------------- -== The process Library == +== Library == -This library (libraries/process) is derived from code from two -sources: +The libraries (process and directory) are derived from code from two +sources: * Code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below), diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ Traditional `String` is notorious: -- Up to 40 bytes (five words) required for one character (the List constructor, the pointer to the Char constructor, the Char constructor, the actual Char value, and the pointer to the next List constructor) +- 24 bytes (three words) required for one character (the List constructor, the actual Char value, and the pointer to the next List constructor). 24x memory consumption. - Heap fragmentation causing malloc/free overhead - A lot of pointer chasing for reading, devastating the cache hit rate - A lot of pointer chasing plus a lot of heap object allocation for manipulation (appending, slicing, etc.) diff --git a/cbits/processFlags.h b/cbits/processFlags.h deleted file mode 100644 --- a/cbits/processFlags.h +++ /dev/null @@ -1,11 +0,0 @@ -/* ---------------------------------------------------------------------------- - (c) The University of Glasgow 2004 - - Flags used in runProcess.c and for System.Process.Internals - ------------------------------------------------------------------------- */ - -#define RUN_PROCESS_IN_CLOSE_FDS 0x1 -#define RUN_PROCESS_IN_NEW_GROUP 0x2 -#define RUN_PROCESS_DETACHED 0x4 -#define RUN_PROCESS_NEW_SESSION 0x8 -#define RUN_PROCESS_NEW_CONSOLE 0x10 diff --git a/rawfilepath.cabal b/rawfilepath.cabal --- a/rawfilepath.cabal +++ b/rawfilepath.cabal @@ -1,5 +1,5 @@ name: rawfilepath -version: 0.1.1 +version: 0.2.0 synopsis: Use RawFilePath instead of FilePath description: Please see README.md homepage: https://github.com/xtendo-org/rawfilepath#readme @@ -18,16 +18,19 @@ hs-source-dirs: src exposed-modules: Data.ByteString.RawFilePath, - System.RawFilePath - System.Process.RawFilePath + RawFilePath + RawFilePath.Directory + RawFilePath.Process other-modules: + RawFilePath.Directory.Internal RawFilePath.Import - System.Process.RawFilePath.Common - System.Process.RawFilePath.Internal - System.Process.RawFilePath.Posix + RawFilePath.Process.Basic + RawFilePath.Process.Common + RawFilePath.Process.Internal + RawFilePath.Process.Posix + RawFilePath.Process.Utility c-sources: cbits/runProcess.c - cbits/processFlags.h cbits/processFlags.c include-dirs: cbits build-depends: diff --git a/src/RawFilePath.hs b/src/RawFilePath.hs new file mode 100644 --- /dev/null +++ b/src/RawFilePath.hs @@ -0,0 +1,9 @@ +module RawFilePath + ( module Module + , RawFilePath + ) where + +import System.Posix.ByteString (RawFilePath) + +import RawFilePath.Directory as Module +import RawFilePath.Process as Module diff --git a/src/RawFilePath/Directory.hs b/src/RawFilePath/Directory.hs new file mode 100644 --- /dev/null +++ b/src/RawFilePath/Directory.hs @@ -0,0 +1,229 @@ +----------------------------------------------------------------------------- +-- | +-- Module : RawFilePath.Directory +-- Copyright : (C) 2004 The University of Glasgow. (C) 2017 XT et al. +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : e@xtendo.org +-- Stability : experimental +-- Portability : POSIX +-- +-- This is the module for the 'RawFilePath' version of functions in the +-- @directory@ package. +-- +----------------------------------------------------------------------------- + +module RawFilePath.Directory + ( + -- ** Nondestructive (read-only) + doesPathExist + , doesFileExist + , doesDirectoryExist + , getHomeDirectory + , getTemporaryDirectory + , listDirectory + , getDirectoryFiles + -- ** Destructive + , createDirectory + , createDirectoryIfMissing + , removeFile + , removeDirectory + , removeDirectoryRecursive + ) where + +import RawFilePath.Import + +-- extra modules + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified System.Posix.ByteString as U -- U for Unix + +-- local modules + +import RawFilePath.Directory.Internal + +-- | Test whether the given path points to an existing filesystem object. If +-- the user lacks necessary permissions to search the parent directories, this +-- function may return false even if the file does actually exist. +doesPathExist :: RawFilePath -> IO Bool +doesPathExist path = (True <$ U.getFileStatus path) `catchIOError` + const (return False) + +-- | Return 'True' if the argument file exists and is either a directory or a +-- symbolic link to a directory, and 'False' otherwise. +doesDirectoryExist :: RawFilePath -> IO Bool +doesDirectoryExist path = pathIsDirectory path `catchIOError` + const (return False) + +-- | Return 'True' if the argument file exists and is not a directory, and +-- 'False' otherwise. +doesFileExist :: RawFilePath -> IO Bool +doesFileExist path = (not <$> pathIsDirectory path) `catchIOError` + const (return False) + +-- | Returns the current user's home directory. More specifically, the value +-- of the @HOME@ environment variable. +-- +-- The directory returned is expected to be writable by the current user, but +-- note that it isn't generally considered good practice to store +-- application-specific data here; use 'getXdgDirectory' or +-- 'getAppUserDataDirectory' instead. +-- +-- The operation may fail with: +-- +-- * 'UnsupportedOperation' +-- The operating system has no notion of home directory. +-- +-- * 'isDoesNotExistError' +-- The home directory for the current user does not exist, or +-- cannot be found. +getHomeDirectory :: IO (Maybe RawFilePath) +getHomeDirectory = U.getEnv "HOME" + +-- | Return the current directory for temporary files. It first returns the +-- value of the @TMPDIR@ environment variable or \"\/tmp\" if the variable +-- isn\'t defined. +getTemporaryDirectory :: IO ByteString +getTemporaryDirectory = fromMaybe "/tmp" <$> U.getEnv "TMPDIR" + +-- | Get a list of files in the specified directory, excluding "." and ".." +-- +-- > ghci> listDirectory "/" +-- > ["home","sys","var","opt","lib64","sbin","usr","srv","dev","lost+found","bin","tmp","run","root","boot","proc","etc","lib"] +listDirectory + :: RawFilePath -- ^ The path of directory to inspect + -> IO [RawFilePath] -- ^ A list of files in the directory +listDirectory dirPath = filter f <$> getDirectoryFiles dirPath + where + f p = p /= "." && p /= ".." + +-- | Get a list of files in the specified directory, including "." and ".." +-- +-- > ghci> getDirectoryFiles "/" +-- > ["home","sys","var","opt","..","lib64","sbin","usr","srv","dev","lost+found","mnt","bin","tmp","run","root","boot",".","proc","etc","lib"] +getDirectoryFiles + :: RawFilePath -- ^ The path of directory to inspect + -> IO [RawFilePath] -- ^ A list of files in the directory +getDirectoryFiles dirPath = bracket open close repeatRead + where + open = U.openDirStream dirPath + close = U.closeDirStream + repeatRead stream = do + d <- U.readDirStream stream + if B.length d == 0 then return [] else do + rest <- repeatRead stream + return $ d : rest + +-- | Create a new directory. +-- +-- > ghci> createDirectory "/tmp/mydir" +-- > ghci> getDirectoryFiles "/tmp/mydir" +-- > [".",".."] +-- > ghci> createDirectory "/tmp/mydir/anotherdir" +-- > ghci> getDirectoryFiles "/tmp/mydir" +-- > [".","..","anotherdir"] +createDirectory :: RawFilePath -> IO () +createDirectory dir = U.createDirectory dir 0o755 + +-- | Create a new directory if it does not already exist. If the first +-- argument is 'True' the function will also create all parent directories +-- when they are missing. +createDirectoryIfMissing + :: Bool -- ^ Create parent directories or not + -> RawFilePath -- ^ The path of the directory to create + -> IO () +createDirectoryIfMissing willCreateParents path + | willCreateParents = createDirs parents + | otherwise = createDir path ioError + where + createDirs [] = return () + createDirs [dir] = createDir dir ioError + createDirs (dir : dirs) = createDir dir $ \ _ -> + -- Create parent directories (recursively) only when they are missing + createDirs dirs >> createDir dir ioError + createDir dir notExistHandler = tryIOError (createDirectory dir) >>= \ case + Right () -> return () + Left e + | isDoesNotExistError e -> notExistHandler e + -- createDirectory (and indeed POSIX mkdir) does not distinguish + -- between a dir already existing and a file already existing. So we + -- check for it here. Unfortunately there is a slight race condition + -- here, but we think it is benign. It could report an exeption in + -- the case that the dir did exist but another process deletes the + -- directory and creates a file in its place before we can check + -- that the directory did indeed exist. We also follow this path + -- when we get a permissions error, as trying to create "." when in + -- the root directory on Windows fails with + -- CreateDirectory ".": permission denied (Access is denied.) + -- This caused GHCi to crash when loading a module in the root + -- directory. + | isAlreadyExistsError e + || isPermissionError e -> do + canIgnore <- catchIOError (pathIsDirectory dir) $ \ _ -> + return (isAlreadyExistsError e) + unless canIgnore (ioError e) + | otherwise -> ioError e + parents = reverse $ scanl1 (+/+) $ B.split (w8 '/') $ stripSlash path + +-- | Remove a file. This function internally calls @unlink@. +removeFile :: RawFilePath -> IO () +removeFile = U.removeLink + +-- | Remove a directory. The target directory needs to be empty; Otherwise an +-- exception will be thrown. +removeDirectory :: RawFilePath -> IO () +removeDirectory = U.removeDirectory + +-- | Remove an existing directory /dir/ together with its contents and +-- subdirectories. Within this directory, symbolic links are removed without +-- affecting their targets. +removeDirectoryRecursive :: RawFilePath -> IO () +removeDirectoryRecursive path = + (`ioeAddLocation` "removeDirectoryRecursive") `modifyIOError` do + m <- U.getSymbolicLinkStatus path + case fileTypeFromMetadata m of + Directory -> + removeContentsRecursive path + DirectoryLink -> + ioError (err `ioeSetErrorString` "is a directory symbolic link") + _ -> + ioError (err `ioeSetErrorString` "not a directory") + where err = mkIOError InappropriateType "" Nothing (Just (B8.unpack path)) + +-- | Remove an existing file or directory at /path/ together with its contents +-- and subdirectories. Symbolic links are removed without affecting their the +-- targets. +removePathRecursive :: RawFilePath -> IO () +removePathRecursive path = + (`ioeAddLocation` "removePathRecursive") `modifyIOError` do + m <- U.getSymbolicLinkStatus path + case fileTypeFromMetadata m of + Directory -> removeContentsRecursive path + DirectoryLink -> U.removeDirectory path + _ -> U.removeLink path + +-- | Remove the contents of the directory /dir/ recursively. Symbolic links +-- are removed without affecting their the targets. +removeContentsRecursive :: RawFilePath -> IO () +removeContentsRecursive path = + (`ioeAddLocation` "removeContentsRecursive") `modifyIOError` do + cont <- listDirectory path + mapM_ removePathRecursive [path +/+ x | x <- cont] + U.removeDirectory path + + +w8 :: Char -> Word8 +w8 = fromIntegral . ord + +stripSlash :: ByteString -> ByteString +stripSlash p = if B.last p == w8 '/' then B.init p else p + +pathIsDirectory :: RawFilePath -> IO Bool +pathIsDirectory path = U.isDirectory <$> U.getFileStatus path + + +-- An extremely simplistic approach for path concatenation. +infixr 5 +/+ +(+/+) :: RawFilePath -> RawFilePath -> RawFilePath +a +/+ b = mconcat [a, "/", b] diff --git a/src/RawFilePath/Directory/Internal.hs b/src/RawFilePath/Directory/Internal.hs new file mode 100644 --- /dev/null +++ b/src/RawFilePath/Directory/Internal.hs @@ -0,0 +1,24 @@ +module RawFilePath.Directory.Internal where + +import RawFilePath.Import + +import qualified System.Posix.ByteString as U + +ioeAddLocation :: IOError -> String -> IOError +ioeAddLocation e loc = ioeSetLocation e newLoc + where + newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc + oldLoc = ioeGetLocation e + +data FileType + = File + | SymbolicLink + | Directory + | DirectoryLink + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +fileTypeFromMetadata :: U.FileStatus -> FileType +fileTypeFromMetadata stat + | U.isSymbolicLink stat = SymbolicLink + | U.isDirectory stat = Directory + | otherwise = File diff --git a/src/RawFilePath/Import.hs b/src/RawFilePath/Import.hs --- a/src/RawFilePath/Import.hs +++ b/src/RawFilePath/Import.hs @@ -4,20 +4,23 @@ , RawFilePath ) where +import Control.Applicative as Module import Control.Concurrent as Module import Control.Exception as Module import Control.Monad as Module import Data.Bits as Module +import Data.Char as Module +import Data.Functor as Module import Data.Maybe as Module import Data.Monoid as Module import Data.Typeable as Module import Data.Word as Module import Foreign as Module hiding (void) import Foreign.C as Module -import GHC.IO.Device as Module hiding (close, getEcho, setEcho) +import GHC.IO.Device as Module hiding (close, getEcho, setEcho, Directory) import GHC.IO.Encoding as Module import GHC.IO.Exception as Module -import GHC.IO.Handle.FD as Module +import GHC.IO.Handle.FD as Module hiding (fdToHandle) import GHC.IO.Handle.Internals as Module import GHC.IO.Handle.Types as Module import GHC.IO.IOMode as Module diff --git a/src/RawFilePath/Process.hs b/src/RawFilePath/Process.hs new file mode 100644 --- /dev/null +++ b/src/RawFilePath/Process.hs @@ -0,0 +1,109 @@ +----------------------------------------------------------------------------- +-- | +-- Module : RawFilePath.Process +-- Copyright : (C) XT et al. 2017 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : e@xtendo.org +-- Stability : experimental +-- Portability : POSIX +-- +-- Welcome to @RawFilePath.Process@, a small part of the Haskell +-- community's effort to purge 'String' for the Greater Good. +-- +-- With this module, you can create (and interact with) sub-processes without +-- the encoding problem of 'String'. The command and its arguments, all +-- 'ByteString's, never get converted from/to 'String' internally on its way +-- to the actual syscall. It also avoids the time/space waste of 'String'. +-- +-- The interface, unlike the original @process@ package, uses types to prevent +-- unnecessary runtime errors when obtaining 'Handle's. This is inspired by +-- the @typed-process@ package which is awesome, although this module is much +-- simpler; it doesn't introduce any new requirement of language extension or +-- library package (for the sake of portability). +-- +-- 'Handle' (accessible with 'processStdin', 'processStdout', and +-- 'processStderr') is what you can use to interact with the sub-process. For +-- example, use 'Data.ByteString.hGetContents' from "Data.ByteString" to read +-- from a 'Handle' as a 'ByteString'. +-- +-- == Example +-- +-- @ +-- {-\# language OverloadedStrings \#-} +-- +-- import RawFilePath.Process +-- import qualified Data.ByteString as B +-- +-- main :: IO () +-- main = do +-- p <- 'startProcess' $ 'proc' "echo" ["hello"] +-- \`setStdout\` 'CreatePipe' +-- result <- B.hGetContents ('processStdout' p) +-- _ <- 'waitForProcess' p +-- +-- print (result == "hello\\n") +-- @ +-- +----------------------------------------------------------------------------- + + +module RawFilePath.Process + ( + -- ** Configuring process + -- $configuring + ProcessConf + , proc + + -- *** Configuring process standard streams + , StreamType + , CreatePipe(..) + , Inherit(..) + , NoStream(..) + , UseHandle(..) + , setStdin + , setStdout + , setStderr + + -- ** Running process + , Process + , startProcess + + -- ** Obtaining process streams + -- $obtaining + , processStdin + , processStdout + , processStderr + + -- ** Process completion + , stopProcess + , terminateProcess + , waitForProcess + + -- ** Utility functions + -- $utility + , module RawFilePath.Process.Utility + + ) where + +-- local modules + +import RawFilePath.Process.Basic +import RawFilePath.Process.Common +import RawFilePath.Process.Utility + +-- $configuring +-- +-- Configuration of how a new sub-process will be launched. +-- +-- $obtaining +-- +-- As the type signature suggests, these functions only work on processes +-- whose stream in configured to 'CreatePipe'. This is the type-safe way of +-- obtaining 'Handle's instead of returning 'Maybe' 'Handle's like the +-- @process@ package does. +-- +-- $utility +-- +-- These are utility functions; they can be implemented with the primary +-- functions above. They are provided for convenience. diff --git a/src/RawFilePath/Process/Basic.hs b/src/RawFilePath/Process/Basic.hs new file mode 100644 --- /dev/null +++ b/src/RawFilePath/Process/Basic.hs @@ -0,0 +1,74 @@ +module RawFilePath.Process.Basic where + +-- base modules + +import RawFilePath.Import hiding (ClosedHandle) + +-- local modules + +import RawFilePath.Process.Common +import RawFilePath.Process.Internal +import RawFilePath.Process.Posix + +-- | Start a new sub-process with the given configuration. +startProcess + :: (StreamType stdin, StreamType stdout, StreamType stderr) + => ProcessConf stdin stdout stderr + -> IO (Process stdin stdout stderr) +startProcess = createProcessInternal + +-- | Stop a sub-process. For now it simply calls 'terminateProcess' and then +-- 'waitForProcess'. +stopProcess :: Process stdin stdout stderr -> IO ExitCode +stopProcess p = do + terminateProcess p + waitForProcess p + +-- | Wait (block) for a sub-process to exit and obtain its exit code. +waitForProcess + :: Process stdin stdout stderr + -> IO ExitCode +waitForProcess ph = lockWaitpid $ do + p_ <- modifyProcessHandle ph $ \ p_ -> return (p_,p_) + case p_ of + ClosedHandle e -> return e + OpenHandle h -> do + e <- alloca $ \ pret -> do + -- don't hold the MVar while we call c_waitForProcess... + throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret) + modifyProcessHandle ph $ \ p_' -> + case p_' of + ClosedHandle e -> return (p_', e) + OpenExtHandle{} -> return (p_', ExitFailure (-1)) + OpenHandle ph' -> do + closePHANDLE ph' + code <- peek pret + let e = if code == 0 + then ExitSuccess + else ExitFailure (fromIntegral code) + return (ClosedHandle e, e) + when delegatingCtlc $ + endDelegateControlC e + return e + OpenExtHandle _ _job _iocp -> + return $ ExitFailure (-1) + where + -- If more than one thread calls `waitpid` at a time, `waitpid` will + -- return the exit code to one of them and (-1) to the rest of them, + -- causing an exception to be thrown. + -- Cf. https://github.com/haskell/process/issues/46, and + -- https://github.com/haskell/process/pull/58 for further discussion + lockWaitpid m = withMVar (waitpidLock ph) $ \ () -> m + delegatingCtlc = mbDelegateCtlc ph + +-- | Terminate a sub-process by sending SIGTERM to it. +terminateProcess :: Process stdin stdout stderr -> IO () +terminateProcess p = withProcessHandle p $ \ case + ClosedHandle _ -> return () + OpenExtHandle{} -> error + "terminateProcess with OpenExtHandle should not happen on POSIX." + OpenHandle h -> do + throwErrnoIfMinus1Retry_ "terminateProcess" $ c_terminateProcess h + return () + -- does not close the handle, we might want to try terminating it + -- again, or get its exit code. diff --git a/src/RawFilePath/Process/Common.hs b/src/RawFilePath/Process/Common.hs new file mode 100644 --- /dev/null +++ b/src/RawFilePath/Process/Common.hs @@ -0,0 +1,243 @@ +module RawFilePath.Process.Common + ( Process(..) + , ProcessConf(..) + , proc + , processStdin + , processStdout + , processStderr + , StreamType + , mbFd + , willCreateHandle + , CreatePipe(..) + , Inherit(..) + , NoStream(..) + , UseHandle(..) + , setStdin + , setStdout + , setStderr + + , PHANDLE + , ProcessHandle__(..) + , modifyProcessHandle + , withProcessHandle + , fdStdin + , fdStdout + , fdStderr + , mbPipe + ) where + +import RawFilePath.Import + +-- extra modules + +import System.Posix.Internals (FD) +import qualified GHC.IO.FD as FD + +-- Original declarations + +-- | The process configuration that is needed for creating new processes. Use +-- 'proc' to make one. +data ProcessConf stdin stdout stderr = ProcessConf + { cmdargs :: [ByteString] + -- ^ Executable & arguments, or shell command + , cwd :: Maybe RawFilePath + -- ^ Optional path to the working directory for the new process + , env :: Maybe [(ByteString, ByteString)] + -- ^ Optional environment (otherwise inherit from the current process) + , cfgStdin :: stdin + -- ^ How to determine stdin + , cfgStdout :: stdout + -- ^ How to determine stdout + , cfgStderr :: stderr + -- ^ How to determine stderr + , closeFds :: Bool + -- ^ Close all file descriptors except stdin, stdout and stderr in the new + -- process + , createGroup :: Bool + -- ^ Create a new process group + , delegateCtlc :: Bool + -- ^ Delegate control-C handling. Use this for interactive console + -- processes to let them handle control-C themselves (see below for + -- details). + , createNewConsole :: Bool + -- ^ Use the windows CREATE_NEW_CONSOLE flag when creating the process; + -- does nothing on other platforms. + -- + -- Default: @False@ + , newSession :: Bool + -- ^ Use posix setsid to start the new process in a new session; does nothing on other platforms. + , childGroup :: Maybe GroupID + -- ^ Use posix setgid to set child process's group id. + -- + -- Default: @Nothing@ + , childUser :: Maybe UserID + -- ^ Use posix setuid to set child process's user id. + -- + -- Default: @Nothing@ + } + +-- | Create a process configuration with the default settings. +proc + :: RawFilePath -- ^ Command to run + -> [ByteString] -- ^ Arguments to the command + -> ProcessConf Inherit Inherit Inherit +proc cmd args = ProcessConf + { cmdargs = cmd : args + , cwd = Nothing + , env = Nothing + , cfgStdin = Inherit + , cfgStdout = Inherit + , cfgStderr = Inherit + , closeFds = False + , createGroup = False + , delegateCtlc = False + , createNewConsole = False + , newSession = False + , childGroup = Nothing + , childUser = Nothing + } + +-- | Control how the standard input of the process will be initialized. +setStdin + :: (StreamType newStdin) + => ProcessConf oldStdin stdout stderr + -> newStdin + -> ProcessConf newStdin stdout stderr +setStdin p newStdin = p { cfgStdin = newStdin } +infixl 4 `setStdin` + +-- | Control how the standard output of the process will be initialized. +setStdout + :: (StreamType newStdout) + => ProcessConf stdin oldStdout stderr + -> newStdout + -> ProcessConf stdin newStdout stderr +setStdout p newStdout = p { cfgStdout = newStdout } +infixl 4 `setStdout` + +-- | Control how the standard error of the process will be initialized. +setStderr + :: (StreamType newStderr) + => ProcessConf stdin stdout oldStderr + -> newStderr + -> ProcessConf stdin stdout newStderr +setStderr p newStderr = p { cfgStderr = newStderr } +infixl 4 `setStderr` + +-- | The process type. The three type variables denote how its standard +-- streams were initialized. +data Process stdin stdout stderr = Process + { procStdin :: Maybe Handle + , procStdout :: Maybe Handle + , procStderr :: Maybe Handle + , phandle :: !(MVar ProcessHandle__) + , mbDelegateCtlc :: !Bool + , waitpidLock :: !(MVar ()) + } + +-- | Take a process and return its standard input handle. +processStdin :: Process CreatePipe stdout stderr -> Handle +processStdin Process{..} = fromMaybe err procStdin + where + err = error "This can't happen: stdin is CreatePipe but missing" + +-- | Take a process and return its standard output handle. +processStdout :: Process stdin CreatePipe stderr -> Handle +processStdout Process{..} = fromMaybe err procStdout + where + err = error "This can't happen: stdout is CreatePipe but missing" + +-- | Take a process and return its standard error handle. +processStderr :: Process stdin stdout CreatePipe -> Handle +processStderr Process{..} = fromMaybe err procStderr + where + err = error "This can't happen: stderr is CreatePipe but missing" + +-- | Create a new pipe for the stream. You get a new 'Handle'. +data CreatePipe = CreatePipe deriving Show +-- | Inherit the parent (current) process handle. The child will share the +-- stream. For example, if the child writes anything to stdout, it will all go +-- to the parent's stdout. +data Inherit = Inherit deriving Show +-- | No stream handle will be passed. Use when you don't want to communicate +-- with a stream. For example, to run something silently. +data NoStream = NoStream deriving Show +-- | Use the supplied 'Handle'. +data UseHandle = UseHandle Handle deriving Show + +-- | The class of types that determine the standard stream of a sub-process. +-- You can decide how to initialize the standard streams (stdin, stdout, and +-- stderr) of a sub-process with the instances of this class. +class StreamType c where + mbFd :: FD -> c -> IO FD + willCreateHandle :: c -> Bool +#if __GLASGOW_HASKELL__ >= 780 + mbFd = undefined + willCreateHandle = undefined + {-# MINIMAL #-} +#endif +instance StreamType CreatePipe where + mbFd _ _ = return (-1) + willCreateHandle _ = True +instance StreamType Inherit where + mbFd std _ = return std + willCreateHandle _ = False +instance StreamType NoStream where + mbFd _ _ = return (-2) + willCreateHandle _ = False +instance StreamType UseHandle where + mbFd _std (UseHandle hdl) = + withHandle "" hdl $ \Handle__{haDevice=dev,..} -> case cast dev of + Just fd -> do + -- clear the O_NONBLOCK flag on this FD, if it is set, since + -- we're exposing it externally (see #3316 of 'process') + fd' <- FD.setNonBlockingMode fd False + return (Handle__{haDevice=fd',..}, FD.fdFD fd') + Nothing -> ioError $ mkIOError illegalOperationErrorType + "createProcess" (Just hdl) Nothing + `ioeSetErrorString` "handle is not a file descriptor" + willCreateHandle _ = False + +-- Declarations from the process package (modified) + +type PHANDLE = CPid + +data ProcessHandle__ = OpenHandle PHANDLE + | OpenExtHandle PHANDLE PHANDLE PHANDLE + | ClosedHandle ExitCode + +modifyProcessHandle + :: Process stdin stdout stderr + -> (ProcessHandle__ -> IO (ProcessHandle__, a)) + -> IO a +modifyProcessHandle p = modifyMVar (phandle p) + +withProcessHandle + :: Process stdin stdout stderr -> (ProcessHandle__ -> IO a) -> IO a +withProcessHandle p = withMVar (phandle p) + +fdStdin, fdStdout, fdStderr :: FD +fdStdin = 0 +fdStdout = 1 +fdStderr = 2 + +mbPipe :: StreamType c => c -> Ptr FD -> IOMode -> IO (Maybe Handle) +mbPipe streamConf pfd mode = if willCreateHandle streamConf + then fmap Just (pfdToHandle pfd mode) + else return Nothing + +pfdToHandle :: Ptr FD -> IOMode -> IO Handle +pfdToHandle pfd mode = do + fd <- peek pfd + let filepath = "fd:" ++ show fd + (fD,fd_type) <- FD.mkFD (fromIntegral fd) mode + (Just (Stream,0,0)) -- avoid calling fstat() + False {-is_socket-} + False {-non-blocking-} + fD' <- FD.setNonBlockingMode fD True -- see #3316 +#if __GLASGOW_HASKELL__ >= 704 + enc <- getLocaleEncoding +#else + let enc = localeEncoding +#endif + mkHandleFromFD fD' fd_type filepath mode False {-is_socket-} (Just enc) diff --git a/src/RawFilePath/Process/Internal.hs b/src/RawFilePath/Process/Internal.hs new file mode 100644 --- /dev/null +++ b/src/RawFilePath/Process/Internal.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE InterruptibleFFI #-} + +module RawFilePath.Process.Internal + ( c_terminateProcess + , c_getProcessExitCode + , c_waitForProcess + ) where + +import Foreign +import Foreign.C + +import System.Posix.Types (CPid (..)) + +import RawFilePath.Process.Common + +foreign import ccall unsafe "terminateProcess" + c_terminateProcess + :: PHANDLE + -> IO CInt + +foreign import ccall unsafe "getProcessExitCode" + c_getProcessExitCode + :: PHANDLE + -> Ptr CInt + -> IO CInt + +foreign import ccall interruptible "waitForProcess" -- NB. safe - can block + c_waitForProcess + :: PHANDLE + -> Ptr CInt + -> IO CInt diff --git a/src/RawFilePath/Process/Posix.hs b/src/RawFilePath/Process/Posix.hs new file mode 100644 --- /dev/null +++ b/src/RawFilePath/Process/Posix.hs @@ -0,0 +1,223 @@ +module RawFilePath.Process.Posix + ( createProcessInternal + , withCEnvironment + , closePHANDLE + , startDelegateControlC + , endDelegateControlC + , stopDelegateControlC + , c_execvpe + , pPrPr_disableITimers + , createPipe + , createPipeInternalFd + ) where + +import RawFilePath.Import + +-- extra modules + +import Data.ByteString.Internal (ByteString(..), memcpy) +import System.Posix.ByteString.FilePath (withFilePath) +import System.Posix.Internals hiding (withFilePath) +import System.Posix.Process.Internals ( pPrPr_disableITimers, c_execvpe ) +import System.Posix.Signals +import qualified System.Posix.Signals as Sig +import qualified System.Posix.IO as Posix + +-- local modules + +import RawFilePath.Process.Common + +#include "processFlags.c" + +closePHANDLE :: PHANDLE -> IO () +closePHANDLE _ = return () + +-- ---------------------------------------------------------------------------- +-- Utils + +withManyByteString :: [ByteString] -> (Ptr CString -> IO a) -> IO a +withManyByteString bs action = + allocaBytes wholeLength $ \ buf -> + allocaBytes ptrLength $ \ cs -> do + copyByteStrings bs buf cs + action (castPtr cs) + where + ptrLength = (length bs + 1) * sizeOf (undefined :: Ptr CString) + wholeLength = sum (map (\ (PS _ _ l) -> l + 1) bs) + +copyByteStrings :: [ByteString] -> Ptr Word8 -> Ptr (Ptr Word8) -> IO () +copyByteStrings [] _ cs = poke cs nullPtr +copyByteStrings (PS fp o l : xs) buf cs = withForeignPtr fp $ \ p -> do + memcpy buf (p `plusPtr` o) (fromIntegral l) + pokeByteOff buf l (0 :: Word8) + poke cs (buf :: Ptr Word8) + copyByteStrings xs (buf `plusPtr` (l + 1)) + (cs `plusPtr` sizeOf (undefined :: Ptr CString)) + +withCEnvironment :: [(ByteString, ByteString)] -> (Ptr CString -> IO a) -> IO a +withCEnvironment envir act = + let env' = map (\(name, val) -> name <> "=" <> val) envir + in withManyByteString env' act + +-- ----------------------------------------------------------------------------- +-- POSIX runProcess with signal handling in the child + +createProcessInternal + :: (StreamType stdin, StreamType stdout, StreamType stderr) + => ProcessConf stdin stdout stderr + -> IO (Process stdin stdout stderr) +createProcessInternal ProcessConf{..} + = alloca $ \ pfdStdInput -> + alloca $ \ pfdStdOutput -> + alloca $ \ pfdStdError -> + alloca $ \ pFailedDoing -> + maybeWith withCEnvironment env $ \pEnv -> + maybeWith withFilePath cwd $ \pWorkDir -> + maybeWith with childGroup $ \pChildGroup -> + maybeWith with childUser $ \pChildUser -> + withManyByteString cmdargs $ \pargs -> do + + fdin <- mbFd fdStdin cfgStdin + fdout <- mbFd fdStdout cfgStdout + fderr <- mbFd fdStderr cfgStderr + + when delegateCtlc startDelegateControlC + + -- runInteractiveProcess() blocks signals around the fork(). + -- Since blocking/unblocking of signals is a global state + -- operation, we better ensure mutual exclusion of calls to + -- runInteractiveProcess(). + procHandle <- withMVar runInteractiveProcessLock $ \_ -> + c_runInteractiveProcess pargs pWorkDir pEnv + fdin fdout fderr + pfdStdInput pfdStdOutput pfdStdError + pChildGroup pChildUser + (if delegateCtlc then 1 else 0) + ((if closeFds then RUN_PROCESS_IN_CLOSE_FDS else 0) + .|.(if createGroup then RUN_PROCESS_IN_NEW_GROUP else 0) + .|.(if createNewConsole then RUN_PROCESS_NEW_CONSOLE else 0) + .|.(if newSession then RUN_PROCESS_NEW_SESSION else 0)) + pFailedDoing + + when (procHandle == -1) $ do + cFailedDoing <- peek pFailedDoing + failedDoing <- peekCString cFailedDoing + when delegateCtlc stopDelegateControlC + -- TODO(XT): avoid String + throwErrno (show (head cmdargs) ++ ": " ++ failedDoing) + + hIn <- mbPipe cfgStdin pfdStdInput WriteMode + hOut <- mbPipe cfgStdout pfdStdOutput ReadMode + hErr <- mbPipe cfgStderr pfdStdError ReadMode + + mvarProcHandle <- newMVar (OpenHandle procHandle) + lock <- newMVar () + return (Process hIn hOut hErr mvarProcHandle delegateCtlc lock) + +{-# NOINLINE runInteractiveProcessLock #-} +runInteractiveProcessLock :: MVar () +runInteractiveProcessLock = unsafePerformIO $ newMVar () + +-- ---------------------------------------------------------------------------- +-- Delegated control-C handling on Unix + +-- See ticket https://ghc.haskell.org/trac/ghc/ticket/2301 +-- and http://www.cons.org/cracauer/sigint.html +-- +-- While running an interactive console process like ghci or a shell, we want +-- to let that process handle Ctl-C keyboard interrupts how it sees fit. +-- So that means we need to ignore the SIGINT/SIGQUIT Unix signals while we're +-- running such programs. And then if/when they do terminate, we need to check +-- if they terminated due to SIGINT/SIGQUIT and if so then we behave as if we +-- got the Ctl-C then, by throwing the UserInterrupt exception. +-- +-- If we run multiple programs like this concurrently then we have to be +-- careful to avoid messing up the signal handlers. We keep a count and only +-- restore when the last one has finished. + +{-# NOINLINE runInteractiveProcessDelegateCtlc #-} +runInteractiveProcessDelegateCtlc :: MVar (Maybe (Int, Sig.Handler, Sig.Handler)) +runInteractiveProcessDelegateCtlc = unsafePerformIO $ newMVar Nothing + +startDelegateControlC :: IO () +startDelegateControlC = + modifyMVar_ runInteractiveProcessDelegateCtlc $ \ case + Nothing -> do + -- We're going to ignore ^C in the parent while there are any + -- processes using ^C delegation. + -- + -- If another thread runs another process without using + -- delegation while we're doing this then it will inherit the + -- ignore ^C status. + old_int <- installHandler sigINT Ignore Nothing + old_quit <- installHandler sigQUIT Ignore Nothing + return (Just (1, old_int, old_quit)) + + Just (count, old_int, old_quit) -> do + -- If we're already doing it, just increment the count + let !count' = count + 1 + return (Just (count', old_int, old_quit)) + +stopDelegateControlC :: IO () +stopDelegateControlC = + modifyMVar_ runInteractiveProcessDelegateCtlc $ \ case + Just (1, old_int, old_quit) -> do + -- Last process, so restore the old signal handlers + _ <- installHandler sigINT old_int Nothing + _ <- installHandler sigQUIT old_quit Nothing + return Nothing + + Just (count, old_int, old_quit) -> do + -- Not the last, just decrement the count + let !count' = count - 1 + return (Just (count', old_int, old_quit)) + + Nothing -> return Nothing -- should be impossible + +endDelegateControlC :: ExitCode -> IO () +endDelegateControlC exitCode = do + stopDelegateControlC + + -- And if the process did die due to SIGINT or SIGQUIT then + -- we throw our equivalent exception here (synchronously). + -- + -- An alternative design would be to throw to the main thread, as the + -- normal signal handler does. But since we can be sync here, we do so. + -- It allows the code locally to catch it and do something. + case exitCode of + ExitFailure n | isSigIntQuit n -> throwIO UserInterrupt + _ -> return () + where + isSigIntQuit n = sig == sigINT || sig == sigQUIT + where + sig = fromIntegral (-n) + +foreign import ccall unsafe "runInteractiveProcess" + c_runInteractiveProcess + :: Ptr CString + -> CString + -> Ptr CString + -> FD + -> FD + -> FD + -> Ptr FD + -> Ptr FD + -> Ptr FD + -> Ptr CGid + -> Ptr CUid + -> CInt -- reset child's SIGINT & SIGQUIT handlers + -> CInt -- flags + -> Ptr CString + -> IO PHANDLE + +createPipe :: IO (Handle, Handle) +createPipe = do + (readfd, writefd) <- Posix.createPipe + readh <- Posix.fdToHandle readfd + writeh <- Posix.fdToHandle writefd + return (readh, writeh) + +createPipeInternalFd :: IO (FD, FD) +createPipeInternalFd = do + (Fd readfd, Fd writefd) <- Posix.createPipe + return (readfd, writefd) diff --git a/src/RawFilePath/Process/Utility.hs b/src/RawFilePath/Process/Utility.hs new file mode 100644 --- /dev/null +++ b/src/RawFilePath/Process/Utility.hs @@ -0,0 +1,59 @@ +module RawFilePath.Process.Utility + ( callProcess + , readProcessWithExitCode + ) where + +-- base modules + +import RawFilePath.Import + +-- extra modules + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Builder as B + +-- local modules + +import RawFilePath.Process.Common +import RawFilePath.Process.Basic + +-- | Create a new process with the given configuration, and wait for it to +-- finish. +callProcess :: ProcessConf stdin stdout stderr -> IO ExitCode +callProcess conf = start >>= waitForProcess + where + start = startProcess conf + { cfgStdin = NoStream + , cfgStdout = NoStream + , cfgStderr = NoStream + } + +-- | Fork an external process, read its standard output strictly, blocking +-- until the process terminates, and return the output as 'ByteString'. +-- +-- Output is returned strictly, so this is not suitable for interactive +-- applications. +readProcessWithExitCode + :: ProcessConf stdin stdout stderr + -> IO (ExitCode, ByteString, ByteString) +readProcessWithExitCode conf = do + process <- startProcess conf + { cfgStdin = NoStream + , cfgStdout = CreatePipe + , cfgStderr = CreatePipe + } + stdoutB <- hGetAll (processStdout process) + stderrB <- hGetAll (processStderr process) + exitCode <- waitForProcess process + return (exitCode, stdoutB, stderrB) + +-- utility functions + +-- Read from Handle until IOError +hGetAll :: Handle -> IO ByteString +hGetAll h = LB.toStrict . B.toLazyByteString <$> hGetAll' mempty h + where + hGetAll' acc h' = tryIOError (B.hGetContents h) >>= \ case + Left _ -> return acc + Right b -> hGetAll' (acc <> B.byteString b) h' diff --git a/src/System/Process/RawFilePath.hs b/src/System/Process/RawFilePath.hs deleted file mode 100644 --- a/src/System/Process/RawFilePath.hs +++ /dev/null @@ -1,168 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : System.Process.RawFilePath --- Copyright : (C) XT et al. 2017 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : e@xtendo.org --- Stability : experimental --- Portability : POSIX --- --- Welcome to @System.Process.RawFilePath@, a small part of the Haskell --- community's effort to purge 'String' for the Greater Good. --- --- With this module, you can create (and interact with) sub-processes without --- the encoding problem of 'String'. The command and its arguments, all --- 'ByteString's, never get converted from/to 'String' internally on its way --- to the actual syscall. It also avoids the time/space waste of 'String'. --- --- The interface, unlike the original @process@ package, uses types to prevent --- unnecessary runtime errors when obtaining 'Handle's. This is inspired by --- the @typed-process@ package which is awesome, although this module is much --- simpler; it doesn't introduce any new requirement of language extension or --- library package (for the sake of portability). --- --- 'Handle' (accessible with 'processStdin', 'processStdout', and --- 'processStderr') is what you can use to interact with the sub-process. For --- example, use 'Data.ByteString.hGetContents' from "Data.ByteString" to read --- from a 'Handle' as a 'ByteString'. --- --- == Example --- --- @ --- {-\# language OverloadedStrings \#-} --- --- import System.Process.RawFilePath --- import qualified Data.ByteString as B --- --- main :: IO () --- main = do --- p <- 'startProcess' $ 'proc' "echo" ["hello"] --- \`setStdout\` 'CreatePipe' --- result <- B.hGetContents ('processStdout' p) --- _ <- 'waitForProcess' p --- --- print (result == "hello\\n") --- @ --- ------------------------------------------------------------------------------ - - -module System.Process.RawFilePath - ( - -- ** Configuring process - -- $configuring - ProcessConf - , proc - - -- *** Configuring process standard streams - , StreamType - , CreatePipe(..) - , Inherit(..) - , NoStream(..) - , UseHandle(..) - , setStdin - , setStdout - , setStderr - - -- ** Running process - , Process - , startProcess - - -- ** Obtaining process streams - -- $obtaining - , processStdin - , processStdout - , processStderr - - -- ** Process completion - , stopProcess - , terminateProcess - , waitForProcess - - ) where - --- base modules - -import RawFilePath.Import hiding (ClosedHandle) - --- local modules - -import System.Process.RawFilePath.Common -import System.Process.RawFilePath.Internal -import System.Process.RawFilePath.Posix - --- | Start a new sub-process with the given configuration. -startProcess - :: (StreamType stdin, StreamType stdout, StreamType stderr) - => ProcessConf stdin stdout stderr - -> IO (Process stdin stdout stderr) -startProcess = createProcessInternal - --- | Stop a sub-process. For now it simply calls 'terminateProcess' and then --- 'waitForProcess'. -stopProcess :: Process stdin stdout stderr -> IO ExitCode -stopProcess p = do - terminateProcess p - waitForProcess p - --- | Wait (block) for a sub-process to exit and obtain its exit code. -waitForProcess - :: Process stdin stdout stderr - -> IO ExitCode -waitForProcess ph = lockWaitpid $ do - p_ <- modifyProcessHandle ph $ \ p_ -> return (p_,p_) - case p_ of - ClosedHandle e -> return e - OpenHandle h -> do - e <- alloca $ \ pret -> do - -- don't hold the MVar while we call c_waitForProcess... - throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret) - modifyProcessHandle ph $ \ p_' -> - case p_' of - ClosedHandle e -> return (p_', e) - OpenExtHandle{} -> return (p_', ExitFailure (-1)) - OpenHandle ph' -> do - closePHANDLE ph' - code <- peek pret - let e = if code == 0 - then ExitSuccess - else ExitFailure (fromIntegral code) - return (ClosedHandle e, e) - when delegatingCtlc $ - endDelegateControlC e - return e - OpenExtHandle _ _job _iocp -> - return $ ExitFailure (-1) - where - -- If more than one thread calls `waitpid` at a time, `waitpid` will - -- return the exit code to one of them and (-1) to the rest of them, - -- causing an exception to be thrown. - -- Cf. https://github.com/haskell/process/issues/46, and - -- https://github.com/haskell/process/pull/58 for further discussion - lockWaitpid m = withMVar (waitpidLock ph) $ \ () -> m - delegatingCtlc = mbDelegateCtlc ph - --- | Terminate a sub-process by sending SIGTERM to it. -terminateProcess :: Process stdin stdout stderr -> IO () -terminateProcess p = withProcessHandle p $ \ case - ClosedHandle _ -> return () - OpenExtHandle{} -> error - "terminateProcess with OpenExtHandle should not happen on POSIX." - OpenHandle h -> do - throwErrnoIfMinus1Retry_ "terminateProcess" $ c_terminateProcess h - return () - -- does not close the handle, we might want to try terminating it - -- again, or get its exit code. - - --- $configuring --- --- Configuration of how a new sub-process will be launched. --- --- $obtaining --- --- As the type signature suggests, these functions only work on processes --- whose stream in configured to 'CreatePipe'. This is the type-safe way of --- obtaining 'Handle's instead of returning 'Maybe' 'Handle's like the --- @process@ package does. diff --git a/src/System/Process/RawFilePath/Common.hs b/src/System/Process/RawFilePath/Common.hs deleted file mode 100644 --- a/src/System/Process/RawFilePath/Common.hs +++ /dev/null @@ -1,243 +0,0 @@ -module System.Process.RawFilePath.Common - ( Process(..) - , ProcessConf(..) - , proc - , processStdin - , processStdout - , processStderr - , StreamType - , mbFd - , willCreateHandle - , CreatePipe(..) - , Inherit(..) - , NoStream(..) - , UseHandle(..) - , setStdin - , setStdout - , setStderr - - , PHANDLE - , ProcessHandle__(..) - , modifyProcessHandle - , withProcessHandle - , fdStdin - , fdStdout - , fdStderr - , mbPipe - ) where - -import RawFilePath.Import - --- extra modules - -import System.Posix.Internals (FD) -import qualified GHC.IO.FD as FD - --- Original declarations - --- | The process configuration that is needed for creating new processes. Use --- 'proc' to make one. -data ProcessConf stdin stdout stderr = ProcessConf - { cmdargs :: [ByteString] - -- ^ Executable & arguments, or shell command - , cwd :: Maybe RawFilePath - -- ^ Optional path to the working directory for the new process - , env :: Maybe [(ByteString, ByteString)] - -- ^ Optional environment (otherwise inherit from the current process) - , cfgStdin :: stdin - -- ^ How to determine stdin - , cfgStdout :: stdout - -- ^ How to determine stdout - , cfgStderr :: stderr - -- ^ How to determine stderr - , closeFds :: Bool - -- ^ Close all file descriptors except stdin, stdout and stderr in the new - -- process - , createGroup :: Bool - -- ^ Create a new process group - , delegateCtlc :: Bool - -- ^ Delegate control-C handling. Use this for interactive console - -- processes to let them handle control-C themselves (see below for - -- details). - , createNewConsole :: Bool - -- ^ Use the windows CREATE_NEW_CONSOLE flag when creating the process; - -- does nothing on other platforms. - -- - -- Default: @False@ - , newSession :: Bool - -- ^ Use posix setsid to start the new process in a new session; does nothing on other platforms. - , childGroup :: Maybe GroupID - -- ^ Use posix setgid to set child process's group id. - -- - -- Default: @Nothing@ - , childUser :: Maybe UserID - -- ^ Use posix setuid to set child process's user id. - -- - -- Default: @Nothing@ - } - --- | Create a process configuration with the default settings. -proc - :: RawFilePath -- ^ Command to run - -> [ByteString] -- ^ Arguments to the command - -> ProcessConf Inherit Inherit Inherit -proc cmd args = ProcessConf - { cmdargs = cmd : args - , cwd = Nothing - , env = Nothing - , cfgStdin = Inherit - , cfgStdout = Inherit - , cfgStderr = Inherit - , closeFds = False - , createGroup = False - , delegateCtlc = False - , createNewConsole = False - , newSession = False - , childGroup = Nothing - , childUser = Nothing - } - --- | Control how the standard input of the process will be initialized. -setStdin - :: (StreamType newStdin) - => ProcessConf oldStdin stdout stderr - -> newStdin - -> ProcessConf newStdin stdout stderr -setStdin p newStdin = p { cfgStdin = newStdin } -infixl 4 `setStdin` - --- | Control how the standard output of the process will be initialized. -setStdout - :: (StreamType newStdout) - => ProcessConf stdin oldStdout stderr - -> newStdout - -> ProcessConf stdin newStdout stderr -setStdout p newStdout = p { cfgStdout = newStdout } -infixl 4 `setStdout` - --- | Control how the standard error of the process will be initialized. -setStderr - :: (StreamType newStderr) - => ProcessConf stdin stdout oldStderr - -> newStderr - -> ProcessConf stdin stdout newStderr -setStderr p newStderr = p { cfgStderr = newStderr } -infixl 4 `setStderr` - --- | The process type. The three type variables denote how its standard --- streams were initialized. -data Process stdin stdout stderr = Process - { procStdin :: Maybe Handle - , procStdout :: Maybe Handle - , procStderr :: Maybe Handle - , phandle :: !(MVar ProcessHandle__) - , mbDelegateCtlc :: !Bool - , waitpidLock :: !(MVar ()) - } - --- | Take a process and return its standard input handle. -processStdin :: Process CreatePipe stdout stderr -> Handle -processStdin Process{..} = fromMaybe err procStdin - where - err = error "This can't happen: stdin is CreatePipe but missing" - --- | Take a process and return its standard output handle. -processStdout :: Process stdin CreatePipe stderr -> Handle -processStdout Process{..} = fromMaybe err procStdout - where - err = error "This can't happen: stdout is CreatePipe but missing" - --- | Take a process and return its standard error handle. -processStderr :: Process stdin stdout CreatePipe -> Handle -processStderr Process{..} = fromMaybe err procStderr - where - err = error "This can't happen: stderr is CreatePipe but missing" - --- | Create a new pipe for the stream. You get a new 'Handle'. -data CreatePipe = CreatePipe deriving Show --- | Inherit the parent (current) process handle. The child will share the --- stream. For example, if the child writes anything to stdout, it will all go --- to the parent's stdout. -data Inherit = Inherit deriving Show --- | No stream handle will be passed. Use when you don't want to communicate --- with a stream. For example, to run something silently. -data NoStream = NoStream deriving Show --- | Use the supplied 'Handle'. -data UseHandle = UseHandle Handle deriving Show - --- | The class of types that determine the standard stream of a sub-process. --- You can decide how to initialize the standard streams (stdin, stdout, and --- stderr) of a sub-process with the instances of this class. -class StreamType c where - mbFd :: FD -> c -> IO FD - willCreateHandle :: c -> Bool -#if __GLASGOW_HASKELL__ >= 780 - mbFd = undefined - willCreateHandle = undefined - {-# MINIMAL #-} -#endif -instance StreamType CreatePipe where - mbFd _ _ = return (-1) - willCreateHandle _ = True -instance StreamType Inherit where - mbFd std _ = return std - willCreateHandle _ = False -instance StreamType NoStream where - mbFd _ _ = return (-2) - willCreateHandle _ = False -instance StreamType UseHandle where - mbFd _std (UseHandle hdl) = - withHandle "" hdl $ \Handle__{haDevice=dev,..} -> case cast dev of - Just fd -> do - -- clear the O_NONBLOCK flag on this FD, if it is set, since - -- we're exposing it externally (see #3316 of 'process') - fd' <- FD.setNonBlockingMode fd False - return (Handle__{haDevice=fd',..}, FD.fdFD fd') - Nothing -> ioError $ mkIOError illegalOperationErrorType - "createProcess" (Just hdl) Nothing - `ioeSetErrorString` "handle is not a file descriptor" - willCreateHandle _ = False - --- Declarations from the process package (modified) - -type PHANDLE = CPid - -data ProcessHandle__ = OpenHandle PHANDLE - | OpenExtHandle PHANDLE PHANDLE PHANDLE - | ClosedHandle ExitCode - -modifyProcessHandle - :: Process stdin stdout stderr - -> (ProcessHandle__ -> IO (ProcessHandle__, a)) - -> IO a -modifyProcessHandle p = modifyMVar (phandle p) - -withProcessHandle - :: Process stdin stdout stderr -> (ProcessHandle__ -> IO a) -> IO a -withProcessHandle p = withMVar (phandle p) - -fdStdin, fdStdout, fdStderr :: FD -fdStdin = 0 -fdStdout = 1 -fdStderr = 2 - -mbPipe :: StreamType c => c -> Ptr FD -> IOMode -> IO (Maybe Handle) -mbPipe streamConf pfd mode = if willCreateHandle streamConf - then fmap Just (pfdToHandle pfd mode) - else return Nothing - -pfdToHandle :: Ptr FD -> IOMode -> IO Handle -pfdToHandle pfd mode = do - fd <- peek pfd - let filepath = "fd:" ++ show fd - (fD,fd_type) <- FD.mkFD (fromIntegral fd) mode - (Just (Stream,0,0)) -- avoid calling fstat() - False {-is_socket-} - False {-non-blocking-} - fD' <- FD.setNonBlockingMode fD True -- see #3316 -#if __GLASGOW_HASKELL__ >= 704 - enc <- getLocaleEncoding -#else - let enc = localeEncoding -#endif - mkHandleFromFD fD' fd_type filepath mode False {-is_socket-} (Just enc) diff --git a/src/System/Process/RawFilePath/Internal.hs b/src/System/Process/RawFilePath/Internal.hs deleted file mode 100644 --- a/src/System/Process/RawFilePath/Internal.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE InterruptibleFFI #-} - -module System.Process.RawFilePath.Internal - ( c_terminateProcess - , c_getProcessExitCode - , c_waitForProcess - ) where - -import Foreign -import Foreign.C - -import System.Posix.Types (CPid (..)) - -import System.Process.RawFilePath.Common - -foreign import ccall unsafe "terminateProcess" - c_terminateProcess - :: PHANDLE - -> IO CInt - -foreign import ccall unsafe "getProcessExitCode" - c_getProcessExitCode - :: PHANDLE - -> Ptr CInt - -> IO CInt - -foreign import ccall interruptible "waitForProcess" -- NB. safe - can block - c_waitForProcess - :: PHANDLE - -> Ptr CInt - -> IO CInt diff --git a/src/System/Process/RawFilePath/Posix.hs b/src/System/Process/RawFilePath/Posix.hs deleted file mode 100644 --- a/src/System/Process/RawFilePath/Posix.hs +++ /dev/null @@ -1,223 +0,0 @@ -module System.Process.RawFilePath.Posix - ( createProcessInternal - , withCEnvironment - , closePHANDLE - , startDelegateControlC - , endDelegateControlC - , stopDelegateControlC - , c_execvpe - , pPrPr_disableITimers - , createPipe - , createPipeInternalFd - ) where - -import RawFilePath.Import - --- extra modules - -import Data.ByteString.Internal (ByteString(..), memcpy) -import System.Posix.ByteString.FilePath (withFilePath) -import System.Posix.Internals hiding (withFilePath) -import System.Posix.Process.Internals ( pPrPr_disableITimers, c_execvpe ) -import System.Posix.Signals -import qualified System.Posix.Signals as Sig -import qualified System.Posix.IO as Posix - --- local modules - -import System.Process.RawFilePath.Common - -#include "processFlags.h" - -closePHANDLE :: PHANDLE -> IO () -closePHANDLE _ = return () - --- ---------------------------------------------------------------------------- --- Utils - -withManyByteString :: [ByteString] -> (Ptr CString -> IO a) -> IO a -withManyByteString bs action = - allocaBytes wholeLength $ \ buf -> - allocaBytes ptrLength $ \ cs -> do - copyByteStrings bs buf cs - action (castPtr cs) - where - ptrLength = (length bs + 1) * sizeOf (undefined :: Ptr CString) - wholeLength = sum (map (\ (PS _ _ l) -> l + 1) bs) - -copyByteStrings :: [ByteString] -> Ptr Word8 -> Ptr (Ptr Word8) -> IO () -copyByteStrings [] _ cs = poke cs nullPtr -copyByteStrings (PS fp o l : xs) buf cs = withForeignPtr fp $ \ p -> do - memcpy buf (p `plusPtr` o) (fromIntegral l) - pokeByteOff buf l (0 :: Word8) - poke cs (buf :: Ptr Word8) - copyByteStrings xs (buf `plusPtr` (l + 1)) - (cs `plusPtr` sizeOf (undefined :: Ptr CString)) - -withCEnvironment :: [(ByteString, ByteString)] -> (Ptr CString -> IO a) -> IO a -withCEnvironment envir act = - let env' = map (\(name, val) -> name <> "=" <> val) envir - in withManyByteString env' act - --- ----------------------------------------------------------------------------- --- POSIX runProcess with signal handling in the child - -createProcessInternal - :: (StreamType stdin, StreamType stdout, StreamType stderr) - => ProcessConf stdin stdout stderr - -> IO (Process stdin stdout stderr) -createProcessInternal ProcessConf{..} - = alloca $ \ pfdStdInput -> - alloca $ \ pfdStdOutput -> - alloca $ \ pfdStdError -> - alloca $ \ pFailedDoing -> - maybeWith withCEnvironment env $ \pEnv -> - maybeWith withFilePath cwd $ \pWorkDir -> - maybeWith with childGroup $ \pChildGroup -> - maybeWith with childUser $ \pChildUser -> - withManyByteString cmdargs $ \pargs -> do - - fdin <- mbFd fdStdin cfgStdin - fdout <- mbFd fdStdout cfgStdout - fderr <- mbFd fdStderr cfgStderr - - when delegateCtlc startDelegateControlC - - -- runInteractiveProcess() blocks signals around the fork(). - -- Since blocking/unblocking of signals is a global state - -- operation, we better ensure mutual exclusion of calls to - -- runInteractiveProcess(). - procHandle <- withMVar runInteractiveProcessLock $ \_ -> - c_runInteractiveProcess pargs pWorkDir pEnv - fdin fdout fderr - pfdStdInput pfdStdOutput pfdStdError - pChildGroup pChildUser - (if delegateCtlc then 1 else 0) - ((if closeFds then RUN_PROCESS_IN_CLOSE_FDS else 0) - .|.(if createGroup then RUN_PROCESS_IN_NEW_GROUP else 0) - .|.(if createNewConsole then RUN_PROCESS_NEW_CONSOLE else 0) - .|.(if newSession then RUN_PROCESS_NEW_SESSION else 0)) - pFailedDoing - - when (procHandle == -1) $ do - cFailedDoing <- peek pFailedDoing - failedDoing <- peekCString cFailedDoing - when delegateCtlc stopDelegateControlC - -- TODO(XT): avoid String - throwErrno (show (head cmdargs) ++ ": " ++ failedDoing) - - hIn <- mbPipe cfgStdin pfdStdInput WriteMode - hOut <- mbPipe cfgStdout pfdStdOutput ReadMode - hErr <- mbPipe cfgStderr pfdStdError ReadMode - - mvarProcHandle <- newMVar (OpenHandle procHandle) - lock <- newMVar () - return (Process hIn hOut hErr mvarProcHandle delegateCtlc lock) - -{-# NOINLINE runInteractiveProcessLock #-} -runInteractiveProcessLock :: MVar () -runInteractiveProcessLock = unsafePerformIO $ newMVar () - --- ---------------------------------------------------------------------------- --- Delegated control-C handling on Unix - --- See ticket https://ghc.haskell.org/trac/ghc/ticket/2301 --- and http://www.cons.org/cracauer/sigint.html --- --- While running an interactive console process like ghci or a shell, we want --- to let that process handle Ctl-C keyboard interrupts how it sees fit. --- So that means we need to ignore the SIGINT/SIGQUIT Unix signals while we're --- running such programs. And then if/when they do terminate, we need to check --- if they terminated due to SIGINT/SIGQUIT and if so then we behave as if we --- got the Ctl-C then, by throwing the UserInterrupt exception. --- --- If we run multiple programs like this concurrently then we have to be --- careful to avoid messing up the signal handlers. We keep a count and only --- restore when the last one has finished. - -{-# NOINLINE runInteractiveProcessDelegateCtlc #-} -runInteractiveProcessDelegateCtlc :: MVar (Maybe (Int, Sig.Handler, Sig.Handler)) -runInteractiveProcessDelegateCtlc = unsafePerformIO $ newMVar Nothing - -startDelegateControlC :: IO () -startDelegateControlC = - modifyMVar_ runInteractiveProcessDelegateCtlc $ \ case - Nothing -> do - -- We're going to ignore ^C in the parent while there are any - -- processes using ^C delegation. - -- - -- If another thread runs another process without using - -- delegation while we're doing this then it will inherit the - -- ignore ^C status. - old_int <- installHandler sigINT Ignore Nothing - old_quit <- installHandler sigQUIT Ignore Nothing - return (Just (1, old_int, old_quit)) - - Just (count, old_int, old_quit) -> do - -- If we're already doing it, just increment the count - let !count' = count + 1 - return (Just (count', old_int, old_quit)) - -stopDelegateControlC :: IO () -stopDelegateControlC = - modifyMVar_ runInteractiveProcessDelegateCtlc $ \ case - Just (1, old_int, old_quit) -> do - -- Last process, so restore the old signal handlers - _ <- installHandler sigINT old_int Nothing - _ <- installHandler sigQUIT old_quit Nothing - return Nothing - - Just (count, old_int, old_quit) -> do - -- Not the last, just decrement the count - let !count' = count - 1 - return (Just (count', old_int, old_quit)) - - Nothing -> return Nothing -- should be impossible - -endDelegateControlC :: ExitCode -> IO () -endDelegateControlC exitCode = do - stopDelegateControlC - - -- And if the process did die due to SIGINT or SIGQUIT then - -- we throw our equivalent exception here (synchronously). - -- - -- An alternative design would be to throw to the main thread, as the - -- normal signal handler does. But since we can be sync here, we do so. - -- It allows the code locally to catch it and do something. - case exitCode of - ExitFailure n | isSigIntQuit n -> throwIO UserInterrupt - _ -> return () - where - isSigIntQuit n = sig == sigINT || sig == sigQUIT - where - sig = fromIntegral (-n) - -foreign import ccall unsafe "runInteractiveProcess" - c_runInteractiveProcess - :: Ptr CString - -> CString - -> Ptr CString - -> FD - -> FD - -> FD - -> Ptr FD - -> Ptr FD - -> Ptr FD - -> Ptr CGid - -> Ptr CUid - -> CInt -- reset child's SIGINT & SIGQUIT handlers - -> CInt -- flags - -> Ptr CString - -> IO PHANDLE - -createPipe :: IO (Handle, Handle) -createPipe = do - (readfd, writefd) <- Posix.createPipe - readh <- Posix.fdToHandle readfd - writeh <- Posix.fdToHandle writefd - return (readh, writeh) - -createPipeInternalFd :: IO (FD, FD) -createPipeInternalFd = do - (Fd readfd, Fd writefd) <- Posix.createPipe - return (readfd, writefd) diff --git a/src/System/RawFilePath.hs b/src/System/RawFilePath.hs deleted file mode 100644 --- a/src/System/RawFilePath.hs +++ /dev/null @@ -1,263 +0,0 @@ -{-# language LambdaCase #-} - --- | --- Module : System.RawFilePath --- Copyright : (c) XT 2016 --- License : Apache 2.0 --- --- Maintainer : e@xtendo.org --- Stability : experimental --- Portability : POSIX --- --- Higher-level API for the 'RawFilePath'-variants of functions in the 'unix' --- module. - -module System.RawFilePath - ( RawFilePath - -- * Process - , callProcess - , callProcessSilent - , readProcess - , readProcessEither - -- * Directory - , listDirectory - , getDirectoryFiles - , getDirectoryFilesRecursive - , copyFile - , getHomeDirectory - , doesFileExist - , doesDirectoryExist - , setCurrentDirectory - , tryRemoveFile - ) where - -import Data.Monoid -import Control.Monad -import Control.Exception - -import Data.ByteString (ByteString) -import qualified Data.ByteString as B - -import System.IO -import System.IO.Error -import System.Exit (ExitCode(..)) - -import Foreign.Marshal.Alloc (allocaBytes) -import System.Posix.ByteString - -processError :: RawFilePath -> IOError -processError cmd = mkIOError userErrorType - ("calling process " <> show cmd) Nothing (Just $ show cmd) - --- | Creates a new process to run the specified command with the given --- arguments, and waits for it to finish. Throws an exception if the process --- returns a nonzero exit code. --- --- > *System.RawFilePath> callProcess "ls" ["-a", "src"] --- > . .. System -callProcess - :: RawFilePath -- ^ Command to run - -> [ByteString] -- ^ Command arguments - -> IO () -callProcess cmd args = do - pid <- forkProcess $ executeFile cmd True args Nothing - getProcessStatus True False pid >>= \case - Just status -> case status of - Exited exitCode -> case exitCode of - ExitSuccess -> return () - ExitFailure _ -> failure - _ -> failure - Nothing -> failure - where - failure = ioError (processError cmd) - --- | Same as 'callProcess' except the child process will share the parent\'s --- stdout and stderr, meaning it won\'t print anything. -callProcessSilent - :: RawFilePath -- ^ Command to run - -> [ByteString] -- ^ Command arguments - -> IO ExitCode -callProcessSilent cmd args = do - pid <- forkProcess $ do - closeFd stdOutput - closeFd stdError - executeFile cmd True args Nothing - getProcessStatus True False pid >>= \case - Just status -> case status of - Exited exitCode -> return exitCode - _ -> failure - Nothing -> failure - where - failure = ioError (processError cmd) - -getContentsAndClose :: Handle -> IO ByteString -getContentsAndClose h = B.hGetContents h <* hClose h - --- | Runs a command, reads its standard output strictly, blocking until the process terminates, and returns the output as 'ByteString'. --- --- > *System.RawFilePath> readProcess "date" ["+%s"] --- > "1469999314\n" -readProcess - :: RawFilePath -- ^ Command to run - -> [ByteString] -- ^ Command arguments - -> IO ByteString -- ^ The output from the command -readProcess cmd args = do - (fd0, fd1) <- createPipe - pid <- forkProcess $ do - closeFd fd0 - closeFd stdOutput - closeFd stdError - void $ dupTo fd1 stdOutput - executeFile cmd True args Nothing - closeFd fd1 - (fdToHandle fd0 >>= getContentsAndClose) <* - getProcessStatus True False pid - --- | A \'safer\' approach to 'readProcess'. Depending on the exit status of --- the process, this function will return output either from stderr or stdout. --- --- > *System.RawFilePath> readProcessEither "date" ["%s"] --- > Left "date: invalid date \226\128\152%s\226\128\153\n" --- > *System.RawFilePath> readProcessEither "date" ["+%s"] --- > Right "1469999817\n" -readProcessEither - :: RawFilePath -- ^ Command to run - -> [ByteString] -- ^ Command arguments - -> IO (Either ByteString ByteString) -- ^ Either the stedrr output from - -- the command if it finished with a nonzero exit code, or the stdout data - -- if it finished normally. -readProcessEither cmd args = do - (fd0, fd1) <- createPipe - (efd0, efd1) <- createPipe - pid <- forkProcess $ do - closeFd fd0 - closeFd stdOutput - void $ dupTo fd1 stdOutput - closeFd efd0 - closeFd stdError - void $ dupTo efd1 stdError - executeFile cmd True args Nothing - closeFd fd1 - closeFd efd1 - content <- fdToHandle fd0 >>= getContentsAndClose - err <- fdToHandle efd0 >>= getContentsAndClose - getProcessStatus True False pid >>= \case - Just status -> case status of - Exited exitCode -> case exitCode of - ExitSuccess -> return $ Right content - ExitFailure _ -> return $ Left err - _ -> return $ Left err - Nothing -> return $ Left err - --- | Get a list of files in the specified directory, excluding "." and ".." --- --- > *System.RawFilePath> listDirectory "src" --- > ["..","System","."] -listDirectory - :: RawFilePath -- ^ The path of directory to inspect - -> IO [RawFilePath] -- ^ A list of files in the directory -listDirectory dirPath = filter f <$> getDirectoryFiles dirPath - where - f p = p /= "." && p /= ".." - --- | Get a list of files in the specified directory, including "." and ".." --- --- > *System.RawFilePath> getDirectoryFiles "src" --- > ["..","System","."] -getDirectoryFiles - :: RawFilePath -- ^ The path of directory to inspect - -> IO [RawFilePath] -- ^ A list of files in the directory -getDirectoryFiles dirPath = bracket open close repeatRead - where - open = openDirStream dirPath - close = closeDirStream - repeatRead stream = do - d <- readDirStream stream - if B.length d == 0 then return [] else do - rest <- repeatRead stream - return $ d : rest - --- | Recursively get all files in all subdirectories of the specified --- directory. --- --- > *System.RawFilePath> getDirectoryFilesRecursive "src" --- > ["src/System/RawFilePath.hs"] -getDirectoryFilesRecursive - :: RawFilePath -- ^ The path of directory to inspect - -> IO [RawFilePath] -- ^ A list of relative paths -getDirectoryFilesRecursive path = do - names <- map (path ) . filter (\x -> x /= ".." && x /= ".") <$> - getDirectoryFiles path - inspectedNames <- mapM inspect names - return $ concat inspectedNames - where - inspect :: RawFilePath -> IO [RawFilePath] - inspect p = fmap isDirectory (getFileStatus p) >>= \i -> if i - then getDirectoryFilesRecursive p else return [p] - -defaultFlags :: OpenFileFlags -defaultFlags = OpenFileFlags - { append = False - , exclusive = False - , noctty = True - , nonBlock = False - , trunc = False - } - --- Buffer size for file copy -bufferSize :: Int -bufferSize = 4096 - --- | Copy a file from the source path to the destination path. -copyFile - :: RawFilePath -- ^ The source path - -> RawFilePath -- ^ The destination path - -> IO () -copyFile srcPath tgtPath = do - bracket ropen hClose $ \hi -> - bracket topen hClose $ \ho -> - allocaBytes bufferSize $ copyContents hi ho - rename tmpPath tgtPath - where - ropen = openFd srcPath ReadOnly Nothing defaultFlags >>= fdToHandle - topen = createFile tmpPath stdFileMode >>= fdToHandle - tmpPath = tgtPath <> ".copyFile.tmp" - copyContents hi ho buffer = do - count <- hGetBuf hi buffer bufferSize - when (count > 0) $ do - hPutBuf ho buffer count - copyContents hi ho buffer - --- | A function that "tries" to remove a file. If the file does not exist, --- nothing happens. -tryRemoveFile :: RawFilePath -> IO () -tryRemoveFile path = catchIOError (removeLink path) $ - \e -> unless (isDoesNotExistError e) $ ioError e - --- | Returns the current user\'s home directory. -getHomeDirectory :: IO RawFilePath -getHomeDirectory = getEnv "HOME" >>= maybe err return - where - err = ioError $ mkIOError doesNotExistErrorType errMsg Nothing Nothing - errMsg = "Environment variable $HOME" - --- | Returns 'True' if the argument file exists and is not a directory. -doesFileExist :: RawFilePath -> IO Bool -doesFileExist path = fileExist path >>= \i -> if i - then not . isDirectory <$> getFileStatus path - else return False - --- | Returns 'True' if the argument file exists and is a directory. -doesDirectoryExist :: RawFilePath -> IO Bool -doesDirectoryExist path = fileExist path >>= \i -> if i - then isDirectory <$> getFileStatus path - else return False - --- | Change the working directory to the given path. -setCurrentDirectory :: RawFilePath -> IO () -setCurrentDirectory = changeWorkingDirectory - --- An extremely simplistic approach for path concatenation. -infixr 5 -() :: RawFilePath -> RawFilePath -> RawFilePath -a b = mconcat [a, "/", b]