diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -7,7 +7,7 @@ == The 2-Clause BSD License == -Copyright 2016-2017 XT +Copyright 2016-2024 XT et al. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: @@ -34,7 +34,7 @@ == The MIT License == -Copyright (c) 2016-2017 XT +Copyright (c) 2016-2024 XT et al. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # rawfilepath -Version: 1.1.0 +Version: 1.1.1 ## TL;DR diff --git a/rawfilepath.cabal b/rawfilepath.cabal --- a/rawfilepath.cabal +++ b/rawfilepath.cabal @@ -1,19 +1,19 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: rawfilepath -version: 1.1.0 +version: 1.1.1 synopsis: Use RawFilePath instead of FilePath -description: Please see README.md +description: A fast and safe API with high-level features on `RawFilePath`, instead of `FilePath`, to avoid the encoding issues or performance penalties. Please see `README.md` category: System homepage: https://github.com/xtendo-org/rawfilepath#readme bug-reports: https://github.com/xtendo-org/rawfilepath/issues author: XT et al. maintainer: git@xtendo.org -copyright: (C) 2016-2023 XT et al. +copyright: (C) 2016-2024 XT et al. license: Apache-2.0 license-file: LICENSE build-type: Simple diff --git a/src/Data/ByteString/RawFilePath.hs b/src/Data/ByteString/RawFilePath.hs --- a/src/Data/ByteString/RawFilePath.hs +++ b/src/Data/ByteString/RawFilePath.hs @@ -9,45 +9,46 @@ -- -- A drop-in replacement of @Data.ByteString@ from the @bytestring@ package -- that provides file I/O functions with 'RawFilePath' instead of 'FilePath'. - -module Data.ByteString.RawFilePath - ( module Data.ByteString - , RawFilePath - , readFile - , writeFile - , appendFile - , withFile - - ) where +module Data.ByteString.RawFilePath ( + module Data.ByteString, + RawFilePath, + readFile, + writeFile, + appendFile, + withFile, +) where -- base modules -import Prelude hiding (readFile, writeFile, appendFile) import Control.Exception (bracket) -import System.IO (IOMode(..), Handle, hClose) - -- extra modules +import Data.ByteString hiding (appendFile, readFile, writeFile) +import System.IO (Handle, IOMode (..), hClose) import System.Posix.ByteString -import Data.ByteString hiding (readFile, writeFile, appendFile) +import Prelude hiding (appendFile, readFile, writeFile) + -- | Read an entire file at the 'RawFilePath' strictly into a 'ByteString'. readFile :: RawFilePath -> IO ByteString readFile path = withFile path ReadMode hGetContents + -- | Write a 'ByteString' to a file at the 'RawFilePath'. writeFile :: RawFilePath -> ByteString -> IO () writeFile path content = withFile path WriteMode (`hPut` content) + -- | Append a 'ByteString' to a file at the 'RawFilePath'. appendFile :: RawFilePath -> ByteString -> IO () appendFile path content = withFile path AppendMode (`hPut` content) + -- | Acquire a file handle and perform an I/O action. The file will be closed -- on exit or when this I/O action throws an exception. withFile :: RawFilePath -> IOMode -> (Handle -> IO r) -> IO r withFile path ioMode = bracket (open >>= fdToHandle) hClose - where + where #if MIN_VERSION_unix(2,8,0) open = case ioMode of ReadMode -> openFd path ReadOnly $ defaultFlags Nothing diff --git a/src/RawFilePath.hs b/src/RawFilePath.hs --- a/src/RawFilePath.hs +++ b/src/RawFilePath.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : RawFilePath -- Copyright : (C) XT et al. 2017 @@ -46,18 +49,14 @@ -- -- For process-related functions, see "RawFilePath.Process" for a brief -- introduction and an example code. --- ------------------------------------------------------------------------------ - -module RawFilePath - ( module RawFilePath.Directory - , module RawFilePath.Process - , RawFilePath - ) where - -import RawFilePath.Import +module RawFilePath ( + module RawFilePath.Directory, + module RawFilePath.Process, + RawFilePath, +) where -- local modules import RawFilePath.Directory hiding (RawFilePath) +import RawFilePath.Import import RawFilePath.Process hiding (RawFilePath) diff --git a/src/RawFilePath/Directory.hs b/src/RawFilePath/Directory.hs --- a/src/RawFilePath/Directory.hs +++ b/src/RawFilePath/Directory.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : RawFilePath.Directory -- Copyright : (C) 2004 The University of Glasgow. (C) 2017 XT et al. @@ -10,60 +13,66 @@ -- -- This is the module for the 'RawFilePath' version of functions in the -- @directory@ package. --- ------------------------------------------------------------------------------ +module RawFilePath.Directory ( + RawFilePath, -module RawFilePath.Directory - ( RawFilePath - -- ** Nondestructive (read-only) - , doesPathExist - , doesFileExist - , doesDirectoryExist - , getHomeDirectory - , getTemporaryDirectory - , listDirectory - , getDirectoryFiles - , getDirectoryFilesRecursive - -- ** Destructive - , createDirectory - , createDirectoryIfMissing - , removeFile - , tryRemoveFile - , removeDirectory - , removeDirectoryRecursive - ) where + -- ** Nondestructive (read-only) + doesPathExist, + doesFileExist, + doesDirectoryExist, + getHomeDirectory, + getTemporaryDirectory, + listDirectory, + getDirectoryFiles, + getDirectoryFilesRecursive, -import RawFilePath.Import + -- ** Destructive + createDirectory, + createDirectoryIfMissing, + removeFile, + tryRemoveFile, + removeDirectory, + removeDirectoryRecursive, +) where -- 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 +-- U for Unix -- local modules import RawFilePath.Directory.Internal +import RawFilePath.Import +import qualified System.Posix.ByteString as U + -- | 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) +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) +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) +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. -- @@ -83,58 +92,78 @@ 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 + :: 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 /= ".." + 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 + :: 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 + 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 + -- | 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 + :: 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 U.isDirectory (U.getFileStatus p) >>= \i -> if i - then getDirectoryFilesRecursive p else return [p] + names <- + map (path +/+) . filter (\x -> x /= ".." && x /= ".") + <$> getDirectoryFiles path + inspectedNames <- mapM inspect names + return $ concat inspectedNames + where + inspect :: RawFilePath -> IO [RawFilePath] + inspect p = + U.getFileStatus p + >>= ( \i -> + if i + then getDirectoryFilesRecursive p + else return [p] + ) + . U.isDirectory + -- | Create a new directory. -- -- > ghci> createDirectory "/tmp/mydir" @@ -146,62 +175,70 @@ 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 () + :: 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 + | 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@. If the file does -- not exist, an exception is thrown. removeFile :: RawFilePath -> IO () removeFile = U.removeLink + -- | A function that "tries" to remove a file. If the file does not exist, -- nothing happens. tryRemoveFile :: RawFilePath -> IO () tryRemoveFile path = catchIOError (U.removeLink path) $ - \ e -> unless (isDoesNotExistError e) $ ioError e + \e -> unless (isDoesNotExistError e) $ ioError e + -- | 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. @@ -216,8 +253,10 @@ ioError (err `ioeSetErrorString` "is a directory symbolic link") _ -> ioError (err `ioeSetErrorString` "not a directory") - where err = mkIOError InappropriateType "" Nothing (Just (B8.unpack path)) + 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. @@ -226,10 +265,11 @@ (`ioeAddLocation` "removePathRecursive") `modifyIOError` do m <- U.getSymbolicLinkStatus path case fileTypeFromMetadata m of - Directory -> removeContentsRecursive path + Directory -> removeContentsRecursive path DirectoryLink -> U.removeDirectory path - _ -> U.removeLink path + _ -> U.removeLink path + -- | Remove the contents of the directory /dir/ recursively. Symbolic links -- are removed without affecting their the targets. removeContentsRecursive :: RawFilePath -> IO () @@ -243,14 +283,18 @@ 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 +/+ +infixr 5 +/+ + + (+/+) :: RawFilePath -> RawFilePath -> RawFilePath a +/+ b = mconcat [a, "/", b] diff --git a/src/RawFilePath/Directory/Internal.hs b/src/RawFilePath/Directory/Internal.hs --- a/src/RawFilePath/Directory/Internal.hs +++ b/src/RawFilePath/Directory/Internal.hs @@ -1,21 +1,23 @@ 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 + 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) + = File + | SymbolicLink + | Directory + | DirectoryLink + deriving (Bounded, Enum, Eq, Ord, Read, Show) + fileTypeFromMetadata :: U.FileStatus -> FileType fileTypeFromMetadata stat diff --git a/src/RawFilePath/Import.hs b/src/RawFilePath/Import.hs --- a/src/RawFilePath/Import.hs +++ b/src/RawFilePath/Import.hs @@ -1,14 +1,15 @@ -module RawFilePath.Import - ( module Module - , ByteString - , RawFilePath - ) where +module RawFilePath.Import ( + module Module, + ByteString, + 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.ByteString (ByteString) import Data.Char as Module import Data.Functor as Module import Data.Maybe as Module @@ -17,7 +18,7 @@ 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, Directory) +import GHC.IO.Device as Module hiding (Directory, close, getEcho, setEcho) import GHC.IO.Encoding as Module import GHC.IO.Exception as Module import GHC.IO.Handle.Internals as Module @@ -27,7 +28,5 @@ import System.IO as Module import System.IO.Error as Module import System.IO.Unsafe as Module - -import Data.ByteString (ByteString) -import System.Posix.Types as Module import System.Posix.ByteString (RawFilePath) +import System.Posix.Types as Module diff --git a/src/RawFilePath/Process.hs b/src/RawFilePath/Process.hs --- a/src/RawFilePath/Process.hs +++ b/src/RawFilePath/Process.hs @@ -1,7 +1,10 @@ ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : RawFilePath.Process --- Copyright : (C) XT et al. 2017 +-- Copyright : (C) XT et al. 2017 - 2024 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : e@xtendo.org @@ -17,17 +20,17 @@ -- 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). +-- unnecessary runtime errors when obtaining t'System.IO.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 +-- t'System.IO.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'. +-- from a t'System.IO.Handle' as a 'ByteString'. -- --- == Fast and Brief Example +-- == Fast and brief example -- -- If you have experience with Unix pipes, this example should be pretty -- straightforward. In fact it is so simple that you don't need any type @@ -56,7 +59,7 @@ -- -- That's it! You can totally skip the verbose explanation below. -- --- == Verbose Explanation of the Example +-- == Verbose explanation of the example -- -- We launch @sed@ as a child process. As we know, it is a regular expression -- search and replacement tool. In the example, @sed@ is a simple Unix pipe @@ -65,8 +68,8 @@ -- -- In @sed@ regex, @\\\>@ means "the end of the word." So, @"s\/\\\\\>\/!\/g"@ -- means "substitute all ends of the words with an exclamation mark." Then, we --- feed some text to its @stdin@, close @stdin@ (to send EOF to @sed@ EOF), --- and read what it said to @stdout@. +-- feed some text to its @stdin@, close @stdin@ (to send EOF to @sed@'s +-- @stdin@), and read what it wrote to @stdout@. -- -- The interesting part is 'proc'. It is a simple function that takes a -- command and its arguments and returns a 'ProcessConf' which defines the @@ -74,18 +77,21 @@ -- functions like 'setStdin' or 'setStdout' to change those properties. -- -- The advantage of this interface is type safety. Take @stdout@ for example. --- There are four options: @Inherit@, @UseHandle@, @CreatePipe@, and --- @NoStream@. If you want to read @stdout@ of the child process, you must set +-- There are four options: 'Inherit', 'UseHandle', 'CreatePipe', and +-- 'NoStream'. If you want to read @stdout@ of the child process, you must set -- it to @CreatePipe@. With the @process@ package, this is done by giving a -- proper argument to @createProcess@. The trouble is, regardless of the --- argument, @createProcess@ returns 'Maybe' 'Handle' as @stdout@. You may or --- may not get a 'Handle'. +-- argument, @createProcess@ returns 'Maybe' t'System.IO.Handle' as @stdout@. +-- You may or may not get a t'System.IO.Handle'. -- --- This is not what we want with Haskell. We want to ensure that (1) we use --- 'CreatePipe' and certainly get the @stdout@ 'Handle' without the fear of --- 'Nothing', and (2) if we don't use 'CreatePipe' but still request the --- @stdout@ 'Handle', it is an error, detected at compile time. +-- This is not what we want with Haskell. We want to ensure that -- +-- 1. We use 'CreatePipe' and certainly get the @stdout@ t'System.IO.Handle' +-- (without having to write unncessary handling for the 'Nothing' case that +-- never happens). +-- 2. If we don't use 'CreatePipe' but still request the @stdout@ +-- t'System.IO.Handle', it is an error, detected __compile-time__. +-- -- So that's what @RawFilePath.Process@ does. In the above example, we use -- functions like 'setStdout'. Later, you use the 'processStdout' family of -- functions to get the process's standard stream handles. This requires that @@ -99,9 +105,9 @@ -- @ -- -- ... If you want to create a new pipe for the child process's @stdin@. Then --- you can later use `processStdout` to get the 'Handle'. If you don't put the --- @\`setStdout\` CreatePipe@ part or set it to something other than --- @CreatePipe@, it will be a compile-time error to use 'processStdout' on +-- you can later use `processStdout` to get the t'System.IO.Handle'. If you +-- don't put the @\`setStdout\` CreatePipe@ part or set it to something other +-- than @CreatePipe@, it will be a compile-time error to use 'processStdout' on -- this process object. -- -- In short, it makes the correct code easy and the wrong code impossible. @@ -113,68 +119,140 @@ -- 3. A lot more portability (doesn't require any language extension). -- -- Enjoy. --- ------------------------------------------------------------------------------ +module RawFilePath.Process ( + RawFilePath, + -- ** Configuring process + -- $configuring + ProcessConf, + proc, -module RawFilePath.Process - ( RawFilePath - -- ** Configuring process - -- $configuring - , ProcessConf - , proc + -- *** Configuring process standard streams + StreamType, + CreatePipe (..), + Inherit (..), + NoStream (..), + UseHandle (..), + setStdin, + setStdout, + setStderr, - -- *** Configuring process standard streams - , StreamType - , CreatePipe(..) - , Inherit(..) - , NoStream(..) - , UseHandle(..) - , setStdin - , setStdout - , setStderr + -- ** Running process + Process, + startProcess, - -- ** Running process - , Process - , startProcess + -- ** Obtaining process streams + -- $obtaining + processStdin, + processStdout, + processStderr, - -- ** Obtaining process streams - -- $obtaining - , processStdin - , processStdout - , processStderr + -- ** Process completion + stopProcess, + terminateProcess, + waitForProcess, - -- ** Process completion - , stopProcess - , terminateProcess - , waitForProcess + -- ** Untyped process + -- $untyped + UnknownStream, - -- ** Utility functions - -- $utility - , callProcess - , readProcessWithExitCode + -- *** Functions to untype process streams + untypeProcess, + untypeProcessStdin, + untypeProcessStdout, + untypeProcessStderr, - ) where + -- *** Functions to obtain @Maybe Handle@ from @UnknownStream@ + processStdinUnknown, + processStdoutUnknown, + processStderrUnknown, -import RawFilePath.Import + -- ** Utility functions + -- $utility + callProcess, + readProcessWithExitCode, +) where +import RawFilePath.Import -- 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. +-- 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 +-- t'System.IO.Handle's instead of returning 'Maybe' t'System.IO.Handle's like +-- the @process@ package does. + + +-- $untyped -- +-- @since 1.1.1 +-- +-- Type safety is awesome, and having types like @Process NoStream +-- CreatePipe Inherit@ is the whole point of this module. +-- +-- However, __after__ we've dealt with many sub-processes and their stream +-- t'System.IO.Handle's, we may have +-- +-- * 'Process' 'Inherit' 'CreatePipe' 'Inherit' +-- +-- * 'Process' 'CreatePipe' 'Inherit' 'Inherit' +-- +-- * 'Process' 'CreatePipe' 'CreatePipe' 'CreatePipe' +-- +-- * 'Process' 'NoStream' 'Inherit' 'Inherit' +-- +-- * 'Process' 'NoStream' 'CreatePipe' 'Inherit' +-- +-- * 'Process' 'Inherit' 'CreatePipe' 'CreatePipe' +-- +-- * ... +-- +-- You get the point. It gets out of hand! There are \( 4^3 = 64 \) +-- combinations and they are all "different process types." You can't put them +-- in a same basket. There are realistic reasons you'd want this: +-- +-- * To keep track of many sub-processes you create, and later properly clean +-- them up. +-- +-- * To have a group of /partially typed/ sub-processes: For example, if you +-- have one @Process NoStream 'CreatePipe' Inherit@ and one @Process +-- CreatePipe 'CreatePipe' CreatePipe@, both are guaranteed to have +-- __stdout__. You'd want to put them into a list, and later loop over them +-- to collect the stdout t'System.IO.Handle's. +-- +-- (Maybe you can use extensions like @ExistentialQuantification@ for this +-- but... It's like you're trying to safeguard your house by installing iron +-- walls in front of the gate, then bringing in a tunnel boring machine to +-- construct an underground passage. Also, we advertised rawfilepath with +-- "minimal dependencies" and "high portability.") +-- +-- This is why rawfilepath now provides 'UnknownStream' and its related +-- functions. So, +-- +-- @ +-- 'Process' 'UnknownStream' 'UnknownStream' 'UnknownStream' +-- @ +-- +-- ... is much like the traditional, un-typed process. You can get a 'Maybe' +-- t'System.IO.Handle' for an 'UnknownStream'. This is useful when you +-- +-- 1. ... Are done with any standard stream I/O +-- 2. ... No longer need the compile-time guarantee of getting (or being +-- prevented to get) t'System.IO.Handle's. +-- 3. ... But still need the 'Process' + + -- $utility -- -- These are utility functions; they can be implemented with the primary diff --git a/src/RawFilePath/Process/Basic.hs b/src/RawFilePath/Process/Basic.hs --- a/src/RawFilePath/Process/Basic.hs +++ b/src/RawFilePath/Process/Basic.hs @@ -3,72 +3,78 @@ -- 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) + :: (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 + 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_) + 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 + 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 + 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. +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 --- a/src/RawFilePath/Process/Common.hs +++ b/src/RawFilePath/Process/Common.hs @@ -1,88 +1,106 @@ -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 +module RawFilePath.Process.Common ( + Process (..), + ProcessConf (..), + proc, + processStdin, + processStdout, + processStderr, + StreamType, + mbFd, + willCreateHandle, + CreatePipe (..), + Inherit (..), + NoStream (..), + UseHandle (..), + setStdin, + setStdout, + setStderr, + UnknownStream, + untypeProcess, + untypeProcessStdin, + untypeProcessStdout, + untypeProcessStderr, + processStdinUnknown, + processStdoutUnknown, + processStderrUnknown, + PHANDLE, + ProcessHandle__ (..), + modifyProcessHandle, + withProcessHandle, + fdStdin, + fdStdout, + fdStderr, + mbPipe, +) where -- extra modules +import qualified GHC.IO.FD as FD import GHC.IO.Handle.FD as Module (mkHandleFromFD) +import RawFilePath.Import import System.Posix.Internals (FD) -import qualified GHC.IO.FD as FD + -- Original declarations +-- | Represents a stream whose creation information is unknown; We don't have +-- any type system guarantee of the t'System.IO.Handle'\'s existence. +-- +-- @since 1.1.1 +data UnknownStream + + -- | 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@ - } + { 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 + :: RawFilePath + -- ^ Command to run + -> [ByteString] + -- ^ Arguments to the command + -> ProcessConf Inherit Inherit Inherit +proc cmd args = + ProcessConf { cmdargs = cmd : args , cwd = Nothing , env = Nothing @@ -98,147 +116,263 @@ , 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 } + :: (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 } + :: (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 } + :: (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 ()) - } + { 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" + 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" + 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" + 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 + +-- | Create a new pipe for the stream. You get a new t'System.IO.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 +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 +data NoStream = NoStream deriving (Show) + +-- | Use the supplied t'System.IO.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 + mbFd :: FD -> c -> IO FD + willCreateHandle :: c -> Bool + mbFd = undefined + willCreateHandle = undefined + {-# MINIMAL #-} + + instance StreamType CreatePipe where - mbFd _ _ = return (-1) - willCreateHandle _ = True + mbFd _ _ = return (-1) + willCreateHandle _ = True + + instance StreamType Inherit where - mbFd std _ = return std - willCreateHandle _ = False + mbFd std _ = return std + willCreateHandle _ = False + + instance StreamType NoStream where - mbFd _ _ = return (-2) - willCreateHandle _ = False + 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 + 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 +data ProcessHandle__ + = OpenHandle PHANDLE + | OpenExtHandle PHANDLE PHANDLE PHANDLE + | ClosedHandle ExitCode + + modifyProcessHandle - :: Process stdin stdout stderr - -> (ProcessHandle__ -> IO (ProcessHandle__, a)) - -> IO a + :: 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 + :: Process stdin stdout stderr -> (ProcessHandle__ -> IO a) -> IO a withProcessHandle p = withMVar (phandle p) + fdStdin, fdStdout, fdStderr :: FD -fdStdin = 0 +fdStdin = 0 fdStdout = 1 fdStderr = 2 -mbPipe :: StreamType c => c -> Ptr FD -> IOMode -> IO (Maybe Handle) -mbPipe streamConf pfd mode = if willCreateHandle streamConf + +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 + +-- | Deliberately "un-type" all three type parameters of a process. Then, the +-- three standard streams will be available as 'Maybe' t'System.IO.Handle'. +-- Obtain them using +-- +-- * 'processStdinUnknown' +-- +-- * 'processStdoutUnknown' +-- +-- * 'processStderrUnknown' +-- +-- @since 1.1.1 +untypeProcess + :: Process stdin stdout stderr + -> Process UnknownStream UnknownStream UnknownStream +untypeProcess p = p{phandle = phandle p} + + +-- | Deliberately "un-type" the standard input stream (stdin) type parameter of +-- a process. After this, use 'processStdinUnknown' to access 'Maybe' +-- t'System.IO.Handle'. +-- +-- @since 1.1.1 +untypeProcessStdin + :: Process stdin stdout stderr + -> Process UnknownStream stdout stderr +untypeProcessStdin p = p{procStdin = procStdin p} + + +-- | Deliberately "un-type" the standard output stream (stdout) type parameter of +-- a process. After this, use 'processStdinUnknown' to access 'Maybe' +-- t'System.IO.Handle'. +-- +-- @since 1.1.1 +untypeProcessStdout + :: Process stdin stdout stderr + -> Process stdin UnknownStream stderr +untypeProcessStdout p = p{procStdout = procStdout p} + + +-- | Deliberately "un-type" the standard error stream (stderr) type parameter +-- of a process. After this, use 'processStdinUnknown' to access 'Maybe' +-- t'System.IO.Handle'. +-- +-- @since 1.1.1 +untypeProcessStderr + :: Process stdin stdout stderr + -> Process stdin stdout UnknownStream +untypeProcessStderr p = p{procStderr = procStderr p} + + +-- | Obtain the stdin t'System.IO.Handle' from a process. The result could be +-- 'Nothing', so dealing with that is the caller's responsibility. +-- +-- @since 1.1.1 +processStdinUnknown :: Process UnknownStream stdout stderr -> Maybe Handle +processStdinUnknown = procStdin + + +-- | Obtain the stdout t'System.IO.Handle' from a process. There is no +-- guarantee; It may return 'Nothing', and dealing with it is a runtime +-- responsibility. +-- +-- @since 1.1.1 +processStdoutUnknown :: Process stdin UnknownStream stderr -> Maybe Handle +processStdoutUnknown = procStdout + + +-- | Obtain the stderr t'System.IO.Handle' from a process. There is no +-- guarantee; It may return 'Nothing', and dealing with it is a runtime +-- responsibility. +-- +-- @since 1.1.1 +processStderrUnknown :: Process stdin stdout UnknownStream -> Maybe Handle +processStderrUnknown = procStderr + + 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_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 --- a/src/RawFilePath/Process/Internal.hs +++ b/src/RawFilePath/Process/Internal.hs @@ -1,28 +1,29 @@ {-# LANGUAGE InterruptibleFFI #-} -module RawFilePath.Process.Internal - ( c_terminateProcess - , c_getProcessExitCode - , c_waitForProcess - ) where +module RawFilePath.Process.Internal ( + c_terminateProcess, + c_getProcessExitCode, + c_waitForProcess, +) where import Foreign import Foreign.C - +import RawFilePath.Process.Common 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 diff --git a/src/RawFilePath/Process/Posix.hs b/src/RawFilePath/Process/Posix.hs --- a/src/RawFilePath/Process/Posix.hs +++ b/src/RawFilePath/Process/Posix.hs @@ -1,123 +1,140 @@ -module RawFilePath.Process.Posix - ( createProcessInternal - , withCEnvironment - , closePHANDLE - , startDelegateControlC - , endDelegateControlC - , stopDelegateControlC - , c_execvpe - , pPrPr_disableITimers - , createPipe - , createPipeInternalFd - ) where - -import RawFilePath.Import +module RawFilePath.Process.Posix ( + createProcessInternal, + withCEnvironment, + closePHANDLE, + startDelegateControlC, + endDelegateControlC, + stopDelegateControlC, + c_execvpe, + pPrPr_disableITimers, + createPipe, + createPipeInternalFd, +) where -- extra modules -import Data.ByteString.Internal (ByteString(..), memcpy) +import Data.ByteString.Internal (ByteString (..)) +import RawFilePath.Import +-- local modules + +import RawFilePath.Process.Common import System.Posix.ByteString.FilePath (withFilePath) +import qualified System.Posix.IO as Posix import System.Posix.Internals hiding (withFilePath) -import System.Posix.Process.Internals ( pPrPr_disableITimers, c_execvpe ) +import System.Posix.Process.Internals (c_execvpe, pPrPr_disableITimers) 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) + 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)) +copyByteStrings (PS fp o l : xs) buf cs = withForeignPtr fp $ \p -> do + copyBytes 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 + :: [(ByteString, ByteString)] -> (Ptr CString -> IO a) -> IO a withCEnvironment envir act = let env' = map (\(name, val) -> name <> "=" <> val) envir - in withManyByteString env' act + 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 + :: (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 - fdin <- mbFd fdStdin cfgStdin - fdout <- mbFd fdStdout cfgStdout - fderr <- mbFd fdStderr cfgStderr + when delegateCtlc startDelegateControlC - 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 - -- 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) - 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 - 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) - 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 @@ -136,62 +153,64 @@ -- restore when the last one has finished. {-# NOINLINE runInteractiveProcessDelegateCtlc #-} -runInteractiveProcessDelegateCtlc :: MVar (Maybe (Int, Sig.Handler, Sig.Handler)) +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)) + 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)) - 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 + 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 - 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 + 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) + -- 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 @@ -205,19 +224,21 @@ -> Ptr FD -> Ptr CGid -> Ptr CUid - -> CInt -- reset child's SIGINT & SIGQUIT handlers - -> CInt -- flags + -> 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) + (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) + (Fd readfd, Fd writefd) <- Posix.createPipe + return (readfd, writefd) diff --git a/src/RawFilePath/Process/Utility.hs b/src/RawFilePath/Process/Utility.hs --- a/src/RawFilePath/Process/Utility.hs +++ b/src/RawFilePath/Process/Utility.hs @@ -1,57 +1,65 @@ -module RawFilePath.Process.Utility - ( callProcess - , readProcessWithExitCode - ) where +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 - +import qualified Data.ByteString.Lazy as LB +import RawFilePath.Import -- local modules -import RawFilePath.Process.Common import RawFilePath.Process.Basic +import RawFilePath.Process.Common + -- | Create a new process with the given configuration, and wait for it to --- finish. +-- finish. Note that this will set all streams to `NoStream`, so the process +-- will be completely silent. If you need the output data from the process, use +-- `readProcessWithExitCode` instead. callProcess :: ProcessConf stdin stdout stderr -> IO ExitCode callProcess conf = start >>= waitForProcess - where - start = startProcess conf + where + start = + startProcess + conf { cfgStdin = NoStream , cfgStdout = NoStream , cfgStderr = NoStream } + -- | Fork an external process, read its standard output and standard error -- strictly, blocking until the process terminates, and return them with the -- process exit code. readProcessWithExitCode - :: ProcessConf stdin stdout stderr - -> IO (ExitCode, ByteString, ByteString) + :: ProcessConf stdin stdout stderr + -> IO (ExitCode, ByteString, ByteString) readProcessWithExitCode conf = do - process <- startProcess conf + process <- + startProcess + conf { cfgStdin = NoStream , cfgStdout = CreatePipe , cfgStderr = CreatePipe } - stdoutB <- hGetAll (processStdout process) - stderrB <- hGetAll (processStderr process) - exitCode <- waitForProcess process - return (exitCode, stdoutB, stderrB) + 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' + where + hGetAll' acc h' = + tryIOError (B.hGetContents h) >>= \case + Left _ -> return acc + Right b -> hGetAll' (acc <> B.byteString b) h' diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,12 +1,13 @@ -{-# language OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} -import RawFilePath import qualified Data.ByteString as B +import RawFilePath + main :: IO () main = do - p <- startProcess $ proc "echo" ["hello"] `setStdout` CreatePipe - result <- B.hGetContents (processStdout p) - _ <- waitForProcess p + p <- startProcess $ proc "echo" ["hello"] `setStdout` CreatePipe + result <- B.hGetContents (processStdout p) + _ <- waitForProcess p - print (result == "hello\n") + print (result == "hello\n")