packages feed

rawfilepath 1.1.0 → 1.1.1

raw patch · 15 files changed

+853/−559 lines, 15 files

Files

LICENSE view
@@ -7,7 +7,7 @@  == The 2-Clause BSD License == -Copyright 2016-2017 XT <https://e.xtendo.org/>+Copyright 2016-2024 XT <https://xtendo.org/> 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 <https://e.xtendo.org/>+Copyright (c) 2016-2024 XT <https://xtendo.org/> et al.  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated
README.md view
@@ -1,6 +1,6 @@ # rawfilepath -Version: 1.1.0+Version: 1.1.1  ## TL;DR
rawfilepath.cabal view
@@ -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
src/Data/ByteString/RawFilePath.hs view
@@ -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
src/RawFilePath.hs view
@@ -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)
src/RawFilePath/Directory.hs view
@@ -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]
src/RawFilePath/Directory/Internal.hs view
@@ -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
src/RawFilePath/Import.hs view
@@ -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
src/RawFilePath/Process.hs view
@@ -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
src/RawFilePath/Process/Basic.hs view
@@ -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.
src/RawFilePath/Process/Common.hs view
@@ -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)
src/RawFilePath/Process/Internal.hs view
@@ -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
src/RawFilePath/Process/Posix.hs view
@@ -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)
src/RawFilePath/Process/Utility.hs view
@@ -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'
test/Spec.hs view
@@ -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")