Some some

.travis.yml

@@ -68,6 +68,7 @@ install:
  - cabal install --installdir=$HOME/.cabal/bin doctest
 
 script:
+ - (cd unix && autoreconf -fi)
  - cabal build --enable-tests all
  - cabal run spec
  - ./hpath/run-doctests.sh

cabal.project

@@ -3,6 +3,7 @@ packages: ./hpath
           ./hpath-filepath
           ./hpath-io
           ./hpath-posix
+          ./unix
 
 package hpath-io
     ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16

hpath-posix/src/System/Posix/RawFilePath/Directory/Traversals.hs

@@ -30,8 +30,6 @@ module System.Posix.RawFilePath.Directory.Traversals (
 
 -- lower-level stuff
 , readDirEnt
-, packDirStream
-, unpackDirStream
 , fdOpendir
 
 , realpath
@@ -52,11 +50,11 @@ import Control.Exception
 import qualified Data.ByteString.Char8 as BS
 import System.Posix.ByteString.FilePath
 import System.Posix.Directory.ByteString as PosixBS
+import System.Posix.Directory.Common
 import System.Posix.Files.ByteString
 
 import System.IO.Unsafe
 import "unix" System.Posix.IO.ByteString (closeFd)
-import Unsafe.Coerce (unsafeCoerce)
 import Foreign.C.Error
 import Foreign.C.String
 import Foreign.C.Types
@@ -148,18 +146,6 @@ actOnDirContents pathRelToTop b f =
 ----------------------------------------------------------
 -- dodgy stuff
 
-type CDir = ()
-type CDirent = ()
-
--- Posix doesn't export DirStream, so to re-use that type we need to use
--- unsafeCoerce.  It's just a newtype, so this is a legitimate usage.
--- ugly trick.
-unpackDirStream :: DirStream -> Ptr CDir
-unpackDirStream = unsafeCoerce
-
-packDirStream :: Ptr CDir -> DirStream
-packDirStream = unsafeCoerce
-
 -- the __hscore_* functions are defined in the unix package.  We can import them and let
 -- the linker figure it out.
 foreign import ccall unsafe "__hscore_readdir"
@@ -178,14 +164,14 @@ foreign import ccall "realpath"
   c_realpath :: CString -> CString -> IO CString
 
 foreign import ccall unsafe "fdopendir"
-  c_fdopendir :: Posix.Fd -> IO (Ptr ())
+  c_fdopendir :: Posix.Fd -> IO (Ptr CDir)
 
 ----------------------------------------------------------
 -- less dodgy but still lower-level
 
 
 readDirEnt :: DirStream -> IO (DirType, RawFilePath)
-readDirEnt (unpackDirStream -> dirp) =
+readDirEnt (DirStream dirp) =
   alloca $ \ptr_dEnt  -> loop ptr_dEnt
  where
   loop ptr_dEnt = do
@@ -228,7 +214,7 @@ getDirectoryContents path =
 -- |Binding to @fdopendir(3)@.
 fdOpendir :: Posix.Fd -> IO DirStream
 fdOpendir fd =
-    packDirStream <$> throwErrnoIfNull "fdOpendir" (c_fdopendir fd)
+    DirStream <$> throwErrnoIfNull "fdOpendir" (c_fdopendir fd)
 
 
 -- |Like `getDirectoryContents` except for a file descriptor.

unix/LICENSE

@@ -0,0 +1,31 @@
+The Glasgow Haskell Compiler License
+
+Copyright 2004, The University Court of the University of Glasgow. 
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+ 
+- Redistributions in binary form must reproduce the above copyright notice,
+this list of conditions and the following disclaimer in the documentation
+and/or other materials provided with the distribution.
+ 
+- Neither name of the University nor the names of its contributors may be
+used to endorse or promote products derived from this software without
+specific prior written permission. 
+
+THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGE.

unix/README.md

@@ -0,0 +1,15 @@
+The `unix` Package  [![Hackage](https://img.shields.io/hackage/v/unix.svg)](https://hackage.haskell.org/package/unix) [![Build Status](https://travis-ci.org/haskell/unix.svg)](https://travis-ci.org/haskell/unix)
+==================
+
+See [`unix` on Hackage](http://hackage.haskell.org/package/unix) for
+more information.
+
+Installing from Git
+-------------------
+
+To build this package using Cabal directly from Git, you must run
+`autoreconf -i` before the usual Cabal build steps (`cabal
+{configure,build,install}`). The program `autoreconf` is part of
+[GNU autoconf](http://www.gnu.org/software/autoconf/).  There is no
+need to run the `configure` script: `cabal configure` will do this for
+you.

unix/Setup.hs

@@ -0,0 +1,6 @@
+module Main (main) where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMainWithHooks autoconfUserHooks

unix/System/Posix.hs

@@ -0,0 +1,189 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE Safe #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- <http://pubs.opengroup.org/onlinepubs/9699919799/ POSIX.1-2008> support
+--
+-----------------------------------------------------------------------------
+
+module System.Posix (
+  module System.Posix.Types,
+  module System.Posix.Signals,
+  module System.Posix.Directory,
+  module System.Posix.Files,
+  module System.Posix.Unistd,
+  module System.Posix.IO,
+  module System.Posix.Env,
+  module System.Posix.Process,
+  module System.Posix.Temp,
+  module System.Posix.Terminal,
+  module System.Posix.Time,
+  module System.Posix.User,
+  module System.Posix.Resource,
+  module System.Posix.Semaphore,
+  module System.Posix.SharedMem,
+  module System.Posix.DynamicLinker,
+-- XXX 'Module' type clashes with GHC
+--  module System.Posix.DynamicLinker.Module
+ ) where
+
+import System.Posix.Types
+import System.Posix.Signals
+import System.Posix.Directory
+import System.Posix.Files
+import System.Posix.Unistd
+import System.Posix.Process
+import System.Posix.IO
+import System.Posix.Env
+import System.Posix.Temp
+import System.Posix.Terminal
+import System.Posix.Time
+import System.Posix.User
+import System.Posix.Resource
+import System.Posix.Semaphore
+import System.Posix.SharedMem
+-- XXX: bad planning, we have two constructors called "Default"
+import System.Posix.DynamicLinker hiding (Default)
+--import System.Posix.DynamicLinker.Module
+
+{- TODO
+
+Here we detail our support for the IEEE Std 1003.1-2001 standard.  For
+each header file defined by the standard, we categorise its
+functionality as
+
+ - "supported"
+
+   Full equivalent functionality is provided by the specified Haskell
+   module.
+
+ - "unsupported" (functionality not provided by a Haskell module)
+
+   The functionality is not currently provided.
+
+ - "to be supported"
+
+   Currently unsupported, but support is planned for the future.
+
+Exceptions are listed where appropriate.
+
+Interfaces supported
+--------------------
+
+unix package:
+
+dirent.h 	System.Posix.Directory
+dlfcn.h 	System.Posix.DynamicLinker
+errno.h 	Foreign.C.Error
+fcntl.h 	System.Posix.IO
+signal.h	System.Posix.Signals
+sys/stat.h	System.Posix.Files
+sys/times.h	System.Posix.Process
+sys/types.h	System.Posix.Types (with exceptions...)
+sys/utsname.h	System.Posix.Unistd
+sys/wait.h	System.Posix.Process
+termios.h	System.Posix.Terminal (check exceptions)
+unistd.h	System.Posix.*
+utime.h		System.Posix.Files
+pwd.h		System.Posix.User
+grp.h		System.Posix.User
+stdlib.h: 	System.Posix.Env (getenv()/setenv()/unsetenv())
+		System.Posix.Temp (mkstemp())
+sys/resource.h: System.Posix.Resource (get/setrlimit() only)
+
+regex-posix package:
+
+regex.h		Text.Regex.Posix
+
+network package:
+
+arpa/inet.h
+net/if.h
+netinet/in.h
+netinet/tcp.h
+sys/socket.h
+sys/un.h
+
+To be supported
+---------------
+
+limits.h	(pathconf()/fpathconf() already done)
+poll.h
+sys/resource.h  (getrusage(): use instead of times() for getProcessTimes?)
+sys/select.h
+sys/statvfs.h	 (?)
+sys/time.h	(but maybe not the itimer?)
+time.h		(System.Posix.Time)
+stdio.h		(popen only: System.Posix.IO)
+sys/mman.h
+
+Unsupported interfaces
+----------------------
+
+aio.h
+assert.h
+complex.h
+cpio.h
+ctype.h
+fenv.h
+float.h
+fmtmsg.h
+fnmatch.h
+ftw.h
+glob.h
+iconv.h
+inttypes.h
+iso646.h
+langinfo.h
+libgen.h
+locale.h	(see System.Locale)
+math.h
+monetary.h
+mqueue.h
+ndbm.h
+netdb.h
+nl_types.h
+pthread.h
+sched.h
+search.h
+semaphore.h
+setjmp.h
+spawn.h
+stdarg.h
+stdbool.h
+stddef.h
+stdint.h
+stdio.h		except: popen()
+stdlib.h	except: exit(): System.Posix.Process
+			free()/malloc(): Foreign.Marshal.Alloc
+			getenv()/setenv(): ?? System.Environment
+			rand() etc.: System.Random
+string.h
+strings.h
+stropts.h
+sys/ipc.h
+sys/msg.h
+sys/sem.h
+sys/shm.h
+sys/timeb.h
+sys/uio.h
+syslog.h
+tar.h
+tgmath.h
+trace.h
+ucontext.h
+ulimit.h
+utmpx.h
+wchar.h
+wctype.h
+wordexp.h
+
+-}

unix/System/Posix/ByteString.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE Safe #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.ByteString
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- <http://pubs.opengroup.org/onlinepubs/9699919799/ POSIX.1-2008>
+-- support with 'ByteString' file paths and environment strings.
+--
+-- This module exports exactly the same API as "System.Posix", except
+-- that all file paths and environment strings are represented by
+-- 'ByteString' instead of 'String'.  The "System.Posix" API
+-- implicitly translates all file paths and environment strings using
+-- the locale encoding, whereas this version of the API does no
+-- encoding or decoding and works directly in terms of raw bytes.
+--
+-- Note that if you do need to interpret file paths or environment
+-- strings as text, then some Unicode encoding or decoding should be
+-- applied first.
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.ByteString (
+  System.Posix.ByteString.FilePath.RawFilePath,
+  module System.Posix.Types,
+  module System.Posix.Signals,
+  module System.Posix.Directory.ByteString,
+  module System.Posix.Files.ByteString,
+  module System.Posix.Unistd,
+  module System.Posix.IO.ByteString,
+  module System.Posix.Env.ByteString,
+  module System.Posix.Process.ByteString,
+  module System.Posix.Temp.ByteString,
+  module System.Posix.Terminal.ByteString,
+  module System.Posix.Time,
+  module System.Posix.User,
+  module System.Posix.Resource,
+  module System.Posix.Semaphore,
+  module System.Posix.SharedMem,
+  module System.Posix.DynamicLinker.ByteString,
+-- XXX 'Module' type clashes with GHC
+--  module System.Posix.DynamicLinker.Module.ByteString
+ ) where
+
+import System.Posix.ByteString.FilePath
+import System.Posix.Types
+import System.Posix.Signals
+import System.Posix.Directory.ByteString
+import System.Posix.Files.ByteString
+import System.Posix.Unistd
+import System.Posix.Process.ByteString
+import System.Posix.IO.ByteString
+import System.Posix.Env.ByteString
+import System.Posix.Temp.ByteString
+import System.Posix.Terminal.ByteString
+import System.Posix.Time
+import System.Posix.User
+import System.Posix.Resource
+import System.Posix.Semaphore
+import System.Posix.SharedMem
+-- XXX: bad planning, we have two constructors called "Default"
+import System.Posix.DynamicLinker.ByteString hiding (Default)
+--import System.Posix.DynamicLinker.Module.ByteString

unix/System/Posix/ByteString/FilePath.hsc

@@ -0,0 +1,127 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.ByteString.FilePath
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- Internal stuff: support for ByteString FilePaths
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.ByteString.FilePath (
+     RawFilePath, withFilePath, peekFilePath, peekFilePathLen,
+     throwErrnoPathIfMinus1Retry,
+     throwErrnoPathIfMinus1Retry_,
+     throwErrnoPathIfNullRetry,
+     throwErrnoPathIfRetry,
+     throwErrnoPath,
+     throwErrnoPathIf,
+     throwErrnoPathIf_,
+     throwErrnoPathIfNull,
+     throwErrnoPathIfMinus1,
+     throwErrnoPathIfMinus1_
+  ) where
+
+import Foreign hiding ( void )
+import Foreign.C hiding (
+     throwErrnoPath,
+     throwErrnoPathIf,
+     throwErrnoPathIf_,
+     throwErrnoPathIfNull,
+     throwErrnoPathIfMinus1,
+     throwErrnoPathIfMinus1_ )
+
+import Control.Monad
+import Data.ByteString
+import Data.ByteString.Char8 as BC
+import Prelude hiding (FilePath)
+
+-- | A literal POSIX file path
+type RawFilePath = ByteString
+
+withFilePath :: RawFilePath -> (CString -> IO a) -> IO a
+withFilePath = useAsCString
+
+peekFilePath :: CString -> IO RawFilePath
+peekFilePath = packCString
+
+peekFilePathLen :: CStringLen -> IO RawFilePath
+peekFilePathLen = packCStringLen
+
+
+throwErrnoPathIfMinus1Retry :: (Eq a, Num a)
+                            => String -> RawFilePath -> IO a -> IO a
+throwErrnoPathIfMinus1Retry loc path f = do
+  throwErrnoPathIfRetry (== -1) loc path f
+
+throwErrnoPathIfMinus1Retry_ :: (Eq a, Num a)
+                             => String -> RawFilePath -> IO a -> IO ()
+throwErrnoPathIfMinus1Retry_ loc path f =
+  void $ throwErrnoPathIfRetry (== -1) loc path f
+
+throwErrnoPathIfNullRetry :: String -> RawFilePath -> IO (Ptr a) -> IO (Ptr a)
+throwErrnoPathIfNullRetry loc path f =
+  throwErrnoPathIfRetry (== nullPtr) loc path f
+
+throwErrnoPathIfRetry :: (a -> Bool) -> String -> RawFilePath -> IO a -> IO a
+throwErrnoPathIfRetry pr loc rpath f =
+  do
+    res <- f
+    if pr res
+      then do
+        err <- getErrno
+        if err == eINTR
+          then throwErrnoPathIfRetry pr loc rpath f
+          else throwErrnoPath loc rpath
+      else return res
+
+-- | as 'throwErrno', but exceptions include the given path when appropriate.
+--
+throwErrnoPath :: String -> RawFilePath -> IO a
+throwErrnoPath loc path =
+  do
+    errno <- getErrno
+    ioError (errnoToIOError loc errno Nothing (Just (BC.unpack path)))
+
+-- | as 'throwErrnoIf', but exceptions include the given path when
+--   appropriate.
+--
+throwErrnoPathIf :: (a -> Bool) -> String -> RawFilePath -> IO a -> IO a
+throwErrnoPathIf cond loc path f =
+  do
+    res <- f
+    if cond res then throwErrnoPath loc path else return res
+
+-- | as 'throwErrnoIf_', but exceptions include the given path when
+--   appropriate.
+--
+throwErrnoPathIf_ :: (a -> Bool) -> String -> RawFilePath -> IO a -> IO ()
+throwErrnoPathIf_ cond loc path f  = void $ throwErrnoPathIf cond loc path f
+
+-- | as 'throwErrnoIfNull', but exceptions include the given path when
+--   appropriate.
+--
+throwErrnoPathIfNull :: String -> RawFilePath -> IO (Ptr a) -> IO (Ptr a)
+throwErrnoPathIfNull  = throwErrnoPathIf (== nullPtr)
+
+-- | as 'throwErrnoIfMinus1', but exceptions include the given path when
+--   appropriate.
+--
+throwErrnoPathIfMinus1 :: (Eq a, Num a) => String -> RawFilePath -> IO a -> IO a
+throwErrnoPathIfMinus1 = throwErrnoPathIf (== -1)
+
+-- | as 'throwErrnoIfMinus1_', but exceptions include the given path when
+--   appropriate.
+--
+throwErrnoPathIfMinus1_ :: (Eq a, Num a) => String -> RawFilePath -> IO a -> IO ()
+throwErrnoPathIfMinus1_  = throwErrnoPathIf_ (== -1)

unix/System/Posix/Directory.hsc

@@ -0,0 +1,164 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Directory
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- String-based POSIX directory support
+--
+-----------------------------------------------------------------------------
+
+#include "HsUnix.h"
+
+-- hack copied from System.Posix.Files
+#if !defined(PATH_MAX)
+# define PATH_MAX 4096
+#endif
+
+module System.Posix.Directory (
+   -- * Creating and removing directories
+   createDirectory, removeDirectory,
+
+   -- * Reading directories
+   DirStream,
+   openDirStream,
+   readDirStream,
+   rewindDirStream,
+   closeDirStream,
+   DirStreamOffset,
+#ifdef HAVE_TELLDIR
+   tellDirStream,
+#endif
+#ifdef HAVE_SEEKDIR
+   seekDirStream,
+#endif
+
+   -- * The working dirctory
+   getWorkingDirectory,
+   changeWorkingDirectory,
+   changeWorkingDirectoryFd,
+  ) where
+
+import System.IO.Error
+import System.Posix.Error
+import System.Posix.Types
+import Foreign
+import Foreign.C
+
+import System.Posix.Directory.Common
+import System.Posix.Internals (withFilePath, peekFilePath)
+
+-- | @createDirectory dir mode@ calls @mkdir@ to
+--   create a new directory, @dir@, with permissions based on
+--  @mode@.
+createDirectory :: FilePath -> FileMode -> IO ()
+createDirectory name mode =
+  withFilePath name $ \s ->
+    throwErrnoPathIfMinus1Retry_ "createDirectory" name (c_mkdir s mode)
+    -- POSIX doesn't allow mkdir() to return EINTR, but it does on
+    -- OS X (#5184), so we need the Retry variant here.
+
+foreign import ccall unsafe "mkdir"
+  c_mkdir :: CString -> CMode -> IO CInt
+
+-- | @openDirStream dir@ calls @opendir@ to obtain a
+--   directory stream for @dir@.
+openDirStream :: FilePath -> IO DirStream
+openDirStream name =
+  withFilePath name $ \s -> do
+    dirp <- throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s
+    return (DirStream dirp)
+
+foreign import capi unsafe "HsUnix.h opendir"
+   c_opendir :: CString  -> IO (Ptr CDir)
+
+-- | @readDirStream dp@ calls @readdir@ to obtain the
+--   next directory entry (@struct dirent@) for the open directory
+--   stream @dp@, and returns the @d_name@ member of that
+--  structure.
+readDirStream :: DirStream -> IO FilePath
+readDirStream (DirStream dirp) =
+  alloca $ \ptr_dEnt  -> loop ptr_dEnt
+ where
+  loop ptr_dEnt = do
+    resetErrno
+    r <- c_readdir dirp ptr_dEnt
+    if (r == 0)
+         then do dEnt <- peek ptr_dEnt
+                 if (dEnt == nullPtr)
+                    then return []
+                    else do
+                     entry <- (d_name dEnt >>= peekFilePath)
+                     c_freeDirEnt dEnt
+                     return entry
+         else do errno <- getErrno
+                 if (errno == eINTR) then loop ptr_dEnt else do
+                 let (Errno eo) = errno
+                 if (eo == 0)
+                    then return []
+                    else throwErrno "readDirStream"
+
+-- traversing directories
+foreign import ccall unsafe "__hscore_readdir"
+  c_readdir  :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
+
+foreign import ccall unsafe "__hscore_free_dirent"
+  c_freeDirEnt  :: Ptr CDirent -> IO ()
+
+foreign import ccall unsafe "__hscore_d_name"
+  d_name :: Ptr CDirent -> IO CString
+
+
+-- | @getWorkingDirectory@ calls @getcwd@ to obtain the name
+--   of the current working directory.
+getWorkingDirectory :: IO FilePath
+getWorkingDirectory = go (#const PATH_MAX)
+  where
+    go bytes = do
+        r <- allocaBytes bytes $ \buf -> do
+            buf' <- c_getcwd buf (fromIntegral bytes)
+            if buf' /= nullPtr
+                then do s <- peekFilePath buf
+                        return (Just s)
+                else do errno <- getErrno
+                        if errno == eRANGE
+                            -- we use Nothing to indicate that we should
+                            -- try again with a bigger buffer
+                            then return Nothing
+                            else throwErrno "getWorkingDirectory"
+        maybe (go (2 * bytes)) return r
+
+foreign import ccall unsafe "getcwd"
+   c_getcwd   :: Ptr CChar -> CSize -> IO (Ptr CChar)
+
+-- | @changeWorkingDirectory dir@ calls @chdir@ to change
+--   the current working directory to @dir@.
+changeWorkingDirectory :: FilePath -> IO ()
+changeWorkingDirectory path =
+  modifyIOError (`ioeSetFileName` path) $
+    withFilePath path $ \s ->
+       throwErrnoIfMinus1Retry_ "changeWorkingDirectory" (c_chdir s)
+
+foreign import ccall unsafe "chdir"
+   c_chdir :: CString -> IO CInt
+
+removeDirectory :: FilePath -> IO ()
+removeDirectory path =
+  modifyIOError (`ioeSetFileName` path) $
+    withFilePath path $ \s ->
+       throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s)
+
+foreign import ccall unsafe "rmdir"
+   c_rmdir :: CString -> IO CInt

unix/System/Posix/Directory/ByteString.hsc

@@ -0,0 +1,165 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Directory.ByteString
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- String-based POSIX directory support
+--
+-----------------------------------------------------------------------------
+
+#include "HsUnix.h"
+
+-- hack copied from System.Posix.Files
+#if !defined(PATH_MAX)
+# define PATH_MAX 4096
+#endif
+
+module System.Posix.Directory.ByteString (
+   -- * Creating and removing directories
+   createDirectory, removeDirectory,
+
+   -- * Reading directories
+   DirStream,
+   openDirStream,
+   readDirStream,
+   rewindDirStream,
+   closeDirStream,
+   DirStreamOffset,
+#ifdef HAVE_TELLDIR
+   tellDirStream,
+#endif
+#ifdef HAVE_SEEKDIR
+   seekDirStream,
+#endif
+
+   -- * The working directory
+   getWorkingDirectory,
+   changeWorkingDirectory,
+   changeWorkingDirectoryFd,
+  ) where
+
+import System.IO.Error
+import System.Posix.Types
+import Foreign
+import Foreign.C
+
+import Data.ByteString.Char8 as BC
+
+import System.Posix.Directory.Common
+import System.Posix.ByteString.FilePath
+
+-- | @createDirectory dir mode@ calls @mkdir@ to
+--   create a new directory, @dir@, with permissions based on
+--  @mode@.
+createDirectory :: RawFilePath -> FileMode -> IO ()
+createDirectory name mode =
+  withFilePath name $ \s ->
+    throwErrnoPathIfMinus1Retry_ "createDirectory" name (c_mkdir s mode)
+    -- POSIX doesn't allow mkdir() to return EINTR, but it does on
+    -- OS X (#5184), so we need the Retry variant here.
+
+foreign import ccall unsafe "mkdir"
+  c_mkdir :: CString -> CMode -> IO CInt
+
+-- | @openDirStream dir@ calls @opendir@ to obtain a
+--   directory stream for @dir@.
+openDirStream :: RawFilePath -> IO DirStream
+openDirStream name =
+  withFilePath name $ \s -> do
+    dirp <- throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s
+    return (DirStream dirp)
+
+foreign import capi unsafe "HsUnix.h opendir"
+   c_opendir :: CString  -> IO (Ptr CDir)
+
+-- | @readDirStream dp@ calls @readdir@ to obtain the
+--   next directory entry (@struct dirent@) for the open directory
+--   stream @dp@, and returns the @d_name@ member of that
+--  structure.
+readDirStream :: DirStream -> IO RawFilePath
+readDirStream (DirStream dirp) =
+  alloca $ \ptr_dEnt  -> loop ptr_dEnt
+ where
+  loop ptr_dEnt = do
+    resetErrno
+    r <- c_readdir dirp ptr_dEnt
+    if (r == 0)
+         then do dEnt <- peek ptr_dEnt
+                 if (dEnt == nullPtr)
+                    then return BC.empty
+                    else do
+                     entry <- (d_name dEnt >>= peekFilePath)
+                     c_freeDirEnt dEnt
+                     return entry
+         else do errno <- getErrno
+                 if (errno == eINTR) then loop ptr_dEnt else do
+                 let (Errno eo) = errno
+                 if (eo == 0)
+                    then return BC.empty
+                    else throwErrno "readDirStream"
+
+-- traversing directories
+foreign import ccall unsafe "__hscore_readdir"
+  c_readdir  :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
+
+foreign import ccall unsafe "__hscore_free_dirent"
+  c_freeDirEnt  :: Ptr CDirent -> IO ()
+
+foreign import ccall unsafe "__hscore_d_name"
+  d_name :: Ptr CDirent -> IO CString
+
+
+-- | @getWorkingDirectory@ calls @getcwd@ to obtain the name
+--   of the current working directory.
+getWorkingDirectory :: IO RawFilePath
+getWorkingDirectory = go (#const PATH_MAX)
+  where
+    go bytes = do
+        r <- allocaBytes bytes $ \buf -> do
+            buf' <- c_getcwd buf (fromIntegral bytes)
+            if buf' /= nullPtr
+                then do s <- peekFilePath buf
+                        return (Just s)
+                else do errno <- getErrno
+                        if errno == eRANGE
+                            -- we use Nothing to indicate that we should
+                            -- try again with a bigger buffer
+                            then return Nothing
+                            else throwErrno "getWorkingDirectory"
+        maybe (go (2 * bytes)) return r
+
+foreign import ccall unsafe "getcwd"
+   c_getcwd   :: Ptr CChar -> CSize -> IO (Ptr CChar)
+
+-- | @changeWorkingDirectory dir@ calls @chdir@ to change
+--   the current working directory to @dir@.
+changeWorkingDirectory :: RawFilePath -> IO ()
+changeWorkingDirectory path =
+  modifyIOError (`ioeSetFileName` (BC.unpack path)) $
+    withFilePath path $ \s ->
+       throwErrnoIfMinus1Retry_ "changeWorkingDirectory" (c_chdir s)
+
+foreign import ccall unsafe "chdir"
+   c_chdir :: CString -> IO CInt
+
+removeDirectory :: RawFilePath -> IO ()
+removeDirectory path =
+  modifyIOError (`ioeSetFileName` BC.unpack path) $
+    withFilePath path $ \s ->
+       throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s)
+
+foreign import ccall unsafe "rmdir"
+   c_rmdir :: CString -> IO CInt

unix/System/Posix/Directory/Common.hsc

@@ -0,0 +1,88 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Directory.Common
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX directory support
+--
+-----------------------------------------------------------------------------
+
+#include "HsUnix.h"
+
+module System.Posix.Directory.Common (
+       DirStream(..), CDir, CDirent, DirStreamOffset(..),
+       rewindDirStream,
+       closeDirStream,
+#ifdef HAVE_SEEKDIR
+       seekDirStream,
+#endif
+#ifdef HAVE_TELLDIR
+       tellDirStream,
+#endif
+       changeWorkingDirectoryFd,
+  ) where
+
+import System.Posix.Types
+import Foreign
+import Foreign.C
+
+newtype DirStream = DirStream (Ptr CDir)
+
+data {-# CTYPE "DIR" #-} CDir
+data {-# CTYPE "struct dirent" #-} CDirent
+
+-- | @rewindDirStream dp@ calls @rewinddir@ to reposition
+--   the directory stream @dp@ at the beginning of the directory.
+rewindDirStream :: DirStream -> IO ()
+rewindDirStream (DirStream dirp) = c_rewinddir dirp
+
+foreign import ccall unsafe "rewinddir"
+   c_rewinddir :: Ptr CDir -> IO ()
+
+-- | @closeDirStream dp@ calls @closedir@ to close
+--   the directory stream @dp@.
+closeDirStream :: DirStream -> IO ()
+closeDirStream (DirStream dirp) = do
+  throwErrnoIfMinus1Retry_ "closeDirStream" (c_closedir dirp)
+
+foreign import ccall unsafe "closedir"
+   c_closedir :: Ptr CDir -> IO CInt
+
+newtype DirStreamOffset = DirStreamOffset COff
+
+#ifdef HAVE_SEEKDIR
+seekDirStream :: DirStream -> DirStreamOffset -> IO ()
+seekDirStream (DirStream dirp) (DirStreamOffset off) =
+  c_seekdir dirp (fromIntegral off) -- TODO: check for CLong/COff overflow
+
+foreign import ccall unsafe "seekdir"
+  c_seekdir :: Ptr CDir -> CLong -> IO ()
+#endif
+
+#ifdef HAVE_TELLDIR
+tellDirStream :: DirStream -> IO DirStreamOffset
+tellDirStream (DirStream dirp) = do
+  off <- c_telldir dirp
+  return (DirStreamOffset (fromIntegral off)) -- TODO: check for overflow
+
+foreign import ccall unsafe "telldir"
+  c_telldir :: Ptr CDir -> IO CLong
+#endif
+
+changeWorkingDirectoryFd :: Fd -> IO ()
+changeWorkingDirectoryFd (Fd fd) =
+  throwErrnoIfMinus1Retry_ "changeWorkingDirectoryFd" (c_fchdir fd)
+
+foreign import ccall unsafe "fchdir"
+  c_fchdir :: CInt -> IO CInt

unix/System/Posix/DynamicLinker.hsc

@@ -0,0 +1,72 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.DynamicLinker
+-- Copyright   :  (c) Volker Stolz <vs@foldr.org> 2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  vs@foldr.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- Dynamic linker support through dlopen()
+-----------------------------------------------------------------------------
+
+module System.Posix.DynamicLinker (
+
+    module System.Posix.DynamicLinker.Prim,
+    dlopen,
+    dlsym,
+    dlerror,
+    dlclose,
+    withDL, withDL_,
+    undl,
+    )
+
+--  Usage:
+--  ******
+--
+--  Let's assume you want to open a local shared library \'foo\' (.\/libfoo.so)
+--  offering a function
+--    @char \* mogrify (char\*,int)@
+--  and invoke @str = mogrify("test",1)@:
+--
+--
+--  type Fun = CString -> Int -> IO CString
+--  foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun
+--
+--  withDL "libfoo.so" [RTLD_NOW] \$ \\ mod -> do
+--     funptr <- dlsym mod "mogrify"
+--     let fun = fun__ funptr
+--     withCString "test" \$ \\ str -> do
+--       strptr <- fun str 1
+--       strstr <- peekCString strptr
+--       ...
+--
+
+where
+
+import System.Posix.DynamicLinker.Common
+import System.Posix.DynamicLinker.Prim
+
+#include "HsUnix.h"
+
+import Control.Exception        ( bracket )
+import Control.Monad    ( liftM )
+import Foreign
+import System.Posix.Internals ( withFilePath )
+
+dlopen :: FilePath -> [RTLDFlags] -> IO DL
+dlopen path flags = do
+  withFilePath path $ \ p -> do
+    liftM DLHandle $ throwDLErrorIf "dlopen" (== nullPtr) $ c_dlopen p (packRTLDFlags flags)
+
+withDL :: FilePath -> [RTLDFlags] -> (DL -> IO a) -> IO a
+withDL file flags f = bracket (dlopen file flags) (dlclose) f
+
+withDL_ :: FilePath -> [RTLDFlags] -> (DL -> IO a) -> IO ()
+withDL_ file flags f = withDL file flags f >> return ()

unix/System/Posix/DynamicLinker/ByteString.hsc

@@ -0,0 +1,73 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.DynamicLinker.ByteString
+-- Copyright   :  (c) Volker Stolz <vs@foldr.org> 2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  vs@foldr.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- Dynamic linker support through dlopen()
+-----------------------------------------------------------------------------
+
+module System.Posix.DynamicLinker.ByteString (
+
+    module System.Posix.DynamicLinker.Prim,
+    dlopen,
+    dlsym,
+    dlerror,
+    dlclose,
+    withDL, withDL_,
+    undl,
+    )
+
+--  Usage:
+--  ******
+--
+--  Let's assume you want to open a local shared library \'foo\' (.\/libfoo.so)
+--  offering a function
+--    @char \* mogrify (char\*,int)@
+--  and invoke @str = mogrify("test",1)@:
+--
+--
+--  type Fun = CString -> Int -> IO CString
+--  foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun
+--
+--  withDL "libfoo.so" [RTLD_NOW] \$ \\ mod -> do
+--     funptr <- dlsym mod "mogrify"
+--     let fun = fun__ funptr
+--     withCString "test" \$ \\ str -> do
+--       strptr <- fun str 1
+--       strstr <- peekCString strptr
+--       ...
+--
+
+where
+
+import System.Posix.DynamicLinker.Common
+import System.Posix.DynamicLinker.Prim
+
+#include "HsUnix.h"
+
+import Control.Exception        ( bracket )
+import Control.Monad    ( liftM )
+import Foreign
+import System.Posix.ByteString.FilePath
+
+dlopen :: RawFilePath -> [RTLDFlags] -> IO DL
+dlopen path flags = do
+  withFilePath path $ \ p -> do
+    liftM DLHandle $ throwDLErrorIf "dlopen" (== nullPtr) $ c_dlopen p (packRTLDFlags flags)
+
+withDL :: RawFilePath -> [RTLDFlags] -> (DL -> IO a) -> IO a
+withDL file flags f = bracket (dlopen file flags) (dlclose) f
+
+withDL_ :: RawFilePath -> [RTLDFlags] -> (DL -> IO a) -> IO ()
+withDL_ file flags f = withDL file flags f >> return ()

unix/System/Posix/DynamicLinker/Common.hsc

@@ -0,0 +1,92 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.DynamicLinker.Common
+-- Copyright   :  (c) Volker Stolz <vs@foldr.org> 2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  vs@foldr.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- Dynamic linker support through dlopen()
+-----------------------------------------------------------------------------
+
+module System.Posix.DynamicLinker.Common (
+
+    module System.Posix.DynamicLinker.Prim,
+    dlsym,
+    dlerror,
+    dlclose,
+    undl,
+    throwDLErrorIf,
+    Module(..)
+    )
+
+--  Usage:
+--  ******
+--
+--  Let's assume you want to open a local shared library \'foo\' (.\/libfoo.so)
+--  offering a function
+--    @char \* mogrify (char\*,int)@
+--  and invoke @str = mogrify("test",1)@:
+--
+--
+--  type Fun = CString -> Int -> IO CString
+--  foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun
+--
+--  withDL "libfoo.so" [RTLD_NOW] \$ \\ mod -> do
+--     funptr <- dlsym mod "mogrify"
+--     let fun = fun__ funptr
+--     withCString "test" \$ \\ str -> do
+--       strptr <- fun str 1
+--       strstr <- peekCString strptr
+--       ...
+--
+
+where
+
+#include "HsUnix.h"
+
+import System.Posix.DynamicLinker.Prim
+import Foreign
+import Foreign.C
+
+dlclose :: DL -> IO ()
+dlclose (DLHandle h) = throwDLErrorIf_ "dlclose" (/= 0) $ c_dlclose h
+dlclose h = error $ "dlclose: invalid argument" ++ (show h)
+
+dlerror :: IO String
+dlerror = c_dlerror >>= peekCString
+
+-- |'dlsym' returns the address binding of the symbol described in @symbol@,
+-- as it occurs in the shared object identified by @source@.
+
+dlsym :: DL -> String -> IO (FunPtr a)
+dlsym source symbol = do
+  withCAString symbol $ \ s -> do
+    throwDLErrorIf "dlsym" (== nullFunPtr) $ c_dlsym (packDL source) s
+
+-- |'undl' obtains the raw handle. You mustn't do something like
+-- @withDL mod flags $ liftM undl >>= \ p -> use p@
+
+undl :: DL -> Ptr ()
+undl = packDL
+
+throwDLErrorIf :: String -> (a -> Bool) -> IO a -> IO a
+throwDLErrorIf s p f = do
+  r <- f
+  if (p r)
+    then dlerror >>= \ err -> ioError (userError ( s ++ ": " ++ err))
+    else return r
+
+throwDLErrorIf_ :: String -> (a -> Bool) -> IO a -> IO ()
+throwDLErrorIf_ s p f = throwDLErrorIf s p f >> return ()
+
+-- abstract handle for dynamically loaded module (EXPORTED)
+--
+newtype Module = Module (Ptr ())

unix/System/Posix/DynamicLinker/Module.hsc

@@ -0,0 +1,121 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.DynamicLinker.Module
+-- Copyright   :  (c) Volker Stolz <vs@foldr.org> 2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  vs@foldr.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- DLOpen support, old API
+--  Derived from GModule.chs by M.Weber & M.Chakravarty which is part of c2hs
+--  I left the API more or less the same, mostly the flags are different.
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.DynamicLinker.Module (
+
+--  Usage:
+--  ******
+--
+--  Let's assume you want to open a local shared library 'foo' (./libfoo.so)
+--  offering a function
+--    char * mogrify (char*,int)
+--  and invoke str = mogrify("test",1):
+--
+--  type Fun = CString -> Int -> IO CString
+--  foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun
+--
+--  withModule (Just ".") ("libfoo.so") [RTLD_NOW] $ \ mod -> do
+--     funptr <- moduleSymbol mod "mogrify"
+--     let fun = fun__ funptr
+--     withCString "test" $ \ str -> do
+--       strptr <- fun str 1
+--       strstr <- peekCString strptr
+--       ...
+
+      Module
+    , moduleOpen             -- :: String -> ModuleFlags -> IO Module
+    , moduleSymbol           -- :: Source -> String -> IO (FunPtr a)
+    , moduleClose            -- :: Module -> IO Bool
+    , moduleError            -- :: IO String
+    , withModule             -- :: Maybe String
+                             -- -> String
+                             -- -> [ModuleFlags ]
+                             -- -> (Module -> IO a)
+                             -- -> IO a
+    , withModule_            -- :: Maybe String
+                             -- -> String
+                             -- -> [ModuleFlags]
+                             -- -> (Module -> IO a)
+                             -- -> IO ()
+    )
+where
+
+#include "HsUnix.h"
+
+import System.Posix.DynamicLinker
+import System.Posix.DynamicLinker.Common
+import Foreign.Ptr      ( Ptr, nullPtr, FunPtr )
+import System.Posix.Internals ( withFilePath )
+
+unModule              :: Module -> (Ptr ())
+unModule (Module adr)  = adr
+
+-- Opens a module (EXPORTED)
+--
+
+moduleOpen :: String -> [RTLDFlags] -> IO Module
+moduleOpen file flags = do
+  modPtr <- withFilePath file $ \ modAddr -> c_dlopen modAddr (packRTLDFlags flags)
+  if (modPtr == nullPtr)
+      then moduleError >>= \ err -> ioError (userError ("dlopen: " ++ err))
+      else return $ Module modPtr
+
+-- Gets a symbol pointer from a module (EXPORTED)
+--
+moduleSymbol :: Module -> String -> IO (FunPtr a)
+moduleSymbol file sym = dlsym (DLHandle (unModule file)) sym
+
+-- Closes a module (EXPORTED)
+--
+moduleClose     :: Module -> IO ()
+moduleClose file  = dlclose (DLHandle (unModule file))
+
+-- Gets a string describing the last module error (EXPORTED)
+--
+moduleError :: IO String
+moduleError  = dlerror
+
+
+-- Convenience function, cares for module open- & closing
+-- additionally returns status of `moduleClose' (EXPORTED)
+--
+withModule :: Maybe String
+           -> String
+           -> [RTLDFlags]
+           -> (Module -> IO a)
+           -> IO a
+withModule mdir file flags p = do
+  let modPath = case mdir of
+                  Nothing -> file
+                  Just dir  -> dir ++ if ((head (reverse dir)) == '/')
+                                       then file
+                                       else ('/':file)
+  modu <- moduleOpen modPath flags
+  result <- p modu
+  moduleClose modu
+  return result
+
+withModule_ :: Maybe String
+            -> String
+            -> [RTLDFlags]
+            -> (Module -> IO a)
+            -> IO ()
+withModule_ dir file flags p = withModule dir file flags p >>= \ _ -> return ()

unix/System/Posix/DynamicLinker/Module/ByteString.hsc

@@ -0,0 +1,79 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.DynamicLinker.Module.ByteString
+-- Copyright   :  (c) Volker Stolz <vs@foldr.org> 2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  vs@foldr.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- DLOpen support, old API
+--  Derived from GModule.chs by M.Weber & M.Chakravarty which is part of c2hs
+--  I left the API more or less the same, mostly the flags are different.
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.DynamicLinker.Module.ByteString (
+
+--  Usage:
+--  ******
+--
+--  Let's assume you want to open a local shared library 'foo' (./libfoo.so)
+--  offering a function
+--    char * mogrify (char*,int)
+--  and invoke str = mogrify("test",1):
+--
+--  type Fun = CString -> Int -> IO CString
+--  foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun
+--
+--  withModule (Just ".") ("libfoo.so") [RTLD_NOW] $ \ mod -> do
+--     funptr <- moduleSymbol mod "mogrify"
+--     let fun = fun__ funptr
+--     withCString "test" $ \ str -> do
+--       strptr <- fun str 1
+--       strstr <- peekCString strptr
+--       ...
+
+      Module
+    , moduleOpen             -- :: String -> ModuleFlags -> IO Module
+    , moduleSymbol           -- :: Source -> String -> IO (FunPtr a)
+    , moduleClose            -- :: Module -> IO Bool
+    , moduleError            -- :: IO String
+    , withModule             -- :: Maybe String
+                             -- -> String
+                             -- -> [ModuleFlags ]
+                             -- -> (Module -> IO a)
+                             -- -> IO a
+    , withModule_            -- :: Maybe String
+                             -- -> String
+                             -- -> [ModuleFlags]
+                             -- -> (Module -> IO a)
+                             -- -> IO ()
+    )
+where
+
+#include "HsUnix.h"
+
+import System.Posix.DynamicLinker.Module hiding (moduleOpen)
+import System.Posix.DynamicLinker.Prim
+import System.Posix.DynamicLinker.Common
+
+import Foreign
+import System.Posix.ByteString.FilePath
+
+-- Opens a module (EXPORTED)
+--
+
+moduleOpen :: RawFilePath -> [RTLDFlags] -> IO Module
+moduleOpen file flags = do
+  modPtr <- withFilePath file $ \ modAddr -> c_dlopen modAddr (packRTLDFlags flags)
+  if (modPtr == nullPtr)
+      then moduleError >>= \ err -> ioError (userError ("dlopen: " ++ err))
+      else return $ Module modPtr

unix/System/Posix/DynamicLinker/Prim.hsc

@@ -0,0 +1,123 @@
+{-# LANGUAGE Trustworthy #-}
+#if __GLASGOW_HASKELL__ >= 709
+{-# OPTIONS_GHC -fno-warn-trustworthy-safe #-}
+#endif
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.DynamicLinker.Prim
+-- Copyright   :  (c) Volker Stolz <vs@foldr.org> 2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  vs@foldr.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- @dlopen(3)@ and friends
+--  Derived from @GModule.chs@ by M.Weber & M.Chakravarty which is part of c2hs.
+--  I left the API more or less the same, mostly the flags are different.
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.DynamicLinker.Prim (
+  -- * low level API
+  c_dlopen,
+  c_dlsym,
+  c_dlerror,
+  c_dlclose,
+  -- dlAddr, -- XXX NYI
+  haveRtldNext,
+  haveRtldLocal,
+  packRTLDFlags,
+  RTLDFlags(..),
+  packDL,
+  DL(..),
+ )
+
+where
+
+#include "HsUnix.h"
+
+import Data.Bits        ( (.|.) )
+import Foreign.Ptr      ( Ptr, FunPtr, nullPtr )
+import Foreign.C.Types
+import Foreign.C.String ( CString )
+
+
+-- |On some hosts (e.g. SuSe and Ubuntu Linux) @RTLD_NEXT@ (and
+-- @RTLD_DEFAULT@) are not visible without setting the macro
+-- @_GNU_SOURCE@. Since we don\'t want to define this macro, you can use
+-- the function 'haveRtldNext' to check wether the flag `Next` is
+-- available. Ideally, this will be optimized by the compiler so that it
+-- should be as efficient as an @#ifdef@.
+--
+-- If you fail to test the flag and use it although it is undefined,
+-- 'packDL' will throw an error.
+
+haveRtldNext :: Bool
+
+#ifdef HAVE_RTLDNEXT
+haveRtldNext = True
+foreign import ccall unsafe "__hsunix_rtldNext" rtldNext :: Ptr a
+#else  /* HAVE_RTLDNEXT */
+haveRtldNext = False
+#endif /* HAVE_RTLDNEXT */
+
+#ifdef HAVE_RTLDDEFAULT
+foreign import ccall unsafe "__hsunix_rtldDefault" rtldDefault :: Ptr a
+#endif /* HAVE_RTLDDEFAULT */
+
+haveRtldLocal :: Bool
+haveRtldLocal = True
+{-# DEPRECATED haveRtldLocal "defaults to True" #-}
+
+
+-- |Flags for 'System.Posix.DynamicLinker.dlopen'.
+
+data RTLDFlags
+  = RTLD_LAZY
+  | RTLD_NOW
+  | RTLD_GLOBAL
+  | RTLD_LOCAL
+    deriving (Show, Read)
+
+foreign import ccall unsafe "dlopen" c_dlopen :: CString -> CInt -> IO (Ptr ())
+foreign import ccall unsafe "dlsym"  c_dlsym  :: Ptr () -> CString -> IO (FunPtr a)
+foreign import ccall unsafe "dlerror" c_dlerror :: IO CString
+foreign import ccall unsafe "dlclose" c_dlclose :: (Ptr ()) -> IO CInt
+
+packRTLDFlags :: [RTLDFlags] -> CInt
+packRTLDFlags flags = foldl (\ s f -> (packRTLDFlag f) .|. s) 0 flags
+
+packRTLDFlag :: RTLDFlags -> CInt
+packRTLDFlag RTLD_LAZY = #const RTLD_LAZY
+packRTLDFlag RTLD_NOW = #const RTLD_NOW
+packRTLDFlag RTLD_GLOBAL = #const RTLD_GLOBAL
+packRTLDFlag RTLD_LOCAL = #const RTLD_LOCAL
+
+
+-- |Flags for 'System.Posix.DynamicLinker.dlsym'. Notice that 'Next'
+-- might not be available on your particular platform! Use
+-- 'haveRtldNext'.
+--
+-- If 'RTLD_DEFAULT' is not defined on your platform, 'packDL' 'Default'
+-- reduces to 'nullPtr'.
+
+data DL = Null | Next | Default | DLHandle (Ptr ()) deriving (Show)
+
+packDL :: DL -> Ptr ()
+packDL Null = nullPtr
+
+#ifdef HAVE_RTLDNEXT
+packDL Next = rtldNext
+#else
+packDL Next = error "RTLD_NEXT not available"
+#endif
+
+#ifdef HAVE_RTLDDEFAULT
+packDL Default = rtldDefault
+#else
+packDL Default = nullPtr
+#endif
+
+packDL (DLHandle h) = h

unix/System/Posix/Env.hsc

@@ -0,0 +1,205 @@
+{-# LANGUAGE CApiFFI #-}
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Env
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX environment support
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Env (
+      getEnv
+    , getEnvDefault
+    , getEnvironmentPrim
+    , getEnvironment
+    , setEnvironment
+    , putEnv
+    , setEnv
+    , unsetEnv
+    , clearEnv
+) where
+
+#include "HsUnix.h"
+
+import Foreign.C.Error (throwErrnoIfMinus1_)
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.Marshal.Array
+import Foreign.Ptr
+import Foreign.Storable
+import Control.Monad
+import Data.Maybe (fromMaybe)
+import System.Posix.Internals
+
+#if !MIN_VERSION_base(4,7,0)
+-- needed for backported local 'newFilePath' binding in 'putEnv'
+import GHC.IO.Encoding (getFileSystemEncoding)
+import qualified GHC.Foreign as GHC (newCString)
+#endif
+
+-- |'getEnv' looks up a variable in the environment.
+
+getEnv ::
+  String            {- ^ variable name  -} ->
+  IO (Maybe String) {- ^ variable value -}
+getEnv name = do
+  litstring <- withFilePath name c_getenv
+  if litstring /= nullPtr
+     then liftM Just $ peekFilePath litstring
+     else return Nothing
+
+-- |'getEnvDefault' is a wrapper around 'getEnv' where the
+-- programmer can specify a fallback if the variable is not found
+-- in the environment.
+
+getEnvDefault ::
+  String    {- ^ variable name                    -} ->
+  String    {- ^ fallback value                   -} ->
+  IO String {- ^ variable value or fallback value -}
+getEnvDefault name fallback = liftM (fromMaybe fallback) (getEnv name)
+
+foreign import ccall unsafe "getenv"
+   c_getenv :: CString -> IO CString
+
+getEnvironmentPrim :: IO [String]
+getEnvironmentPrim = do
+  c_environ <- getCEnviron
+  -- environ can be NULL
+  if c_environ == nullPtr
+    then return []
+    else do
+      arr <- peekArray0 nullPtr c_environ
+      mapM peekFilePath arr
+
+getCEnviron :: IO (Ptr CString)
+#if HAVE__NSGETENVIRON
+-- You should not access @char **environ@ directly on Darwin in a bundle/shared library.
+-- See #2458 and http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html
+getCEnviron = nsGetEnviron >>= peek
+
+foreign import ccall unsafe "_NSGetEnviron"
+   nsGetEnviron :: IO (Ptr (Ptr CString))
+#else
+getCEnviron = peek c_environ_p
+foreign import ccall unsafe "&environ"
+   c_environ_p :: Ptr (Ptr CString)
+#endif
+
+-- |'getEnvironment' retrieves the entire environment as a
+-- list of @(key,value)@ pairs.
+
+getEnvironment :: IO [(String,String)] {- ^ @[(key,value)]@ -}
+getEnvironment = do
+  env <- getEnvironmentPrim
+  return $ map (dropEq.(break ((==) '='))) env
+ where
+   dropEq (x,'=':ys) = (x,ys)
+   dropEq (x,_)      = error $ "getEnvironment: insane variable " ++ x
+
+-- |'setEnvironment' resets the entire environment to the given list of
+-- @(key,value)@ pairs.
+
+setEnvironment ::
+  [(String,String)] {- ^ @[(key,value)]@ -} ->
+  IO ()
+setEnvironment env = do
+  clearEnv
+  forM_ env $ \(key,value) ->
+    setEnv key value True {-overwrite-}
+
+-- |The 'unsetEnv' function deletes all instances of the variable name
+-- from the environment.
+
+unsetEnv :: String {- ^ variable name -} -> IO ()
+#if HAVE_UNSETENV
+# if !UNSETENV_RETURNS_VOID
+unsetEnv name = withFilePath name $ \ s ->
+  throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s)
+
+-- POSIX.1-2001 compliant unsetenv(3)
+foreign import capi unsafe "HsUnix.h unsetenv"
+   c_unsetenv :: CString -> IO CInt
+# else
+unsetEnv name = withFilePath name c_unsetenv
+
+-- pre-POSIX unsetenv(3) returning @void@
+foreign import capi unsafe "HsUnix.h unsetenv"
+   c_unsetenv :: CString -> IO ()
+# endif
+#else
+unsetEnv name = putEnv (name ++ "=")
+#endif
+
+-- |'putEnv' function takes an argument of the form @name=value@
+-- and is equivalent to @setEnv(key,value,True{-overwrite-})@.
+
+putEnv :: String {- ^ "key=value" -} -> IO ()
+putEnv keyvalue = do s <- newFilePath keyvalue
+                     -- Do not free `s` after calling putenv.
+                     -- According to SUSv2, the string passed to putenv
+                     -- becomes part of the environment. #7342
+                     throwErrnoIfMinus1_ "putenv" (c_putenv s)
+#if !MIN_VERSION_base(4,7,0)
+    where
+      newFilePath :: FilePath -> IO CString
+      newFilePath fp = getFileSystemEncoding >>= \enc -> GHC.newCString enc fp
+#endif
+
+foreign import ccall unsafe "putenv"
+   c_putenv :: CString -> IO CInt
+
+{- |The 'setEnv' function inserts or resets the environment variable name in
+     the current environment list.  If the variable @name@ does not exist in the
+     list, it is inserted with the given value.  If the variable does exist,
+     the argument @overwrite@ is tested; if @overwrite@ is @False@, the variable is
+     not reset, otherwise it is reset to the given value.
+-}
+
+setEnv ::
+  String {- ^ variable name  -} ->
+  String {- ^ variable value -} ->
+  Bool   {- ^ overwrite      -} ->
+  IO ()
+#ifdef HAVE_SETENV
+setEnv key value ovrwrt = do
+  withFilePath key $ \ keyP ->
+    withFilePath value $ \ valueP ->
+      throwErrnoIfMinus1_ "setenv" $
+        c_setenv keyP valueP (fromIntegral (fromEnum ovrwrt))
+
+foreign import ccall unsafe "setenv"
+   c_setenv :: CString -> CString -> CInt -> IO CInt
+#else
+setEnv key value True = putEnv (key++"="++value)
+setEnv key value False = do
+  res <- getEnv key
+  case res of
+    Just _  -> return ()
+    Nothing -> putEnv (key++"="++value)
+#endif
+
+-- |The 'clearEnv' function clears the environment of all name-value pairs.
+clearEnv :: IO ()
+#if HAVE_CLEARENV
+clearEnv = void c_clearenv
+
+foreign import ccall unsafe "clearenv"
+  c_clearenv :: IO Int
+#else
+-- Fallback to 'environ[0] = NULL'.
+clearEnv = do
+  c_environ <- getCEnviron
+  unless (c_environ == nullPtr) $
+    poke c_environ nullPtr
+#endif

unix/System/Posix/Env/ByteString.hsc

@@ -0,0 +1,184 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE Trustworthy #-}
+#if __GLASGOW_HASKELL__ >= 709
+{-# OPTIONS_GHC -fno-warn-trustworthy-safe #-}
+#endif
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Env.ByteString
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX environment support
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Env.ByteString (
+       -- * Environment Variables
+        getEnv
+        , getEnvDefault
+        , getEnvironmentPrim
+        , getEnvironment
+        , putEnv
+        , setEnv
+       , unsetEnv
+
+       -- * Program arguments
+       , getArgs
+) where
+
+#include "HsUnix.h"
+
+import Foreign
+import Foreign.C
+import Control.Monad    ( liftM )
+import Data.Maybe       ( fromMaybe )
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+import Data.ByteString (ByteString)
+
+-- |'getEnv' looks up a variable in the environment.
+
+getEnv ::
+  ByteString            {- ^ variable name  -} ->
+  IO (Maybe ByteString) {- ^ variable value -}
+getEnv name = do
+  litstring <- B.useAsCString name c_getenv
+  if litstring /= nullPtr
+     then liftM Just $ B.packCString litstring
+     else return Nothing
+
+-- |'getEnvDefault' is a wrapper around 'getEnv' where the
+-- programmer can specify a fallback if the variable is not found
+-- in the environment.
+
+getEnvDefault ::
+  ByteString    {- ^ variable name                    -} ->
+  ByteString    {- ^ fallback value                   -} ->
+  IO ByteString {- ^ variable value or fallback value -}
+getEnvDefault name fallback = liftM (fromMaybe fallback) (getEnv name)
+
+foreign import ccall unsafe "getenv"
+   c_getenv :: CString -> IO CString
+
+getEnvironmentPrim :: IO [ByteString]
+getEnvironmentPrim = do
+  c_environ <- getCEnviron
+  arr <- peekArray0 nullPtr c_environ
+  mapM B.packCString arr
+
+getCEnviron :: IO (Ptr CString)
+#if HAVE__NSGETENVIRON
+-- You should not access @char **environ@ directly on Darwin in a bundle/shared library.
+-- See #2458 and http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html
+getCEnviron = nsGetEnviron >>= peek
+
+foreign import ccall unsafe "_NSGetEnviron"
+   nsGetEnviron :: IO (Ptr (Ptr CString))
+#else
+getCEnviron = peek c_environ_p
+
+foreign import ccall unsafe "&environ"
+   c_environ_p :: Ptr (Ptr CString)
+#endif
+
+-- |'getEnvironment' retrieves the entire environment as a
+-- list of @(key,value)@ pairs.
+
+getEnvironment :: IO [(ByteString,ByteString)] {- ^ @[(key,value)]@ -}
+getEnvironment = do
+  env <- getEnvironmentPrim
+  return $ map (dropEq.(BC.break ((==) '='))) env
+ where
+   dropEq (x,y)
+      | BC.head y == '=' = (x,B.tail y)
+      | otherwise       = error $ "getEnvironment: insane variable " ++ BC.unpack x
+
+-- |The 'unsetEnv' function deletes all instances of the variable name
+-- from the environment.
+
+unsetEnv :: ByteString {- ^ variable name -} -> IO ()
+#if HAVE_UNSETENV
+# if !UNSETENV_RETURNS_VOID
+unsetEnv name = B.useAsCString name $ \ s ->
+  throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s)
+
+-- POSIX.1-2001 compliant unsetenv(3)
+foreign import capi unsafe "HsUnix.h unsetenv"
+   c_unsetenv :: CString -> IO CInt
+# else
+unsetEnv name = B.useAsCString name c_unsetenv
+
+-- pre-POSIX unsetenv(3) returning @void@
+foreign import capi unsafe "HsUnix.h unsetenv"
+   c_unsetenv :: CString -> IO ()
+# endif
+#else
+unsetEnv name = putEnv (name ++ "=")
+#endif
+
+-- |'putEnv' function takes an argument of the form @name=value@
+-- and is equivalent to @setEnv(key,value,True{-overwrite-})@.
+
+putEnv :: ByteString {- ^ "key=value" -} -> IO ()
+putEnv keyvalue = B.useAsCString keyvalue $ \s ->
+  throwErrnoIfMinus1_ "putenv" (c_putenv s)
+
+foreign import ccall unsafe "putenv"
+   c_putenv :: CString -> IO CInt
+
+{- |The 'setEnv' function inserts or resets the environment variable name in
+     the current environment list.  If the variable @name@ does not exist in the
+     list, it is inserted with the given value.  If the variable does exist,
+     the argument @overwrite@ is tested; if @overwrite@ is @False@, the variable is
+     not reset, otherwise it is reset to the given value.
+-}
+
+setEnv ::
+  ByteString {- ^ variable name  -} ->
+  ByteString {- ^ variable value -} ->
+  Bool       {- ^ overwrite      -} ->
+  IO ()
+#ifdef HAVE_SETENV
+setEnv key value ovrwrt = do
+  B.useAsCString key $ \ keyP ->
+    B.useAsCString value $ \ valueP ->
+      throwErrnoIfMinus1_ "setenv" $
+        c_setenv keyP valueP (fromIntegral (fromEnum ovrwrt))
+
+foreign import ccall unsafe "setenv"
+   c_setenv :: CString -> CString -> CInt -> IO CInt
+#else
+setEnv key value True = putEnv (key++"="++value)
+setEnv key value False = do
+  res <- getEnv key
+  case res of
+    Just _  -> return ()
+    Nothing -> putEnv (key++"="++value)
+#endif
+
+-- | Computation 'getArgs' returns a list of the program's command
+-- line arguments (not including the program name), as 'ByteString's.
+--
+-- Unlike 'System.Environment.getArgs', this function does no Unicode
+-- decoding of the arguments; you get the exact bytes that were passed
+-- to the program by the OS.  To interpret the arguments as text, some
+-- Unicode decoding should be applied.
+--
+getArgs :: IO [ByteString]
+getArgs =
+  alloca $ \ p_argc ->
+  alloca $ \ p_argv -> do
+   getProgArgv p_argc p_argv
+   p    <- fromIntegral `liftM` peek p_argc
+   argv <- peek p_argv
+   peekArray (p - 1) (advancePtr argv 1) >>= mapM B.packCString
+
+foreign import ccall unsafe "getProgArgv"
+  getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()

unix/System/Posix/Error.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Error
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX error support
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Error (
+        throwErrnoPath,
+        throwErrnoPathIf,
+        throwErrnoPathIf_,
+        throwErrnoPathIfRetry,
+        throwErrnoPathIfNull,
+        throwErrnoPathIfNullRetry,
+        throwErrnoPathIfMinus1,
+        throwErrnoPathIfMinus1_,
+        throwErrnoPathIfMinus1Retry,
+        throwErrnoPathIfMinus1Retry_
+  ) where
+
+import Foreign hiding (void)
+import Foreign.C
+import Control.Monad
+
+throwErrnoPathIfMinus1Retry :: (Eq a, Num a)
+                            => String -> FilePath -> IO a -> IO a
+throwErrnoPathIfMinus1Retry loc path f =
+  throwErrnoPathIfRetry (== -1) loc path f
+
+throwErrnoPathIfMinus1Retry_ :: (Eq a, Num a)
+                             => String -> FilePath -> IO a -> IO ()
+throwErrnoPathIfMinus1Retry_ loc path f =
+  void $ throwErrnoPathIfRetry (== -1) loc path f
+
+throwErrnoPathIfNullRetry :: String -> FilePath -> IO (Ptr a) -> IO (Ptr a)
+throwErrnoPathIfNullRetry loc path f =
+  throwErrnoPathIfRetry (== nullPtr) loc path f
+
+throwErrnoPathIfRetry :: (a -> Bool) -> String -> FilePath -> IO a -> IO a
+throwErrnoPathIfRetry pr loc path f =
+  do
+    res <- f
+    if pr res
+      then do
+        err <- getErrno
+        if err == eINTR
+          then throwErrnoPathIfRetry pr loc path f
+          else throwErrnoPath loc path
+      else return res
+

unix/System/Posix/Fcntl.hsc

@@ -0,0 +1,104 @@
+{-# LANGUAGE CApiFFI #-}
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Fcntl
+-- Copyright   :  (c) The University of Glasgow 2014
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX file control support
+--
+-- @since 2.7.1.0
+-----------------------------------------------------------------------------
+
+#include "HsUnix.h"
+
+module System.Posix.Fcntl (
+    -- * File allocation
+    Advice(..), fileAdvise,
+    fileAllocate,
+  ) where
+
+#if HAVE_POSIX_FALLOCATE || HAVE_POSIX_FADVISE
+import Foreign.C
+#endif
+import System.Posix.Types
+
+#if !HAVE_POSIX_FALLOCATE
+import System.IO.Error ( ioeSetLocation )
+import GHC.IO.Exception ( unsupportedOperation )
+#endif
+
+-- -----------------------------------------------------------------------------
+-- File control
+
+-- | Advice parameter for 'fileAdvise' operation.
+--
+-- For more details, see documentation of @posix_fadvise(2)@.
+--
+-- @since 2.7.1.0
+data Advice
+  = AdviceNormal
+  | AdviceRandom
+  | AdviceSequential
+  | AdviceWillNeed
+  | AdviceDontNeed
+  | AdviceNoReuse
+  deriving Eq
+
+-- | Performs @posix_fadvise(2)@ operation on file-descriptor.
+--
+-- If platform does not provide @posix_fadvise(2)@ 'fileAdvise'
+-- becomes a no-op.
+--
+-- (use @#if HAVE_POSIX_FADVISE@ CPP guard to detect availability)
+--
+-- @since 2.7.1.0
+fileAdvise :: Fd -> FileOffset -> FileOffset -> Advice -> IO ()
+#if HAVE_POSIX_FADVISE
+fileAdvise fd off len adv = do
+  throwErrnoIfMinus1_ "fileAdvise" (c_posix_fadvise (fromIntegral fd) (fromIntegral off) (fromIntegral len) (packAdvice adv))
+
+foreign import capi safe "fcntl.h posix_fadvise"
+  c_posix_fadvise :: CInt -> COff -> COff -> CInt -> IO CInt
+
+packAdvice :: Advice -> CInt
+packAdvice AdviceNormal     = (#const POSIX_FADV_NORMAL)
+packAdvice AdviceRandom     = (#const POSIX_FADV_RANDOM)
+packAdvice AdviceSequential = (#const POSIX_FADV_SEQUENTIAL)
+packAdvice AdviceWillNeed   = (#const POSIX_FADV_WILLNEED)
+packAdvice AdviceDontNeed   = (#const POSIX_FADV_DONTNEED)
+packAdvice AdviceNoReuse    = (#const POSIX_FADV_NOREUSE)
+#else
+fileAdvise _ _ _ _ = return ()
+#endif
+
+-- | Performs @posix_fallocate(2)@ operation on file-descriptor.
+--
+-- Throws 'IOError' (\"unsupported operation\") if platform does not
+-- provide @posix_fallocate(2)@.
+--
+-- (use @#if HAVE_POSIX_FALLOCATE@ CPP guard to detect availability).
+--
+-- @since 2.7.1.0
+fileAllocate :: Fd -> FileOffset -> FileOffset -> IO ()
+#if HAVE_POSIX_FALLOCATE
+fileAllocate fd off len = do
+  throwErrnoIfMinus1_ "fileAllocate" (c_posix_fallocate (fromIntegral fd) (fromIntegral off) (fromIntegral len))
+
+foreign import capi safe "fcntl.h posix_fallocate"
+  c_posix_fallocate :: CInt -> COff -> COff -> IO CInt
+#else
+{-# WARNING fileAllocate
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_POSIX_FALLOCATE@)" #-}
+fileAllocate _ _ _ = ioError (ioeSetLocation unsupportedOperation
+                              "fileAllocate")
+#endif

unix/System/Posix/Files.hsc

@@ -0,0 +1,448 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+{-# LANGUAGE CApiFFI #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Files
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- Functions defined by the POSIX standards for manipulating and querying the
+-- file system. Names of underlying POSIX functions are indicated whenever
+-- possible. A more complete documentation of the POSIX functions together
+-- with a more detailed description of different error conditions are usually
+-- available in the system's manual pages or from
+-- <http://www.unix.org/version3/online.html> (free registration required).
+--
+-- When a function that calls an underlying POSIX function fails, the errno
+-- code is converted to an 'IOError' using 'Foreign.C.Error.errnoToIOError'.
+-- For a list of which errno codes may be generated, consult the POSIX
+-- documentation for the underlying function.
+--
+-----------------------------------------------------------------------------
+
+#include "HsUnix.h"
+
+module System.Posix.Files (
+    -- * File modes
+    -- FileMode exported by System.Posix.Types
+    unionFileModes, intersectFileModes,
+    nullFileMode,
+    ownerReadMode, ownerWriteMode, ownerExecuteMode, ownerModes,
+    groupReadMode, groupWriteMode, groupExecuteMode, groupModes,
+    otherReadMode, otherWriteMode, otherExecuteMode, otherModes,
+    setUserIDMode, setGroupIDMode,
+    stdFileMode,   accessModes,
+    fileTypeModes,
+    blockSpecialMode, characterSpecialMode, namedPipeMode, regularFileMode,
+    directoryMode, symbolicLinkMode, socketMode,
+
+    -- ** Setting file modes
+    setFileMode, setFdMode, setFileCreationMask,
+
+    -- ** Checking file existence and permissions
+    fileAccess, fileExist,
+
+    -- * File status
+    FileStatus,
+    -- ** Obtaining file status
+    getFileStatus, getFdStatus, getSymbolicLinkStatus,
+    -- ** Querying file status
+    deviceID, fileID, fileMode, linkCount, fileOwner, fileGroup,
+    specialDeviceID, fileSize, accessTime, modificationTime,
+    statusChangeTime,
+    accessTimeHiRes, modificationTimeHiRes, statusChangeTimeHiRes,
+    isBlockDevice, isCharacterDevice, isNamedPipe, isRegularFile,
+    isDirectory, isSymbolicLink, isSocket,
+
+    -- * Creation
+    createNamedPipe,
+    createDevice,
+
+    -- * Hard links
+    createLink, removeLink,
+
+    -- * Symbolic links
+    createSymbolicLink, readSymbolicLink,
+
+    -- * Renaming files
+    rename,
+
+    -- * Changing file ownership
+    setOwnerAndGroup,  setFdOwnerAndGroup,
+#if HAVE_LCHOWN
+    setSymbolicLinkOwnerAndGroup,
+#endif
+
+    -- * Changing file timestamps
+    setFileTimes, setFileTimesHiRes,
+    setFdTimesHiRes, setSymbolicLinkTimesHiRes,
+    touchFile, touchFd, touchSymbolicLink,
+
+    -- * Setting file sizes
+    setFileSize, setFdSize,
+
+    -- * Find system-specific limits for a file
+    PathVar(..), getPathVar, getFdPathVar,
+  ) where
+
+
+import Foreign
+import Foreign.C
+
+import System.Posix.Types
+import System.Posix.Files.Common
+import System.Posix.Error
+import System.Posix.Internals
+
+import Data.Time.Clock.POSIX (POSIXTime)
+
+-- -----------------------------------------------------------------------------
+-- chmod()
+
+-- | @setFileMode path mode@ changes permission of the file given by @path@
+-- to @mode@. This operation may fail with 'throwErrnoPathIfMinus1_' if @path@
+-- doesn't exist or if the effective user ID of the current process is not that
+-- of the file's owner.
+--
+-- Note: calls @chmod@.
+setFileMode :: FilePath -> FileMode -> IO ()
+setFileMode name m =
+  withFilePath name $ \s -> do
+    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)
+
+-- -----------------------------------------------------------------------------
+-- access()
+
+-- | @fileAccess name read write exec@ checks if the file (or other file system
+-- object) @name@ can be accessed for reading, writing and\/or executing. To
+-- check a permission set the corresponding argument to 'True'.
+--
+-- Note: calls @access@.
+fileAccess :: FilePath -> Bool -> Bool -> Bool -> IO Bool
+fileAccess name readOK writeOK execOK = access name flags
+  where
+   flags   = read_f .|. write_f .|. exec_f
+   read_f  = if readOK  then (#const R_OK) else 0
+   write_f = if writeOK then (#const W_OK) else 0
+   exec_f  = if execOK  then (#const X_OK) else 0
+
+-- | Checks for the existence of the file.
+--
+-- Note: calls @access@.
+fileExist :: FilePath -> IO Bool
+fileExist name =
+  withFilePath name $ \s -> do
+    r <- c_access s (#const F_OK)
+    if (r == 0)
+        then return True
+        else do err <- getErrno
+                if (err == eNOENT)
+                   then return False
+                   else throwErrnoPath "fileExist" name
+
+access :: FilePath -> CMode -> IO Bool
+access name flags =
+  withFilePath name $ \s -> do
+    r <- c_access s (fromIntegral flags)
+    if (r == 0)
+        then return True
+        else do err <- getErrno
+                if (err == eACCES || err == eROFS || err == eTXTBSY ||
+                    err == ePERM)
+                   then return False
+                   else throwErrnoPath "fileAccess" name
+
+
+-- | @getFileStatus path@ calls gets the @FileStatus@ information (user ID,
+-- size, access times, etc.) for the file @path@.
+--
+-- Note: calls @stat@.
+getFileStatus :: FilePath -> IO FileStatus
+getFileStatus path = do
+  fp <- mallocForeignPtrBytes (#const sizeof(struct stat))
+  withForeignPtr fp $ \p ->
+    withFilePath path $ \s ->
+      throwErrnoPathIfMinus1Retry_ "getFileStatus" path (c_stat s p)
+  return (FileStatus fp)
+
+-- | Acts as 'getFileStatus' except when the 'FilePath' refers to a symbolic
+-- link. In that case the @FileStatus@ information of the symbolic link itself
+-- is returned instead of that of the file it points to.
+--
+-- Note: calls @lstat@.
+getSymbolicLinkStatus :: FilePath -> IO FileStatus
+getSymbolicLinkStatus path = do
+  fp <- mallocForeignPtrBytes (#const sizeof(struct stat))
+  withForeignPtr fp $ \p ->
+    withFilePath path $ \s ->
+      throwErrnoPathIfMinus1_ "getSymbolicLinkStatus" path (c_lstat s p)
+  return (FileStatus fp)
+
+foreign import capi unsafe "HsUnix.h lstat"
+  c_lstat :: CString -> Ptr CStat -> IO CInt
+
+-- | @createNamedPipe fifo mode@
+-- creates a new named pipe, @fifo@, with permissions based on
+-- @mode@. May fail with 'throwErrnoPathIfMinus1_' if a file named @name@
+-- already exists or if the effective user ID of the current process doesn't
+-- have permission to create the pipe.
+--
+-- Note: calls @mkfifo@.
+createNamedPipe :: FilePath -> FileMode -> IO ()
+createNamedPipe name mode = do
+  withFilePath name $ \s ->
+    throwErrnoPathIfMinus1_ "createNamedPipe" name (c_mkfifo s mode)
+
+-- | @createDevice path mode dev@ creates either a regular or a special file
+-- depending on the value of @mode@ (and @dev@).  @mode@ will normally be either
+-- 'blockSpecialMode' or 'characterSpecialMode'.  May fail with
+-- 'throwErrnoPathIfMinus1_' if a file named @name@ already exists or if the
+-- effective user ID of the current process doesn't have permission to create
+-- the file.
+--
+-- Note: calls @mknod@.
+createDevice :: FilePath -> FileMode -> DeviceID -> IO ()
+createDevice path mode dev =
+  withFilePath path $ \s ->
+    throwErrnoPathIfMinus1_ "createDevice" path (c_mknod s mode dev)
+
+foreign import capi unsafe "HsUnix.h mknod"
+  c_mknod :: CString -> CMode -> CDev -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Hard links
+
+-- | @createLink old new@ creates a new path, @new@, linked to an existing file,
+-- @old@.
+--
+-- Note: calls @link@.
+createLink :: FilePath -> FilePath -> IO ()
+createLink name1 name2 =
+  withFilePath name1 $ \s1 ->
+  withFilePath name2 $ \s2 ->
+  throwErrnoPathIfMinus1_ "createLink" name1 (c_link s1 s2)
+
+-- | @removeLink path@ removes the link named @path@.
+--
+-- Note: calls @unlink@.
+removeLink :: FilePath -> IO ()
+removeLink name =
+  withFilePath name $ \s ->
+  throwErrnoPathIfMinus1_ "removeLink" name (c_unlink s)
+
+-- -----------------------------------------------------------------------------
+-- Symbolic Links
+
+-- | @createSymbolicLink file1 file2@ creates a symbolic link named @file2@
+-- which points to the file @file1@.
+--
+-- Symbolic links are interpreted at run-time as if the contents of the link
+-- had been substituted into the path being followed to find a file or directory.
+--
+-- Note: calls @symlink@.
+createSymbolicLink :: FilePath -> FilePath -> IO ()
+createSymbolicLink file1 file2 =
+  withFilePath file1 $ \s1 ->
+  withFilePath file2 $ \s2 ->
+  throwErrnoPathIfMinus1_ "createSymbolicLink" file2 (c_symlink s1 s2)
+
+foreign import ccall unsafe "symlink"
+  c_symlink :: CString -> CString -> IO CInt
+
+-- ToDo: should really use SYMLINK_MAX, but not everyone supports it yet,
+-- and it seems that the intention is that SYMLINK_MAX is no larger than
+-- PATH_MAX.
+#if !defined(PATH_MAX)
+-- PATH_MAX is not defined on systems with unlimited path length.
+-- Ugly.  Fix this.
+#define PATH_MAX 4096
+#endif
+
+-- | Reads the @FilePath@ pointed to by the symbolic link and returns it.
+--
+-- Note: calls @readlink@.
+readSymbolicLink :: FilePath -> IO FilePath
+readSymbolicLink file =
+  allocaArray0 (#const PATH_MAX) $ \buf -> do
+    withFilePath file $ \s -> do
+      len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $
+        c_readlink s buf (#const PATH_MAX)
+      peekFilePathLen (buf,fromIntegral len)
+
+foreign import ccall unsafe "readlink"
+  c_readlink :: CString -> CString -> CSize -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Renaming files
+
+-- | @rename old new@ renames a file or directory from @old@ to @new@.
+--
+-- Note: calls @rename@.
+rename :: FilePath -> FilePath -> IO ()
+rename name1 name2 =
+  withFilePath name1 $ \s1 ->
+  withFilePath name2 $ \s2 ->
+  throwErrnoPathIfMinus1_ "rename" name1 (c_rename s1 s2)
+
+foreign import ccall unsafe "rename"
+   c_rename :: CString -> CString -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- chown()
+
+-- | @setOwnerAndGroup path uid gid@ changes the owner and group of @path@ to
+-- @uid@ and @gid@, respectively.
+--
+-- If @uid@ or @gid@ is specified as -1, then that ID is not changed.
+--
+-- Note: calls @chown@.
+setOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO ()
+setOwnerAndGroup name uid gid = do
+  withFilePath name $ \s ->
+    throwErrnoPathIfMinus1_ "setOwnerAndGroup" name (c_chown s uid gid)
+
+foreign import ccall unsafe "chown"
+  c_chown :: CString -> CUid -> CGid -> IO CInt
+
+#if HAVE_LCHOWN
+-- | Acts as 'setOwnerAndGroup' but does not follow symlinks (and thus
+-- changes permissions on the link itself).
+--
+-- Note: calls @lchown@.
+setSymbolicLinkOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO ()
+setSymbolicLinkOwnerAndGroup name uid gid = do
+  withFilePath name $ \s ->
+    throwErrnoPathIfMinus1_ "setSymbolicLinkOwnerAndGroup" name
+        (c_lchown s uid gid)
+
+foreign import ccall unsafe "lchown"
+  c_lchown :: CString -> CUid -> CGid -> IO CInt
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Setting file times
+
+-- | @setFileTimes path atime mtime@ sets the access and modification times
+-- associated with file @path@ to @atime@ and @mtime@, respectively.
+--
+-- Note: calls @utime@.
+setFileTimes :: FilePath -> EpochTime -> EpochTime -> IO ()
+setFileTimes name atime mtime = do
+  withFilePath name $ \s ->
+   allocaBytes (#const sizeof(struct utimbuf)) $ \p -> do
+     (#poke struct utimbuf, actime)  p atime
+     (#poke struct utimbuf, modtime) p mtime
+     throwErrnoPathIfMinus1_ "setFileTimes" name (c_utime s p)
+
+-- | Like 'setFileTimes' but timestamps can have sub-second resolution.
+--
+-- Note: calls @utimensat@ or @utimes@.
+--
+-- @since 2.7.0.0
+setFileTimesHiRes :: FilePath -> POSIXTime -> POSIXTime -> IO ()
+#ifdef HAVE_UTIMENSAT
+setFileTimesHiRes name atime mtime =
+  withFilePath name $ \s ->
+    withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times ->
+      throwErrnoPathIfMinus1_ "setFileTimesHiRes" name $
+        c_utimensat (#const AT_FDCWD) s times 0
+#else
+setFileTimesHiRes name atime mtime =
+  withFilePath name $ \s ->
+    withArray [toCTimeVal atime, toCTimeVal mtime] $ \times ->
+      throwErrnoPathIfMinus1_ "setFileTimesHiRes" name (c_utimes s times)
+#endif
+
+-- | Like 'setFileTimesHiRes' but does not follow symbolic links.
+-- This operation is not supported on all platforms. On these platforms,
+-- this function will raise an exception.
+--
+-- Note: calls @utimensat@ or @lutimes@.
+--
+-- @since 2.7.0.0
+setSymbolicLinkTimesHiRes :: FilePath -> POSIXTime -> POSIXTime -> IO ()
+#if HAVE_UTIMENSAT
+setSymbolicLinkTimesHiRes name atime mtime =
+  withFilePath name $ \s ->
+    withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times ->
+      throwErrnoPathIfMinus1_ "setSymbolicLinkTimesHiRes" name $
+        c_utimensat (#const AT_FDCWD) s times (#const AT_SYMLINK_NOFOLLOW)
+#elif HAVE_LUTIMES
+setSymbolicLinkTimesHiRes name atime mtime =
+  withFilePath name $ \s ->
+    withArray [toCTimeVal atime, toCTimeVal mtime] $ \times ->
+      throwErrnoPathIfMinus1_ "setSymbolicLinkTimesHiRes" name $
+        c_lutimes s times
+#else
+setSymbolicLinkTimesHiRes =
+  error "setSymbolicLinkTimesHiRes: not available on this platform"
+#endif
+
+-- | @touchFile path@ sets the access and modification times associated with
+-- file @path@ to the current time.
+--
+-- Note: calls @utime@.
+touchFile :: FilePath -> IO ()
+touchFile name = do
+  withFilePath name $ \s ->
+   throwErrnoPathIfMinus1_ "touchFile" name (c_utime s nullPtr)
+
+-- | Like 'touchFile' but does not follow symbolic links.
+-- This operation is not supported on all platforms. On these platforms,
+-- this function will raise an exception.
+--
+-- Note: calls @lutimes@.
+--
+-- @since 2.7.0.0
+touchSymbolicLink :: FilePath -> IO ()
+#if HAVE_LUTIMES
+touchSymbolicLink name =
+  withFilePath name $ \s ->
+    throwErrnoPathIfMinus1_ "touchSymbolicLink" name (c_lutimes s nullPtr)
+#else
+touchSymbolicLink =
+  error "touchSymbolicLink: not available on this platform"
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Setting file sizes
+
+-- | Truncates the file down to the specified length. If the file was larger
+-- than the given length before this operation was performed the extra is lost.
+--
+-- Note: calls @truncate@.
+setFileSize :: FilePath -> FileOffset -> IO ()
+setFileSize file off =
+  withFilePath file $ \s ->
+    throwErrnoPathIfMinus1_ "setFileSize" file (c_truncate s off)
+
+foreign import capi unsafe "HsUnix.h truncate"
+  c_truncate :: CString -> COff -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- pathconf()/fpathconf() support
+
+-- | @getPathVar var path@ obtains the dynamic value of the requested
+-- configurable file limit or option associated with file or directory @path@.
+-- For defined file limits, @getPathVar@ returns the associated
+-- value.  For defined file options, the result of @getPathVar@
+-- is undefined, but not failure.
+--
+-- Note: calls @pathconf@.
+getPathVar :: FilePath -> PathVar -> IO Limit
+getPathVar name v = do
+  withFilePath name $ \ nameP ->
+    throwErrnoPathIfMinus1 "getPathVar" name $
+      c_pathconf nameP (pathVarConst v)
+
+foreign import ccall unsafe "pathconf"
+  c_pathconf :: CString -> CInt -> IO CLong

unix/System/Posix/Files/ByteString.hsc

@@ -0,0 +1,448 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+{-# LANGUAGE CApiFFI #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Files.ByteString
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- Functions defined by the POSIX standards for manipulating and querying the
+-- file system. Names of underlying POSIX functions are indicated whenever
+-- possible. A more complete documentation of the POSIX functions together
+-- with a more detailed description of different error conditions are usually
+-- available in the system's manual pages or from
+-- <http://www.unix.org/version3/online.html> (free registration required).
+--
+-- When a function that calls an underlying POSIX function fails, the errno
+-- code is converted to an 'IOError' using 'Foreign.C.Error.errnoToIOError'.
+-- For a list of which errno codes may be generated, consult the POSIX
+-- documentation for the underlying function.
+--
+-----------------------------------------------------------------------------
+
+#include "HsUnix.h"
+
+module System.Posix.Files.ByteString (
+    -- * File modes
+    -- FileMode exported by System.Posix.Types
+    unionFileModes, intersectFileModes,
+    nullFileMode,
+    ownerReadMode, ownerWriteMode, ownerExecuteMode, ownerModes,
+    groupReadMode, groupWriteMode, groupExecuteMode, groupModes,
+    otherReadMode, otherWriteMode, otherExecuteMode, otherModes,
+    setUserIDMode, setGroupIDMode,
+    stdFileMode,   accessModes,
+    fileTypeModes,
+    blockSpecialMode, characterSpecialMode, namedPipeMode, regularFileMode,
+    directoryMode, symbolicLinkMode, socketMode,
+
+    -- ** Setting file modes
+    setFileMode, setFdMode, setFileCreationMask,
+
+    -- ** Checking file existence and permissions
+    fileAccess, fileExist,
+
+    -- * File status
+    FileStatus,
+    -- ** Obtaining file status
+    getFileStatus, getFdStatus, getSymbolicLinkStatus,
+    -- ** Querying file status
+    deviceID, fileID, fileMode, linkCount, fileOwner, fileGroup,
+    specialDeviceID, fileSize, accessTime, modificationTime,
+    statusChangeTime,
+    accessTimeHiRes, modificationTimeHiRes, statusChangeTimeHiRes,
+    isBlockDevice, isCharacterDevice, isNamedPipe, isRegularFile,
+    isDirectory, isSymbolicLink, isSocket,
+
+    -- * Creation
+    createNamedPipe,
+    createDevice,
+
+    -- * Hard links
+    createLink, removeLink,
+
+    -- * Symbolic links
+    createSymbolicLink, readSymbolicLink,
+
+    -- * Renaming files
+    rename,
+
+    -- * Changing file ownership
+    setOwnerAndGroup,  setFdOwnerAndGroup,
+#if HAVE_LCHOWN
+    setSymbolicLinkOwnerAndGroup,
+#endif
+
+    -- * Changing file timestamps
+    setFileTimes, setFileTimesHiRes,
+    setFdTimesHiRes, setSymbolicLinkTimesHiRes,
+    touchFile, touchFd, touchSymbolicLink,
+
+    -- * Setting file sizes
+    setFileSize, setFdSize,
+
+    -- * Find system-specific limits for a file
+    PathVar(..), getPathVar, getFdPathVar,
+  ) where
+
+import System.Posix.Types
+import System.Posix.Internals hiding (withFilePath, peekFilePathLen)
+import Foreign
+import Foreign.C hiding (
+     throwErrnoPath,
+     throwErrnoPathIf,
+     throwErrnoPathIf_,
+     throwErrnoPathIfNull,
+     throwErrnoPathIfMinus1,
+     throwErrnoPathIfMinus1_ )
+
+import System.Posix.Files.Common
+import System.Posix.ByteString.FilePath
+
+import Data.Time.Clock.POSIX (POSIXTime)
+
+-- -----------------------------------------------------------------------------
+-- chmod()
+
+-- | @setFileMode path mode@ changes permission of the file given by @path@
+-- to @mode@. This operation may fail with 'throwErrnoPathIfMinus1_' if @path@
+-- doesn't exist or if the effective user ID of the current process is not that
+-- of the file's owner.
+--
+-- Note: calls @chmod@.
+setFileMode :: RawFilePath -> FileMode -> IO ()
+setFileMode name m =
+  withFilePath name $ \s -> do
+    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)
+
+
+-- -----------------------------------------------------------------------------
+-- access()
+
+-- | @fileAccess name read write exec@ checks if the file (or other file system
+-- object) @name@ can be accessed for reading, writing and\/or executing. To
+-- check a permission set the corresponding argument to 'True'.
+--
+-- Note: calls @access@.
+fileAccess :: RawFilePath -> Bool -> Bool -> Bool -> IO Bool
+fileAccess name readOK writeOK execOK = access name flags
+  where
+   flags   = read_f .|. write_f .|. exec_f
+   read_f  = if readOK  then (#const R_OK) else 0
+   write_f = if writeOK then (#const W_OK) else 0
+   exec_f  = if execOK  then (#const X_OK) else 0
+
+-- | Checks for the existence of the file.
+--
+-- Note: calls @access@.
+fileExist :: RawFilePath -> IO Bool
+fileExist name =
+  withFilePath name $ \s -> do
+    r <- c_access s (#const F_OK)
+    if (r == 0)
+        then return True
+        else do err <- getErrno
+                if (err == eNOENT)
+                   then return False
+                   else throwErrnoPath "fileExist" name
+
+access :: RawFilePath -> CMode -> IO Bool
+access name flags =
+  withFilePath name $ \s -> do
+    r <- c_access s (fromIntegral flags)
+    if (r == 0)
+        then return True
+        else do err <- getErrno
+                if (err == eACCES || err == eROFS || err == eTXTBSY ||
+                    err == ePERM)
+                   then return False
+                   else throwErrnoPath "fileAccess" name
+
+
+-- | @getFileStatus path@ calls gets the @FileStatus@ information (user ID,
+-- size, access times, etc.) for the file @path@.
+--
+-- Note: calls @stat@.
+getFileStatus :: RawFilePath -> IO FileStatus
+getFileStatus path = do
+  fp <- mallocForeignPtrBytes (#const sizeof(struct stat))
+  withForeignPtr fp $ \p ->
+    withFilePath path $ \s ->
+      throwErrnoPathIfMinus1Retry_ "getFileStatus" path (c_stat s p)
+  return (FileStatus fp)
+
+-- | Acts as 'getFileStatus' except when the 'RawFilePath' refers to a symbolic
+-- link. In that case the @FileStatus@ information of the symbolic link itself
+-- is returned instead of that of the file it points to.
+--
+-- Note: calls @lstat@.
+getSymbolicLinkStatus :: RawFilePath -> IO FileStatus
+getSymbolicLinkStatus path = do
+  fp <- mallocForeignPtrBytes (#const sizeof(struct stat))
+  withForeignPtr fp $ \p ->
+    withFilePath path $ \s ->
+      throwErrnoPathIfMinus1_ "getSymbolicLinkStatus" path (c_lstat s p)
+  return (FileStatus fp)
+
+foreign import capi unsafe "HsUnix.h lstat"
+  c_lstat :: CString -> Ptr CStat -> IO CInt
+
+-- | @createNamedPipe fifo mode@
+-- creates a new named pipe, @fifo@, with permissions based on
+-- @mode@. May fail with 'throwErrnoPathIfMinus1_' if a file named @name@
+-- already exists or if the effective user ID of the current process doesn't
+-- have permission to create the pipe.
+--
+-- Note: calls @mkfifo@.
+createNamedPipe :: RawFilePath -> FileMode -> IO ()
+createNamedPipe name mode = do
+  withFilePath name $ \s ->
+    throwErrnoPathIfMinus1_ "createNamedPipe" name (c_mkfifo s mode)
+
+-- | @createDevice path mode dev@ creates either a regular or a special file
+-- depending on the value of @mode@ (and @dev@).  @mode@ will normally be either
+-- 'blockSpecialMode' or 'characterSpecialMode'.  May fail with
+-- 'throwErrnoPathIfMinus1_' if a file named @name@ already exists or if the
+-- effective user ID of the current process doesn't have permission to create
+-- the file.
+--
+-- Note: calls @mknod@.
+createDevice :: RawFilePath -> FileMode -> DeviceID -> IO ()
+createDevice path mode dev =
+  withFilePath path $ \s ->
+    throwErrnoPathIfMinus1_ "createDevice" path (c_mknod s mode dev)
+
+foreign import capi unsafe "HsUnix.h mknod"
+  c_mknod :: CString -> CMode -> CDev -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Hard links
+
+-- | @createLink old new@ creates a new path, @new@, linked to an existing file,
+-- @old@.
+--
+-- Note: calls @link@.
+createLink :: RawFilePath -> RawFilePath -> IO ()
+createLink name1 name2 =
+  withFilePath name1 $ \s1 ->
+  withFilePath name2 $ \s2 ->
+  throwErrnoPathIfMinus1_ "createLink" name1 (c_link s1 s2)
+
+-- | @removeLink path@ removes the link named @path@.
+--
+-- Note: calls @unlink@.
+removeLink :: RawFilePath -> IO ()
+removeLink name =
+  withFilePath name $ \s ->
+  throwErrnoPathIfMinus1_ "removeLink" name (c_unlink s)
+
+-- -----------------------------------------------------------------------------
+-- Symbolic Links
+
+-- | @createSymbolicLink file1 file2@ creates a symbolic link named @file2@
+-- which points to the file @file1@.
+--
+-- Symbolic links are interpreted at run-time as if the contents of the link
+-- had been substituted into the path being followed to find a file or directory.
+--
+-- Note: calls @symlink@.
+createSymbolicLink :: RawFilePath -> RawFilePath -> IO ()
+createSymbolicLink file1 file2 =
+  withFilePath file1 $ \s1 ->
+  withFilePath file2 $ \s2 ->
+  throwErrnoPathIfMinus1_ "createSymbolicLink" file2 (c_symlink s1 s2)
+
+foreign import ccall unsafe "symlink"
+  c_symlink :: CString -> CString -> IO CInt
+
+-- ToDo: should really use SYMLINK_MAX, but not everyone supports it yet,
+-- and it seems that the intention is that SYMLINK_MAX is no larger than
+-- PATH_MAX.
+#if !defined(PATH_MAX)
+-- PATH_MAX is not defined on systems with unlimited path length.
+-- Ugly.  Fix this.
+#define PATH_MAX 4096
+#endif
+
+-- | Reads the @RawFilePath@ pointed to by the symbolic link and returns it.
+--
+-- Note: calls @readlink@.
+readSymbolicLink :: RawFilePath -> IO RawFilePath
+readSymbolicLink file =
+  allocaArray0 (#const PATH_MAX) $ \buf -> do
+    withFilePath file $ \s -> do
+      len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $
+        c_readlink s buf (#const PATH_MAX)
+      peekFilePathLen (buf,fromIntegral len)
+
+foreign import ccall unsafe "readlink"
+  c_readlink :: CString -> CString -> CSize -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Renaming files
+
+-- | @rename old new@ renames a file or directory from @old@ to @new@.
+--
+-- Note: calls @rename@.
+rename :: RawFilePath -> RawFilePath -> IO ()
+rename name1 name2 =
+  withFilePath name1 $ \s1 ->
+  withFilePath name2 $ \s2 ->
+  throwErrnoPathIfMinus1_ "rename" name1 (c_rename s1 s2)
+
+foreign import ccall unsafe "rename"
+   c_rename :: CString -> CString -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- chown()
+
+-- | @setOwnerAndGroup path uid gid@ changes the owner and group of @path@ to
+-- @uid@ and @gid@, respectively.
+--
+-- If @uid@ or @gid@ is specified as -1, then that ID is not changed.
+--
+-- Note: calls @chown@.
+setOwnerAndGroup :: RawFilePath -> UserID -> GroupID -> IO ()
+setOwnerAndGroup name uid gid = do
+  withFilePath name $ \s ->
+    throwErrnoPathIfMinus1_ "setOwnerAndGroup" name (c_chown s uid gid)
+
+foreign import ccall unsafe "chown"
+  c_chown :: CString -> CUid -> CGid -> IO CInt
+
+#if HAVE_LCHOWN
+-- | Acts as 'setOwnerAndGroup' but does not follow symlinks (and thus
+-- changes permissions on the link itself).
+--
+-- Note: calls @lchown@.
+setSymbolicLinkOwnerAndGroup :: RawFilePath -> UserID -> GroupID -> IO ()
+setSymbolicLinkOwnerAndGroup name uid gid = do
+  withFilePath name $ \s ->
+    throwErrnoPathIfMinus1_ "setSymbolicLinkOwnerAndGroup" name
+        (c_lchown s uid gid)
+
+foreign import ccall unsafe "lchown"
+  c_lchown :: CString -> CUid -> CGid -> IO CInt
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Setting file times
+
+-- | @setFileTimes path atime mtime@ sets the access and modification times
+-- associated with file @path@ to @atime@ and @mtime@, respectively.
+--
+-- Note: calls @utime@.
+setFileTimes :: RawFilePath -> EpochTime -> EpochTime -> IO ()
+setFileTimes name atime mtime = do
+  withFilePath name $ \s ->
+   allocaBytes (#const sizeof(struct utimbuf)) $ \p -> do
+     (#poke struct utimbuf, actime)  p atime
+     (#poke struct utimbuf, modtime) p mtime
+     throwErrnoPathIfMinus1_ "setFileTimes" name (c_utime s p)
+
+-- | Like 'setFileTimes' but timestamps can have sub-second resolution.
+--
+-- Note: calls @utimensat@ or @utimes@.
+setFileTimesHiRes :: RawFilePath -> POSIXTime -> POSIXTime -> IO ()
+#ifdef HAVE_UTIMENSAT
+setFileTimesHiRes name atime mtime =
+  withFilePath name $ \s ->
+    withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times ->
+      throwErrnoPathIfMinus1_ "setFileTimesHiRes" name $
+        c_utimensat (#const AT_FDCWD) s times 0
+#else
+setFileTimesHiRes name atime mtime =
+  withFilePath name $ \s ->
+    withArray [toCTimeVal atime, toCTimeVal mtime] $ \times ->
+      throwErrnoPathIfMinus1_ "setFileTimesHiRes" name (c_utimes s times)
+#endif
+
+-- | Like 'setFileTimesHiRes' but does not follow symbolic links.
+-- This operation is not supported on all platforms. On these platforms,
+-- this function will raise an exception.
+--
+-- Note: calls @utimensat@ or @lutimes@.
+setSymbolicLinkTimesHiRes :: RawFilePath -> POSIXTime -> POSIXTime -> IO ()
+#if HAVE_UTIMENSAT
+setSymbolicLinkTimesHiRes name atime mtime =
+  withFilePath name $ \s ->
+    withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times ->
+      throwErrnoPathIfMinus1_ "setSymbolicLinkTimesHiRes" name $
+        c_utimensat (#const AT_FDCWD) s times (#const AT_SYMLINK_NOFOLLOW)
+#elif HAVE_LUTIMES
+setSymbolicLinkTimesHiRes name atime mtime =
+  withFilePath name $ \s ->
+    withArray [toCTimeVal atime, toCTimeVal mtime] $ \times ->
+      throwErrnoPathIfMinus1_ "setSymbolicLinkTimesHiRes" name $
+        c_lutimes s times
+#else
+setSymbolicLinkTimesHiRes =
+  error "setSymbolicLinkTimesHiRes: not available on this platform"
+#endif
+
+-- | @touchFile path@ sets the access and modification times associated with
+-- file @path@ to the current time.
+--
+-- Note: calls @utime@.
+touchFile :: RawFilePath -> IO ()
+touchFile name = do
+  withFilePath name $ \s ->
+   throwErrnoPathIfMinus1_ "touchFile" name (c_utime s nullPtr)
+
+-- | Like 'touchFile' but does not follow symbolic links.
+-- This operation is not supported on all platforms. On these platforms,
+-- this function will raise an exception.
+--
+-- Note: calls @lutimes@.
+touchSymbolicLink :: RawFilePath -> IO ()
+#if HAVE_LUTIMES
+touchSymbolicLink name =
+  withFilePath name $ \s ->
+    throwErrnoPathIfMinus1_ "touchSymbolicLink" name (c_lutimes s nullPtr)
+#else
+touchSymbolicLink =
+  error "touchSymbolicLink: not available on this platform"
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Setting file sizes
+
+-- | Truncates the file down to the specified length. If the file was larger
+-- than the given length before this operation was performed the extra is lost.
+--
+-- Note: calls @truncate@.
+setFileSize :: RawFilePath -> FileOffset -> IO ()
+setFileSize file off =
+  withFilePath file $ \s ->
+    throwErrnoPathIfMinus1_ "setFileSize" file (c_truncate s off)
+
+foreign import capi unsafe "HsUnix.h truncate"
+  c_truncate :: CString -> COff -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- pathconf()/fpathconf() support
+
+-- | @getPathVar var path@ obtains the dynamic value of the requested
+-- configurable file limit or option associated with file or directory @path@.
+-- For defined file limits, @getPathVar@ returns the associated
+-- value.  For defined file options, the result of @getPathVar@
+-- is undefined, but not failure.
+--
+-- Note: calls @pathconf@.
+getPathVar :: RawFilePath -> PathVar -> IO Limit
+getPathVar name v = do
+  withFilePath name $ \ nameP ->
+    throwErrnoPathIfMinus1 "getPathVar" name $
+      c_pathconf nameP (pathVarConst v)
+
+foreign import ccall unsafe "pathconf"
+  c_pathconf :: CString -> CInt -> IO CLong

unix/System/Posix/Files/Common.hsc

@@ -0,0 +1,605 @@
+{-# LANGUAGE Trustworthy #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Files.Common
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- Functions defined by the POSIX standards for manipulating and querying the
+-- file system. Names of underlying POSIX functions are indicated whenever
+-- possible. A more complete documentation of the POSIX functions together
+-- with a more detailed description of different error conditions are usually
+-- available in the system's manual pages or from
+-- <http://www.unix.org/version3/online.html> (free registration required).
+--
+-- When a function that calls an underlying POSIX function fails, the errno
+-- code is converted to an 'IOError' using 'Foreign.C.Error.errnoToIOError'.
+-- For a list of which errno codes may be generated, consult the POSIX
+-- documentation for the underlying function.
+--
+-----------------------------------------------------------------------------
+
+#include "HsUnix.h"
+
+module System.Posix.Files.Common (
+    -- * File modes
+    -- FileMode exported by System.Posix.Types
+    unionFileModes, intersectFileModes,
+    nullFileMode,
+    ownerReadMode, ownerWriteMode, ownerExecuteMode, ownerModes,
+    groupReadMode, groupWriteMode, groupExecuteMode, groupModes,
+    otherReadMode, otherWriteMode, otherExecuteMode, otherModes,
+    setUserIDMode, setGroupIDMode,
+    stdFileMode,   accessModes,
+    fileTypeModes,
+    blockSpecialMode, characterSpecialMode, namedPipeMode, regularFileMode,
+    directoryMode, symbolicLinkMode, socketMode,
+
+    -- ** Setting file modes
+    setFdMode, setFileCreationMask,
+
+    -- * File status
+    FileStatus(..),
+    -- ** Obtaining file status
+    getFdStatus,
+    -- ** Querying file status
+    deviceID, fileID, fileMode, linkCount, fileOwner, fileGroup,
+    specialDeviceID, fileSize, accessTime, modificationTime,
+    statusChangeTime,
+    accessTimeHiRes, modificationTimeHiRes, statusChangeTimeHiRes,
+    setFdTimesHiRes, touchFd,
+    isBlockDevice, isCharacterDevice, isNamedPipe, isRegularFile,
+    isDirectory, isSymbolicLink, isSocket,
+
+    -- * Setting file sizes
+    setFdSize,
+
+    -- * Changing file ownership
+    setFdOwnerAndGroup,
+
+    -- * Find system-specific limits for a file
+    PathVar(..), getFdPathVar, pathVarConst,
+
+    -- * Low level types and functions
+#ifdef HAVE_UTIMENSAT
+    CTimeSpec(..),
+    toCTimeSpec,
+    c_utimensat,
+#endif
+    CTimeVal(..),
+    toCTimeVal,
+    c_utimes,
+#ifdef HAVE_LUTIMES
+    c_lutimes,
+#endif
+  ) where
+
+import System.Posix.Types
+import System.IO.Unsafe
+import Data.Bits
+import Data.Int
+import Data.Ratio
+import Data.Time.Clock.POSIX (POSIXTime)
+import System.Posix.Internals
+import Foreign.C
+import Foreign.ForeignPtr
+#if defined(HAVE_FUTIMES) || defined(HAVE_FUTIMENS)
+import Foreign.Marshal (withArray)
+#endif
+import Foreign.Ptr
+import Foreign.Storable
+
+-- -----------------------------------------------------------------------------
+-- POSIX file modes
+
+-- The abstract type 'FileMode', constants and operators for
+-- manipulating the file modes defined by POSIX.
+
+-- | No permissions.
+nullFileMode :: FileMode
+nullFileMode = 0
+
+-- | Owner has read permission.
+ownerReadMode :: FileMode
+ownerReadMode = (#const S_IRUSR)
+
+-- | Owner has write permission.
+ownerWriteMode :: FileMode
+ownerWriteMode = (#const S_IWUSR)
+
+-- | Owner has execute permission.
+ownerExecuteMode :: FileMode
+ownerExecuteMode = (#const S_IXUSR)
+
+-- | Group has read permission.
+groupReadMode :: FileMode
+groupReadMode = (#const S_IRGRP)
+
+-- | Group has write permission.
+groupWriteMode :: FileMode
+groupWriteMode = (#const S_IWGRP)
+
+-- | Group has execute permission.
+groupExecuteMode :: FileMode
+groupExecuteMode = (#const S_IXGRP)
+
+-- | Others have read permission.
+otherReadMode :: FileMode
+otherReadMode = (#const S_IROTH)
+
+-- | Others have write permission.
+otherWriteMode :: FileMode
+otherWriteMode = (#const S_IWOTH)
+
+-- | Others have execute permission.
+otherExecuteMode :: FileMode
+otherExecuteMode = (#const S_IXOTH)
+
+-- | Set user ID on execution.
+setUserIDMode :: FileMode
+setUserIDMode = (#const S_ISUID)
+
+-- | Set group ID on execution.
+setGroupIDMode :: FileMode
+setGroupIDMode = (#const S_ISGID)
+
+-- | Owner, group and others have read and write permission.
+stdFileMode :: FileMode
+stdFileMode = ownerReadMode  .|. ownerWriteMode .|.
+              groupReadMode  .|. groupWriteMode .|.
+              otherReadMode  .|. otherWriteMode
+
+-- | Owner has read, write and execute permission.
+ownerModes :: FileMode
+ownerModes = (#const S_IRWXU)
+
+-- | Group has read, write and execute permission.
+groupModes :: FileMode
+groupModes = (#const S_IRWXG)
+
+-- | Others have read, write and execute permission.
+otherModes :: FileMode
+otherModes = (#const S_IRWXO)
+
+-- | Owner, group and others have read, write and execute permission.
+accessModes :: FileMode
+accessModes = ownerModes .|. groupModes .|. otherModes
+
+-- | Combines the two file modes into one that contains modes that appear in
+-- either.
+unionFileModes :: FileMode -> FileMode -> FileMode
+unionFileModes m1 m2 = m1 .|. m2
+
+-- | Combines two file modes into one that only contains modes that appear in
+-- both.
+intersectFileModes :: FileMode -> FileMode -> FileMode
+intersectFileModes m1 m2 = m1 .&. m2
+
+fileTypeModes :: FileMode
+fileTypeModes = (#const S_IFMT)
+
+blockSpecialMode :: FileMode
+blockSpecialMode = (#const S_IFBLK)
+
+characterSpecialMode :: FileMode
+characterSpecialMode = (#const S_IFCHR)
+
+namedPipeMode :: FileMode
+namedPipeMode = (#const S_IFIFO)
+
+regularFileMode :: FileMode
+regularFileMode = (#const S_IFREG)
+
+directoryMode :: FileMode
+directoryMode = (#const S_IFDIR)
+
+symbolicLinkMode :: FileMode
+symbolicLinkMode = (#const S_IFLNK)
+
+socketMode :: FileMode
+socketMode = (#const S_IFSOCK)
+
+-- | @setFdMode fd mode@ acts like 'setFileMode' but uses a file descriptor
+-- @fd@ instead of a 'FilePath'.
+--
+-- Note: calls @fchmod@.
+setFdMode :: Fd -> FileMode -> IO ()
+setFdMode (Fd fd) m =
+  throwErrnoIfMinus1_ "setFdMode" (c_fchmod fd m)
+
+foreign import ccall unsafe "fchmod"
+  c_fchmod :: CInt -> CMode -> IO CInt
+
+-- | @setFileCreationMask mode@ sets the file mode creation mask to @mode@.
+-- Modes set by this operation are subtracted from files and directories upon
+-- creation. The previous file creation mask is returned.
+--
+-- Note: calls @umask@.
+setFileCreationMask :: FileMode -> IO FileMode
+setFileCreationMask mask = c_umask mask
+
+-- -----------------------------------------------------------------------------
+-- stat() support
+
+-- | POSIX defines operations to get information, such as owner, permissions,
+-- size and access times, about a file. This information is represented by the
+-- 'FileStatus' type.
+--
+-- Note: see @chmod@.
+newtype FileStatus = FileStatus (ForeignPtr CStat)
+
+-- | ID of the device on which this file resides.
+deviceID         :: FileStatus -> DeviceID
+-- | inode number
+fileID           :: FileStatus -> FileID
+-- | File mode (such as permissions).
+fileMode         :: FileStatus -> FileMode
+-- | Number of hard links to this file.
+linkCount        :: FileStatus -> LinkCount
+-- | ID of owner.
+fileOwner        :: FileStatus -> UserID
+-- | ID of group.
+fileGroup        :: FileStatus -> GroupID
+-- | Describes the device that this file represents.
+specialDeviceID  :: FileStatus -> DeviceID
+-- | Size of the file in bytes. If this file is a symbolic link the size is
+-- the length of the pathname it contains.
+fileSize         :: FileStatus -> FileOffset
+-- | Time of last access.
+accessTime       :: FileStatus -> EpochTime
+-- | Time of last access in sub-second resolution.
+accessTimeHiRes  :: FileStatus -> POSIXTime
+-- | Time of last modification.
+modificationTime :: FileStatus -> EpochTime
+-- | Time of last modification in sub-second resolution.
+modificationTimeHiRes :: FileStatus -> POSIXTime
+-- | Time of last status change (i.e. owner, group, link count, mode, etc.).
+statusChangeTime :: FileStatus -> EpochTime
+-- | Time of last status change (i.e. owner, group, link count, mode, etc.) in sub-second resolution.
+statusChangeTimeHiRes :: FileStatus -> POSIXTime
+
+deviceID (FileStatus stat) =
+  unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_dev)
+fileID (FileStatus stat) =
+  unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_ino)
+fileMode (FileStatus stat) =
+  unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_mode)
+linkCount (FileStatus stat) =
+  unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_nlink)
+fileOwner (FileStatus stat) =
+  unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_uid)
+fileGroup (FileStatus stat) =
+  unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_gid)
+specialDeviceID (FileStatus stat) =
+  unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_rdev)
+fileSize (FileStatus stat) =
+  unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_size)
+accessTime (FileStatus stat) =
+  unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_atime)
+modificationTime (FileStatus stat) =
+  unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_mtime)
+statusChangeTime (FileStatus stat) =
+  unsafePerformIO $ withForeignPtr stat $ (#peek struct stat, st_ctime)
+
+accessTimeHiRes (FileStatus stat) =
+  unsafePerformIO $ withForeignPtr stat $ \stat_ptr -> do
+    sec  <- (#peek struct stat, st_atime) stat_ptr :: IO EpochTime
+#ifdef HAVE_STRUCT_STAT_ST_ATIM
+    nsec <- (#peek struct stat, st_atim.tv_nsec) stat_ptr :: IO (#type long)
+    let frac = toInteger nsec % 10^(9::Int)
+#elif HAVE_STRUCT_STAT_ST_ATIMESPEC
+    nsec <- (#peek struct stat, st_atimespec.tv_nsec) stat_ptr :: IO (#type long)
+    let frac = toInteger nsec % 10^(9::Int)
+#elif HAVE_STRUCT_STAT_ST_ATIMENSEC
+    nsec <- (#peek struct stat, st_atimensec) stat_ptr :: IO (#type long)
+    let frac = toInteger nsec % 10^(9::Int)
+#elif HAVE_STRUCT_STAT_ST_ATIME_N
+    nsec <- (#peek struct stat, st_atime_n) stat_ptr :: IO (#type int)
+    let frac = toInteger nsec % 10^(9::Int)
+#elif HAVE_STRUCT_STAT_ST_UATIME
+    usec <- (#peek struct stat, st_uatime) stat_ptr :: IO (#type int)
+    let frac = toInteger usec % 10^(6::Int)
+#else
+    let frac = 0
+#endif
+    return $ fromRational $ toRational sec + frac
+
+modificationTimeHiRes (FileStatus stat) =
+  unsafePerformIO $ withForeignPtr stat $ \stat_ptr -> do
+    sec  <- (#peek struct stat, st_mtime) stat_ptr :: IO EpochTime
+#ifdef HAVE_STRUCT_STAT_ST_MTIM
+    nsec <- (#peek struct stat, st_mtim.tv_nsec) stat_ptr :: IO (#type long)
+    let frac = toInteger nsec % 10^(9::Int)
+#elif HAVE_STRUCT_STAT_ST_MTIMESPEC
+    nsec <- (#peek struct stat, st_mtimespec.tv_nsec) stat_ptr :: IO (#type long)
+    let frac = toInteger nsec % 10^(9::Int)
+#elif HAVE_STRUCT_STAT_ST_MTIMENSEC
+    nsec <- (#peek struct stat, st_mtimensec) stat_ptr :: IO (#type long)
+    let frac = toInteger nsec % 10^(9::Int)
+#elif HAVE_STRUCT_STAT_ST_MTIME_N
+    nsec <- (#peek struct stat, st_mtime_n) stat_ptr :: IO (#type int)
+    let frac = toInteger nsec % 10^(9::Int)
+#elif HAVE_STRUCT_STAT_ST_UMTIME
+    usec <- (#peek struct stat, st_umtime) stat_ptr :: IO (#type int)
+    let frac = toInteger usec % 10^(6::Int)
+#else
+    let frac = 0
+#endif
+    return $ fromRational $ toRational sec + frac
+
+statusChangeTimeHiRes (FileStatus stat) =
+  unsafePerformIO $ withForeignPtr stat $ \stat_ptr -> do
+    sec  <- (#peek struct stat, st_ctime) stat_ptr :: IO EpochTime
+#ifdef HAVE_STRUCT_STAT_ST_CTIM
+    nsec <- (#peek struct stat, st_ctim.tv_nsec) stat_ptr :: IO (#type long)
+    let frac = toInteger nsec % 10^(9::Int)
+#elif HAVE_STRUCT_STAT_ST_CTIMESPEC
+    nsec <- (#peek struct stat, st_ctimespec.tv_nsec) stat_ptr :: IO (#type long)
+    let frac = toInteger nsec % 10^(9::Int)
+#elif HAVE_STRUCT_STAT_ST_CTIMENSEC
+    nsec <- (#peek struct stat, st_ctimensec) stat_ptr :: IO (#type long)
+    let frac = toInteger nsec % 10^(9::Int)
+#elif HAVE_STRUCT_STAT_ST_CTIME_N
+    nsec <- (#peek struct stat, st_ctime_n) stat_ptr :: IO (#type int)
+    let frac = toInteger nsec % 10^(9::Int)
+#elif HAVE_STRUCT_STAT_ST_UCTIME
+    usec <- (#peek struct stat, st_uctime) stat_ptr :: IO (#type int)
+    let frac = toInteger usec % 10^(6::Int)
+#else
+    let frac = 0
+#endif
+    return $ fromRational $ toRational sec + frac
+
+-- | Checks if this file is a block device.
+isBlockDevice     :: FileStatus -> Bool
+-- | Checks if this file is a character device.
+isCharacterDevice :: FileStatus -> Bool
+-- | Checks if this file is a named pipe device.
+isNamedPipe       :: FileStatus -> Bool
+-- | Checks if this file is a regular file device.
+isRegularFile     :: FileStatus -> Bool
+-- | Checks if this file is a directory device.
+isDirectory       :: FileStatus -> Bool
+-- | Checks if this file is a symbolic link device.
+isSymbolicLink    :: FileStatus -> Bool
+-- | Checks if this file is a socket device.
+isSocket          :: FileStatus -> Bool
+
+isBlockDevice stat =
+  (fileMode stat `intersectFileModes` fileTypeModes) == blockSpecialMode
+isCharacterDevice stat =
+  (fileMode stat `intersectFileModes` fileTypeModes) == characterSpecialMode
+isNamedPipe stat =
+  (fileMode stat `intersectFileModes` fileTypeModes) == namedPipeMode
+isRegularFile stat =
+  (fileMode stat `intersectFileModes` fileTypeModes) == regularFileMode
+isDirectory stat =
+  (fileMode stat `intersectFileModes` fileTypeModes) == directoryMode
+isSymbolicLink stat =
+  (fileMode stat `intersectFileModes` fileTypeModes) == symbolicLinkMode
+isSocket stat =
+  (fileMode stat `intersectFileModes` fileTypeModes) == socketMode
+
+-- | @getFdStatus fd@ acts as 'getFileStatus' but uses a file descriptor @fd@.
+--
+-- Note: calls @fstat@.
+getFdStatus :: Fd -> IO FileStatus
+getFdStatus (Fd fd) = do
+  fp <- mallocForeignPtrBytes (#const sizeof(struct stat))
+  withForeignPtr fp $ \p ->
+    throwErrnoIfMinus1_ "getFdStatus" (c_fstat fd p)
+  return (FileStatus fp)
+
+-- -----------------------------------------------------------------------------
+-- Setting file times
+
+#if HAVE_UTIMENSAT || HAVE_FUTIMENS
+data CTimeSpec = CTimeSpec EpochTime CLong
+
+instance Storable CTimeSpec where
+    sizeOf    _ = #size struct timespec
+    alignment _ = alignment (undefined :: CInt)
+    poke p (CTimeSpec sec nsec) = do
+        (#poke struct timespec, tv_sec ) p sec
+        (#poke struct timespec, tv_nsec) p nsec
+    peek p = do
+        sec  <- #{peek struct timespec, tv_sec } p
+        nsec <- #{peek struct timespec, tv_nsec} p
+        return $ CTimeSpec sec nsec
+
+toCTimeSpec :: POSIXTime -> CTimeSpec
+toCTimeSpec t = CTimeSpec (CTime sec) (truncate $ 10^(9::Int) * frac)
+  where
+    (sec, frac) = if (frac' < 0) then (sec' - 1, frac' + 1) else (sec', frac')
+    (sec', frac') = properFraction $ toRational t
+#endif
+
+#ifdef HAVE_UTIMENSAT
+foreign import ccall unsafe "utimensat"
+    c_utimensat :: CInt -> CString -> Ptr CTimeSpec -> CInt -> IO CInt
+#endif
+
+#if HAVE_FUTIMENS
+foreign import ccall unsafe "futimens"
+    c_futimens :: CInt -> Ptr CTimeSpec -> IO CInt
+#endif
+
+data CTimeVal = CTimeVal CLong CLong
+
+instance Storable CTimeVal where
+    sizeOf    _ = #size struct timeval
+    alignment _ = alignment (undefined :: CInt)
+    poke p (CTimeVal sec usec) = do
+        (#poke struct timeval, tv_sec ) p sec
+        (#poke struct timeval, tv_usec) p usec
+    peek p = do
+        sec  <- #{peek struct timeval, tv_sec } p
+        usec <- #{peek struct timeval, tv_usec} p
+        return $ CTimeVal sec usec
+
+toCTimeVal :: POSIXTime -> CTimeVal
+toCTimeVal t = CTimeVal sec (truncate $ 10^(6::Int) * frac)
+  where
+    (sec, frac) = if (frac' < 0) then (sec' - 1, frac' + 1) else (sec', frac')
+    (sec', frac') = properFraction $ toRational t
+
+foreign import ccall unsafe "utimes"
+    c_utimes :: CString -> Ptr CTimeVal -> IO CInt
+
+#ifdef HAVE_LUTIMES
+foreign import ccall unsafe "lutimes"
+    c_lutimes :: CString -> Ptr CTimeVal -> IO CInt
+#endif
+
+#if HAVE_FUTIMES
+foreign import ccall unsafe "futimes"
+    c_futimes :: CInt -> Ptr CTimeVal -> IO CInt
+#endif
+
+-- | Like 'setFileTimesHiRes' but uses a file descriptor instead of a path.
+-- This operation is not supported on all platforms. On these platforms,
+-- this function will raise an exception.
+--
+-- Note: calls @futimens@ or @futimes@.
+--
+-- @since 2.7.0.0
+setFdTimesHiRes :: Fd -> POSIXTime -> POSIXTime -> IO ()
+#if HAVE_FUTIMENS
+setFdTimesHiRes (Fd fd) atime mtime =
+  withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times ->
+    throwErrnoIfMinus1_ "setFdTimesHiRes" (c_futimens fd times)
+#elif HAVE_FUTIMES
+setFdTimesHiRes (Fd fd) atime mtime =
+  withArray [toCTimeVal atime, toCTimeVal mtime] $ \times ->
+    throwErrnoIfMinus1_ "setFdTimesHiRes" (c_futimes fd times)
+#else
+setFdTimesHiRes =
+  error "setSymbolicLinkTimesHiRes: not available on this platform"
+#endif
+
+-- | Like 'touchFile' but uses a file descriptor instead of a path.
+-- This operation is not supported on all platforms. On these platforms,
+-- this function will raise an exception.
+--
+-- Note: calls @futimes@.
+--
+-- @since 2.7.0.0
+touchFd :: Fd -> IO ()
+#if HAVE_FUTIMES
+touchFd (Fd fd) =
+  throwErrnoIfMinus1_ "touchFd" (c_futimes fd nullPtr)
+#else
+touchFd =
+  error "touchFd: not available on this platform"
+#endif
+
+-- -----------------------------------------------------------------------------
+-- fchown()
+
+-- | Acts as 'setOwnerAndGroup' but uses a file descriptor instead of a
+-- 'FilePath'.
+--
+-- Note: calls @fchown@.
+setFdOwnerAndGroup :: Fd -> UserID -> GroupID -> IO ()
+setFdOwnerAndGroup (Fd fd) uid gid =
+  throwErrnoIfMinus1_ "setFdOwnerAndGroup" (c_fchown fd uid gid)
+
+foreign import ccall unsafe "fchown"
+  c_fchown :: CInt -> CUid -> CGid -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- ftruncate()
+
+-- | Acts as 'setFileSize' but uses a file descriptor instead of a 'FilePath'.
+--
+-- Note: calls @ftruncate@.
+setFdSize :: Fd -> FileOffset -> IO ()
+setFdSize (Fd fd) off =
+  throwErrnoIfMinus1_ "setFdSize" (c_ftruncate fd off)
+
+-- -----------------------------------------------------------------------------
+-- pathconf()/fpathconf() support
+
+data PathVar
+  = FileSizeBits                  {- _PC_FILESIZEBITS     -}
+  | LinkLimit                     {- _PC_LINK_MAX         -}
+  | InputLineLimit                {- _PC_MAX_CANON        -}
+  | InputQueueLimit               {- _PC_MAX_INPUT        -}
+  | FileNameLimit                 {- _PC_NAME_MAX         -}
+  | PathNameLimit                 {- _PC_PATH_MAX         -}
+  | PipeBufferLimit               {- _PC_PIPE_BUF         -}
+                                  -- These are described as optional in POSIX:
+                                  {- _PC_ALLOC_SIZE_MIN     -}
+                                  {- _PC_REC_INCR_XFER_SIZE -}
+                                  {- _PC_REC_MAX_XFER_SIZE  -}
+                                  {- _PC_REC_MIN_XFER_SIZE  -}
+                                  {- _PC_REC_XFER_ALIGN     -}
+  | SymbolicLinkLimit             {- _PC_SYMLINK_MAX      -}
+  | SetOwnerAndGroupIsRestricted  {- _PC_CHOWN_RESTRICTED -}
+  | FileNamesAreNotTruncated      {- _PC_NO_TRUNC         -}
+  | VDisableChar                  {- _PC_VDISABLE         -}
+  | AsyncIOAvailable              {- _PC_ASYNC_IO         -}
+  | PrioIOAvailable               {- _PC_PRIO_IO          -}
+  | SyncIOAvailable               {- _PC_SYNC_IO          -}
+
+pathVarConst :: PathVar -> CInt
+pathVarConst v = case v of
+        LinkLimit                       -> (#const _PC_LINK_MAX)
+        InputLineLimit                  -> (#const _PC_MAX_CANON)
+        InputQueueLimit                 -> (#const _PC_MAX_INPUT)
+        FileNameLimit                   -> (#const _PC_NAME_MAX)
+        PathNameLimit                   -> (#const _PC_PATH_MAX)
+        PipeBufferLimit                 -> (#const _PC_PIPE_BUF)
+        SetOwnerAndGroupIsRestricted    -> (#const _PC_CHOWN_RESTRICTED)
+        FileNamesAreNotTruncated        -> (#const _PC_NO_TRUNC)
+        VDisableChar                    -> (#const _PC_VDISABLE)
+
+#ifdef _PC_SYNC_IO
+        SyncIOAvailable         -> (#const _PC_SYNC_IO)
+#else
+        SyncIOAvailable         -> error "_PC_SYNC_IO not available"
+#endif
+
+#ifdef _PC_ASYNC_IO
+        AsyncIOAvailable        -> (#const _PC_ASYNC_IO)
+#else
+        AsyncIOAvailable        -> error "_PC_ASYNC_IO not available"
+#endif
+
+#ifdef _PC_PRIO_IO
+        PrioIOAvailable         -> (#const _PC_PRIO_IO)
+#else
+        PrioIOAvailable         -> error "_PC_PRIO_IO not available"
+#endif
+
+#if _PC_FILESIZEBITS
+        FileSizeBits            -> (#const _PC_FILESIZEBITS)
+#else
+        FileSizeBits            -> error "_PC_FILESIZEBITS not available"
+#endif
+
+#if _PC_SYMLINK_MAX
+        SymbolicLinkLimit       -> (#const _PC_SYMLINK_MAX)
+#else
+        SymbolicLinkLimit       -> error "_PC_SYMLINK_MAX not available"
+#endif
+
+-- | @getFdPathVar var fd@ obtains the dynamic value of the requested
+-- configurable file limit or option associated with the file or directory
+-- attached to the open channel @fd@. For defined file limits, @getFdPathVar@
+-- returns the associated value.  For defined file options, the result of
+-- @getFdPathVar@ is undefined, but not failure.
+--
+-- Note: calls @fpathconf@.
+getFdPathVar :: Fd -> PathVar -> IO Limit
+getFdPathVar (Fd fd) v =
+    throwErrnoIfMinus1 "getFdPathVar" $
+      c_fpathconf fd (pathVarConst v)
+
+foreign import ccall unsafe "fpathconf"
+  c_fpathconf :: CInt -> CInt -> IO CLong

unix/System/Posix/IO.hsc

@@ -0,0 +1,92 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.IO
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX IO support.  These types and functions correspond to the unix
+-- functions open(2), close(2), etc.  For more portable functions
+-- which are more like fopen(3) and friends from stdio.h, see
+-- "System.IO".
+--
+-----------------------------------------------------------------------------
+
+#include "HsUnix.h"
+
+module System.Posix.IO (
+    -- * Input \/ Output
+
+    -- ** Standard file descriptors
+    stdInput, stdOutput, stdError,
+
+    -- ** Opening and closing files
+    OpenMode(..),
+    OpenFileFlags(..), defaultFileFlags,
+    openFd, createFile,
+    closeFd,
+
+    -- ** Reading\/writing data
+    -- |Programmers using the 'fdRead' and 'fdWrite' API should be aware that
+    -- EAGAIN exceptions may occur for non-blocking IO!
+
+    fdRead, fdWrite,
+    fdReadBuf, fdWriteBuf,
+
+    -- ** Seeking
+    fdSeek,
+
+    -- ** File options
+    FdOption(..),
+    queryFdOption,
+    setFdOption,
+
+    -- ** Locking
+    FileLock,
+    LockRequest(..),
+    getLock,  setLock,
+    waitToSetLock,
+
+    -- ** Pipes
+    createPipe,
+
+    -- ** Duplicating file descriptors
+    dup, dupTo,
+
+    -- ** Converting file descriptors to\/from Handles
+    handleToFd,
+    fdToHandle,
+
+  ) where
+
+import System.Posix.Types
+import System.Posix.Error
+import System.Posix.IO.Common
+import System.Posix.Internals ( withFilePath )
+
+-- |Open and optionally create this file.  See 'System.Posix.Files'
+-- for information on how to use the 'FileMode' type.
+openFd :: FilePath
+       -> OpenMode
+       -> OpenFileFlags
+       -> IO Fd
+openFd name how flags =
+   withFilePath name $ \str ->
+     throwErrnoPathIfMinus1Retry "openFd" name $
+       open_ str how flags
+
+-- |Create and open this file in WriteOnly mode.  A special case of
+-- 'openFd'.  See 'System.Posix.Files' for information on how to use
+-- the 'FileMode' type.
+
+createFile :: FilePath -> FileMode -> IO Fd
+createFile name mode
+  = openFd name WriteOnly defaultFileFlags{ trunc=True, creat=(Just mode) }

unix/System/Posix/IO/ByteString.hsc

@@ -0,0 +1,92 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.IO.ByteString
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX IO support.  These types and functions correspond to the unix
+-- functions open(2), close(2), etc.  For more portable functions
+-- which are more like fopen(3) and friends from stdio.h, see
+-- "System.IO".
+--
+-----------------------------------------------------------------------------
+
+#include "HsUnix.h"
+
+module System.Posix.IO.ByteString (
+    -- * Input \/ Output
+
+    -- ** Standard file descriptors
+    stdInput, stdOutput, stdError,
+
+    -- ** Opening and closing files
+    OpenMode(..),
+    OpenFileFlags(..), defaultFileFlags,
+    openFd, createFile,
+    closeFd,
+
+    -- ** Reading\/writing data
+    -- |Programmers using the 'fdRead' and 'fdWrite' API should be aware that
+    -- EAGAIN exceptions may occur for non-blocking IO!
+
+    fdRead, fdWrite,
+    fdReadBuf, fdWriteBuf,
+
+    -- ** Seeking
+    fdSeek,
+
+    -- ** File options
+    FdOption(..),
+    queryFdOption,
+    setFdOption,
+
+    -- ** Locking
+    FileLock,
+    LockRequest(..),
+    getLock,  setLock,
+    waitToSetLock,
+
+    -- ** Pipes
+    createPipe,
+
+    -- ** Duplicating file descriptors
+    dup, dupTo,
+
+    -- ** Converting file descriptors to\/from Handles
+    handleToFd,
+    fdToHandle,
+
+  ) where
+
+import System.Posix.Types
+import System.Posix.IO.Common
+
+import System.Posix.ByteString.FilePath
+
+-- |Open and optionally create this file.  See 'System.Posix.Files'
+-- for information on how to use the 'FileMode' type.
+openFd :: RawFilePath
+       -> OpenMode
+       -> OpenFileFlags
+       -> IO Fd
+openFd name how flags =
+   withFilePath name $ \str ->
+     throwErrnoPathIfMinus1Retry "openFd" name $
+       open_ str how flags
+
+-- |Create and open this file in WriteOnly mode.  A special case of
+-- 'openFd'.  See 'System.Posix.Files' for information on how to use
+-- the 'FileMode' type.
+
+createFile :: RawFilePath -> FileMode -> IO Fd
+createFile name mode
+  = openFd name WriteOnly defaultFileFlags{ trunc=True, creat=(Just mode) }

unix/System/Posix/IO/Common.hsc

@@ -0,0 +1,443 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE RecordWildCards #-}
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.IO.Common
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.IO.Common (
+    -- * Input \/ Output
+
+    -- ** Standard file descriptors
+    stdInput, stdOutput, stdError,
+
+    -- ** Opening and closing files
+    OpenMode(..),
+    OpenFileFlags(..), defaultFileFlags,
+    open_,
+    closeFd,
+
+    -- ** Reading\/writing data
+    -- |Programmers using the 'fdRead' and 'fdWrite' API should be aware that
+    -- EAGAIN exceptions may occur for non-blocking IO!
+
+    fdRead, fdWrite,
+    fdReadBuf, fdWriteBuf,
+
+    -- ** Seeking
+    fdSeek,
+
+    -- ** File options
+    FdOption(..),
+    queryFdOption,
+    setFdOption,
+
+    -- ** Locking
+    FileLock,
+    LockRequest(..),
+    getLock,  setLock,
+    waitToSetLock,
+
+    -- ** Pipes
+    createPipe,
+
+    -- ** Duplicating file descriptors
+    dup, dupTo,
+
+    -- ** Converting file descriptors to\/from Handles
+    handleToFd,
+    fdToHandle,
+
+  ) where
+
+import System.IO
+import System.IO.Error
+import System.Posix.Types
+import qualified System.Posix.Internals as Base
+
+import Foreign
+import Foreign.C
+
+import GHC.IO.Handle.Internals
+import GHC.IO.Handle.Types
+import qualified GHC.IO.FD as FD
+import qualified GHC.IO.Handle.FD as FD
+import GHC.IO.Exception
+import Data.Typeable (cast)
+
+#include "HsUnix.h"
+
+-- -----------------------------------------------------------------------------
+-- Pipes
+-- |The 'createPipe' function creates a pair of connected file
+-- descriptors. The first component is the fd to read from, the second
+-- is the write end.  Although pipes may be bidirectional, this
+-- behaviour is not portable and programmers should use two separate
+-- pipes for this purpose.  May throw an exception if this is an
+-- invalid descriptor.
+
+createPipe :: IO (Fd, Fd)
+createPipe =
+  allocaArray 2 $ \p_fd -> do
+    throwErrnoIfMinus1_ "createPipe" (c_pipe p_fd)
+    rfd <- peekElemOff p_fd 0
+    wfd <- peekElemOff p_fd 1
+    return (Fd rfd, Fd wfd)
+
+foreign import ccall unsafe "pipe"
+   c_pipe :: Ptr CInt -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Duplicating file descriptors
+
+-- | May throw an exception if this is an invalid descriptor.
+dup :: Fd -> IO Fd
+dup (Fd fd) = do r <- throwErrnoIfMinus1 "dup" (c_dup fd); return (Fd r)
+
+-- | May throw an exception if this is an invalid descriptor.
+dupTo :: Fd -> Fd -> IO Fd
+dupTo (Fd fd1) (Fd fd2) = do
+  r <- throwErrnoIfMinus1 "dupTo" (c_dup2 fd1 fd2)
+  return (Fd r)
+
+foreign import ccall unsafe "dup"
+   c_dup :: CInt -> IO CInt
+
+foreign import ccall unsafe "dup2"
+   c_dup2 :: CInt -> CInt -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Opening and closing files
+
+stdInput, stdOutput, stdError :: Fd
+stdInput   = Fd (#const STDIN_FILENO)
+stdOutput  = Fd (#const STDOUT_FILENO)
+stdError   = Fd (#const STDERR_FILENO)
+
+data OpenMode = ReadOnly | WriteOnly | ReadWrite
+              deriving (Read, Show, Eq, Ord)
+
+-- |Correspond to some of the int flags from C's fcntl.h.
+data OpenFileFlags =
+ OpenFileFlags {
+    append    :: Bool,           -- ^ O_APPEND
+    exclusive :: Bool,           -- ^ O_EXCL
+                                 --
+                                 -- __NOTE__: Result is undefined if 'creat' is 'Nothing'.
+    noctty    :: Bool,           -- ^ O_NOCTTY
+    nonBlock  :: Bool,           -- ^ O_NONBLOCK
+    trunc     :: Bool,           -- ^ O_TRUNC
+    nofollow  :: Bool,           -- ^ O_NOFOLLOW
+                                 --
+                                 -- @since 2.8.0.0
+    creat     :: Maybe FileMode, -- ^ O_CREAT
+                                 --
+                                 -- @since 2.8.0.0
+    cloexec   :: Bool,           -- ^ O_CLOEXEC
+                                 --
+                                 -- @since 2.8.0.0
+    directory :: Bool,           -- ^ O_DIRECTORY
+                                 --
+                                 -- @since 2.8.0.0
+    sync      :: Bool            -- ^ O_SYNC
+                                 --
+                                 -- @since 2.8.0.0
+ }
+ deriving (Read, Show, Eq, Ord)
+
+
+-- | Default values for the 'OpenFileFlags' type.
+--
+-- Each field of 'OpenFileFlags' is either 'False' or 'Nothing'
+-- respectively.
+defaultFileFlags :: OpenFileFlags
+defaultFileFlags =
+ OpenFileFlags {
+    append    = False,
+    exclusive = False,
+    noctty    = False,
+    nonBlock  = False,
+    trunc     = False,
+    nofollow  = False,
+    creat     = Nothing,
+    cloexec   = False,
+    directory = False,
+    sync      = False
+  }
+
+
+-- |Open and optionally create this file.  See 'System.Posix.Files'
+-- for information on how to use the 'FileMode' type.
+open_  :: CString
+       -> OpenMode
+       -> OpenFileFlags
+       -> IO Fd
+open_ str how (OpenFileFlags appendFlag exclusiveFlag nocttyFlag
+                                nonBlockFlag truncateFlag nofollowFlag
+                                creatFlag cloexecFlag directoryFlag
+                                syncFlag) = do
+    fd <- c_open str all_flags mode_w
+    return (Fd fd)
+  where
+    all_flags  = creat .|. flags .|. open_mode
+
+    flags =
+       (if appendFlag       then (#const O_APPEND)    else 0) .|.
+       (if exclusiveFlag    then (#const O_EXCL)      else 0) .|.
+       (if nocttyFlag       then (#const O_NOCTTY)    else 0) .|.
+       (if nonBlockFlag     then (#const O_NONBLOCK)  else 0) .|.
+       (if truncateFlag     then (#const O_TRUNC)     else 0) .|.
+       (if nofollowFlag     then (#const O_NOFOLLOW)  else 0) .|.
+       (if cloexecFlag      then (#const O_CLOEXEC)   else 0) .|.
+       (if directoryFlag    then (#const O_DIRECTORY) else 0) .|.
+       (if syncFlag         then (#const O_SYNC)      else 0)
+
+    (creat, mode_w) = case creatFlag of
+                        Nothing -> (0,0)
+                        Just x  -> ((#const O_CREAT), x)
+
+    open_mode = case how of
+                   ReadOnly  -> (#const O_RDONLY)
+                   WriteOnly -> (#const O_WRONLY)
+                   ReadWrite -> (#const O_RDWR)
+
+foreign import capi unsafe "HsUnix.h open"
+   c_open :: CString -> CInt -> CMode -> IO CInt
+
+-- |Close this file descriptor.  May throw an exception if this is an
+-- invalid descriptor.
+
+closeFd :: Fd -> IO ()
+closeFd (Fd fd) = throwErrnoIfMinus1_ "closeFd" (c_close fd)
+-- Here we don't to retry on EINTR because according to
+--  http://pubs.opengroup.org/onlinepubs/9699919799/functions/close.html
+-- "with errno set to [EINTR] [...] the state of fildes is unspecified"
+-- and on Linux, already the first close() removes the FD from the process's
+-- FD table so closing a second time is invalid
+-- (see http://man7.org/linux/man-pages/man2/close.2.html#NOTES).
+
+foreign import ccall unsafe "HsUnix.h close"
+   c_close :: CInt -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Converting file descriptors to/from Handles
+
+-- | Extracts the 'Fd' from a 'Handle'.  This function has the side effect
+-- of closing the 'Handle' and flushing its write buffer, if necessary.
+handleToFd :: Handle -> IO Fd
+
+-- | Converts an 'Fd' into a 'Handle' that can be used with the
+-- standard Haskell IO library (see "System.IO").
+fdToHandle :: Fd -> IO Handle
+fdToHandle fd = FD.fdToHandle (fromIntegral fd)
+
+handleToFd h@(FileHandle _ m) = do
+  withHandle' "handleToFd" h m $ handleToFd' h
+handleToFd h@(DuplexHandle _ r w) = do
+  _ <- withHandle' "handleToFd" h r $ handleToFd' h
+  withHandle' "handleToFd" h w $ handleToFd' h
+  -- for a DuplexHandle, make sure we mark both sides as closed,
+  -- otherwise a finalizer will come along later and close the other
+  -- side. (#3914)
+
+handleToFd' :: Handle -> Handle__ -> IO (Handle__, Fd)
+handleToFd' h h_@Handle__{haType=_,..} = do
+  case cast haDevice of
+    Nothing -> ioError (ioeSetErrorString (mkIOError IllegalOperation
+                                           "handleToFd" (Just h) Nothing)
+                        "handle is not a file descriptor")
+    Just fd -> do
+     -- converting a Handle into an Fd effectively means
+     -- letting go of the Handle; it is put into a closed
+     -- state as a result.
+     flushWriteBuffer h_
+     FD.release fd
+     return (Handle__{haType=ClosedHandle,..}, Fd (FD.fdFD fd))
+
+
+-- -----------------------------------------------------------------------------
+-- Fd options
+
+data FdOption = AppendOnWrite     -- ^O_APPEND
+              | CloseOnExec       -- ^FD_CLOEXEC
+              | NonBlockingRead   -- ^O_NONBLOCK
+              | SynchronousWrites -- ^O_SYNC
+
+fdOption2Int :: FdOption -> CInt
+fdOption2Int CloseOnExec       = (#const FD_CLOEXEC)
+fdOption2Int AppendOnWrite     = (#const O_APPEND)
+fdOption2Int NonBlockingRead   = (#const O_NONBLOCK)
+fdOption2Int SynchronousWrites = (#const O_SYNC)
+
+-- | May throw an exception if this is an invalid descriptor.
+queryFdOption :: Fd -> FdOption -> IO Bool
+queryFdOption (Fd fd) opt = do
+  r <- throwErrnoIfMinus1 "queryFdOption" (Base.c_fcntl_read fd flag)
+  return ((r .&. fdOption2Int opt) /= 0)
+ where
+  flag    = case opt of
+              CloseOnExec       -> (#const F_GETFD)
+              _                 -> (#const F_GETFL)
+
+-- | May throw an exception if this is an invalid descriptor.
+setFdOption :: Fd -> FdOption -> Bool -> IO ()
+setFdOption (Fd fd) opt val = do
+  r <- throwErrnoIfMinus1 "setFdOption" (Base.c_fcntl_read fd getflag)
+  let r' | val       = r .|. opt_val
+         | otherwise = r .&. (complement opt_val)
+  throwErrnoIfMinus1_ "setFdOption"
+                      (Base.c_fcntl_write fd setflag (fromIntegral r'))
+ where
+  (getflag,setflag)= case opt of
+              CloseOnExec       -> ((#const F_GETFD),(#const F_SETFD))
+              _                 -> ((#const F_GETFL),(#const F_SETFL))
+  opt_val = fdOption2Int opt
+
+-- -----------------------------------------------------------------------------
+-- Seeking
+
+mode2Int :: SeekMode -> CInt
+mode2Int AbsoluteSeek = (#const SEEK_SET)
+mode2Int RelativeSeek = (#const SEEK_CUR)
+mode2Int SeekFromEnd  = (#const SEEK_END)
+
+-- | May throw an exception if this is an invalid descriptor.
+fdSeek :: Fd -> SeekMode -> FileOffset -> IO FileOffset
+fdSeek (Fd fd) mode off =
+  throwErrnoIfMinus1 "fdSeek" (Base.c_lseek fd off (mode2Int mode))
+
+-- -----------------------------------------------------------------------------
+-- Locking
+
+data LockRequest = ReadLock
+                 | WriteLock
+                 | Unlock
+
+type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset)
+
+-- | May throw an exception if this is an invalid descriptor.
+getLock :: Fd -> FileLock -> IO (Maybe (ProcessID, FileLock))
+getLock (Fd fd) lock =
+  allocaLock lock $ \p_flock -> do
+    throwErrnoIfMinus1_ "getLock" (Base.c_fcntl_lock fd (#const F_GETLK) p_flock)
+    result <- bytes2ProcessIDAndLock p_flock
+    return (maybeResult result)
+  where
+    maybeResult (_, (Unlock, _, _, _)) = Nothing
+    maybeResult x = Just x
+
+allocaLock :: FileLock -> (Ptr Base.CFLock -> IO a) -> IO a
+allocaLock (lockreq, mode, start, len) io =
+  allocaBytes (#const sizeof(struct flock)) $ \p -> do
+    (#poke struct flock, l_type)   p (lockReq2Int lockreq :: CShort)
+    (#poke struct flock, l_whence) p (fromIntegral (mode2Int mode) :: CShort)
+    (#poke struct flock, l_start)  p start
+    (#poke struct flock, l_len)    p len
+    io p
+
+lockReq2Int :: LockRequest -> CShort
+lockReq2Int ReadLock  = (#const F_RDLCK)
+lockReq2Int WriteLock = (#const F_WRLCK)
+lockReq2Int Unlock    = (#const F_UNLCK)
+
+bytes2ProcessIDAndLock :: Ptr Base.CFLock -> IO (ProcessID, FileLock)
+bytes2ProcessIDAndLock p = do
+  req   <- (#peek struct flock, l_type)   p
+  mode  <- (#peek struct flock, l_whence) p
+  start <- (#peek struct flock, l_start)  p
+  len   <- (#peek struct flock, l_len)    p
+  pid   <- (#peek struct flock, l_pid)    p
+  return (pid, (int2req req, int2mode mode, start, len))
+ where
+  int2req :: CShort -> LockRequest
+  int2req (#const F_RDLCK) = ReadLock
+  int2req (#const F_WRLCK) = WriteLock
+  int2req (#const F_UNLCK) = Unlock
+  int2req _ = error $ "int2req: bad argument"
+
+  int2mode :: CShort -> SeekMode
+  int2mode (#const SEEK_SET) = AbsoluteSeek
+  int2mode (#const SEEK_CUR) = RelativeSeek
+  int2mode (#const SEEK_END) = SeekFromEnd
+  int2mode _ = error $ "int2mode: bad argument"
+
+-- | May throw an exception if this is an invalid descriptor.
+setLock :: Fd -> FileLock -> IO ()
+setLock (Fd fd) lock = do
+  allocaLock lock $ \p_flock ->
+    throwErrnoIfMinus1_ "setLock" (Base.c_fcntl_lock fd (#const F_SETLK) p_flock)
+
+-- | May throw an exception if this is an invalid descriptor.
+waitToSetLock :: Fd -> FileLock -> IO ()
+waitToSetLock (Fd fd) lock = do
+  allocaLock lock $ \p_flock ->
+    throwErrnoIfMinus1_ "waitToSetLock"
+        (Base.c_fcntl_lock fd (#const F_SETLKW) p_flock)
+
+-- -----------------------------------------------------------------------------
+-- fd{Read,Write}
+
+-- | Read data from an 'Fd' and convert it to a 'String' using the locale encoding.
+-- Throws an exception if this is an invalid descriptor, or EOF has been
+-- reached.
+fdRead :: Fd
+       -> ByteCount -- ^How many bytes to read
+       -> IO (String, ByteCount) -- ^The bytes read, how many bytes were read.
+fdRead _fd 0 = return ("", 0)
+fdRead fd nbytes = do
+    allocaBytes (fromIntegral nbytes) $ \ buf -> do
+    rc <- fdReadBuf fd buf nbytes
+    case rc of
+      0 -> ioError (ioeSetErrorString (mkIOError EOF "fdRead" Nothing Nothing) "EOF")
+      n -> do
+       s <- peekCStringLen (castPtr buf, fromIntegral n)
+       return (s, n)
+
+-- | Read data from an 'Fd' into memory.  This is exactly equivalent
+-- to the POSIX @read@ function.
+fdReadBuf :: Fd
+          -> Ptr Word8 -- ^ Memory in which to put the data
+          -> ByteCount -- ^ Maximum number of bytes to read
+          -> IO ByteCount -- ^ Number of bytes read (zero for EOF)
+fdReadBuf _fd _buf 0 = return 0
+fdReadBuf fd buf nbytes =
+  fmap fromIntegral $
+    throwErrnoIfMinus1Retry "fdReadBuf" $
+      c_safe_read (fromIntegral fd) (castPtr buf) nbytes
+
+foreign import ccall safe "read"
+   c_safe_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
+
+-- | Write a 'String' to an 'Fd' using the locale encoding.
+fdWrite :: Fd -> String -> IO ByteCount
+fdWrite fd str =
+  withCStringLen str $ \ (buf,len) ->
+    fdWriteBuf fd (castPtr buf) (fromIntegral len)
+
+-- | Write data from memory to an 'Fd'.  This is exactly equivalent
+-- to the POSIX @write@ function.
+fdWriteBuf :: Fd
+           -> Ptr Word8    -- ^ Memory containing the data to write
+           -> ByteCount    -- ^ Maximum number of bytes to write
+           -> IO ByteCount -- ^ Number of bytes written
+fdWriteBuf fd buf len =
+  fmap fromIntegral $
+    throwErrnoIfMinus1Retry "fdWriteBuf" $
+      c_safe_write (fromIntegral fd) (castPtr buf) len
+
+foreign import ccall safe "write"
+   c_safe_write :: CInt -> Ptr CChar -> CSize -> IO CSsize

unix/System/Posix/Process.hsc

@@ -0,0 +1,125 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Process
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX process support.  See also the System.Cmd and System.Process
+-- modules in the process package.
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Process (
+    -- * Processes
+
+    -- ** Forking and executing
+    forkProcess,
+    forkProcessWithUnmask,
+    executeFile,
+
+    -- ** Exiting
+    exitImmediately,
+
+    -- ** Process environment
+    getProcessID,
+    getParentProcessID,
+
+    -- ** Process groups
+    getProcessGroupID,
+    getProcessGroupIDOf,
+    createProcessGroupFor,
+    joinProcessGroup,
+    setProcessGroupIDOf,
+
+    -- ** Sessions
+    createSession,
+
+    -- ** Process times
+    ProcessTimes(..),
+    getProcessTimes,
+
+    -- ** Scheduling priority
+    nice,
+    getProcessPriority,
+    getProcessGroupPriority,
+    getUserPriority,
+    setProcessPriority,
+    setProcessGroupPriority,
+    setUserPriority,
+
+    -- ** Process status
+    ProcessStatus(..),
+    getProcessStatus,
+    getAnyProcessStatus,
+    getGroupProcessStatus,
+
+    -- ** Deprecated
+    createProcessGroup,
+    setProcessGroupID,
+
+ ) where
+
+#include "HsUnix.h"
+
+import Foreign
+import Foreign.C
+import System.Posix.Process.Internals
+import System.Posix.Process.Common
+import System.Posix.Internals ( withFilePath )
+
+-- | @'executeFile' cmd args env@ calls one of the
+--   @execv*@ family, depending on whether or not the current
+--   PATH is to be searched for the command, and whether or not an
+--   environment is provided to supersede the process's current
+--   environment.  The basename (leading directory names suppressed) of
+--   the command is passed to @execv*@ as @arg[0]@;
+--   the argument list passed to 'executeFile' therefore
+--   begins with @arg[1]@.
+executeFile :: FilePath                     -- ^ Command
+            -> Bool                         -- ^ Search PATH?
+            -> [String]                     -- ^ Arguments
+            -> Maybe [(String, String)]     -- ^ Environment
+            -> IO a
+executeFile path search args Nothing = do
+  withFilePath path $ \s ->
+    withMany withFilePath (path:args) $ \cstrs ->
+      withArray0 nullPtr cstrs $ \arr -> do
+        pPrPr_disableITimers
+        if search
+           then throwErrnoPathIfMinus1_ "executeFile" path (c_execvp s arr)
+           else throwErrnoPathIfMinus1_ "executeFile" path (c_execv s arr)
+        return undefined -- never reached
+
+executeFile path search args (Just env) = do
+  withFilePath path $ \s ->
+    withMany withFilePath (path:args) $ \cstrs ->
+      withArray0 nullPtr cstrs $ \arg_arr ->
+    let env' = map (\ (name, val) -> name ++ ('=' : val)) env in
+    withMany withFilePath env' $ \cenv ->
+      withArray0 nullPtr cenv $ \env_arr -> do
+        pPrPr_disableITimers
+        if search
+           then throwErrnoPathIfMinus1_ "executeFile" path
+                   (c_execvpe s arg_arr env_arr)
+           else throwErrnoPathIfMinus1_ "executeFile" path
+                   (c_execve s arg_arr env_arr)
+        return undefined -- never reached
+
+foreign import ccall unsafe "execvp"
+  c_execvp :: CString -> Ptr CString -> IO CInt
+
+foreign import ccall unsafe "execv"
+  c_execv :: CString -> Ptr CString -> IO CInt
+
+foreign import ccall unsafe "execve"
+  c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt
+

unix/System/Posix/Process/ByteString.hsc

@@ -0,0 +1,136 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Process.ByteString
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX process support.  See also the System.Cmd and System.Process
+-- modules in the process package.
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Process.ByteString (
+    -- * Processes
+
+    -- ** Forking and executing
+    forkProcess,
+    forkProcessWithUnmask,
+    executeFile,
+
+    -- ** Exiting
+    exitImmediately,
+
+    -- ** Process environment
+    getProcessID,
+    getParentProcessID,
+
+    -- ** Process groups
+    getProcessGroupID,
+    getProcessGroupIDOf,
+    createProcessGroupFor,
+    joinProcessGroup,
+    setProcessGroupIDOf,
+
+    -- ** Sessions
+    createSession,
+
+    -- ** Process times
+    ProcessTimes(..),
+    getProcessTimes,
+
+    -- ** Scheduling priority
+    nice,
+    getProcessPriority,
+    getProcessGroupPriority,
+    getUserPriority,
+    setProcessPriority,
+    setProcessGroupPriority,
+    setUserPriority,
+
+    -- ** Process status
+    ProcessStatus(..),
+    getProcessStatus,
+    getAnyProcessStatus,
+    getGroupProcessStatus,
+
+    -- ** Deprecated
+    createProcessGroup,
+    setProcessGroupID,
+
+ ) where
+
+#include "HsUnix.h"
+
+import Foreign
+import System.Posix.Process.Internals
+import System.Posix.Process.Common
+
+import Foreign.C hiding (
+     throwErrnoPath,
+     throwErrnoPathIf,
+     throwErrnoPathIf_,
+     throwErrnoPathIfNull,
+     throwErrnoPathIfMinus1,
+     throwErrnoPathIfMinus1_ )
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BC
+
+import System.Posix.ByteString.FilePath
+
+-- | @'executeFile' cmd args env@ calls one of the
+--   @execv*@ family, depending on whether or not the current
+--   PATH is to be searched for the command, and whether or not an
+--   environment is provided to supersede the process's current
+--   environment.  The basename (leading directory names suppressed) of
+--   the command is passed to @execv*@ as @arg[0]@;
+--   the argument list passed to 'executeFile' therefore
+--   begins with @arg[1]@.
+executeFile :: RawFilePath                          -- ^ Command
+            -> Bool                         -- ^ Search PATH?
+            -> [ByteString]                 -- ^ Arguments
+            -> Maybe [(ByteString, ByteString)]     -- ^ Environment
+            -> IO a
+executeFile path search args Nothing = do
+  withFilePath path $ \s ->
+    withMany withFilePath (path:args) $ \cstrs ->
+      withArray0 nullPtr cstrs $ \arr -> do
+        pPrPr_disableITimers
+        if search
+           then throwErrnoPathIfMinus1_ "executeFile" path (c_execvp s arr)
+           else throwErrnoPathIfMinus1_ "executeFile" path (c_execv s arr)
+        return undefined -- never reached
+
+executeFile path search args (Just env) = do
+  withFilePath path $ \s ->
+    withMany withFilePath (path:args) $ \cstrs ->
+      withArray0 nullPtr cstrs $ \arg_arr ->
+    let env' = map (\ (name, val) -> name `BC.append` ('=' `BC.cons` val)) env in
+    withMany withFilePath env' $ \cenv ->
+      withArray0 nullPtr cenv $ \env_arr -> do
+        pPrPr_disableITimers
+        if search
+           then throwErrnoPathIfMinus1_ "executeFile" path
+                   (c_execvpe s arg_arr env_arr)
+           else throwErrnoPathIfMinus1_ "executeFile" path
+                   (c_execve s arg_arr env_arr)
+        return undefined -- never reached
+
+foreign import ccall unsafe "execvp"
+  c_execvp :: CString -> Ptr CString -> IO CInt
+
+foreign import ccall unsafe "execv"
+  c_execv :: CString -> Ptr CString -> IO CInt
+
+foreign import ccall unsafe "execve"
+  c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt

unix/System/Posix/Process/Common.hsc

@@ -0,0 +1,430 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE InterruptibleFFI, RankNTypes #-}
+{-# LANGUAGE Trustworthy #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Process.Common
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX process support.  See also the System.Cmd and System.Process
+-- modules in the process package.
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Process.Common (
+    -- * Processes
+
+    -- ** Forking and executing
+    forkProcess,
+    forkProcessWithUnmask,
+
+    -- ** Exiting
+    exitImmediately,
+
+    -- ** Process environment
+    getProcessID,
+    getParentProcessID,
+
+    -- ** Process groups
+    getProcessGroupID,
+    getProcessGroupIDOf,
+    createProcessGroupFor,
+    joinProcessGroup,
+    setProcessGroupIDOf,
+
+    -- ** Sessions
+    createSession,
+
+    -- ** Process times
+    ProcessTimes(..),
+    getProcessTimes,
+
+    -- ** Scheduling priority
+    nice,
+    getProcessPriority,
+    getProcessGroupPriority,
+    getUserPriority,
+    setProcessPriority,
+    setProcessGroupPriority,
+    setUserPriority,
+
+    -- ** Process status
+    ProcessStatus(..),
+    getProcessStatus,
+    getAnyProcessStatus,
+    getGroupProcessStatus,
+
+    -- ** Deprecated
+    createProcessGroup,
+    setProcessGroupID,
+
+ ) where
+
+#include "HsUnix.h"
+
+import Foreign.C.Error
+import Foreign.C.Types
+import Foreign.Marshal.Alloc ( alloca, allocaBytes )
+import Foreign.Ptr ( Ptr )
+import Foreign.StablePtr ( StablePtr, newStablePtr, freeStablePtr )
+import Foreign.Storable ( Storable(..) )
+import System.Exit
+import System.Posix.Process.Internals
+import System.Posix.Types
+import Control.Monad
+
+import Control.Exception.Base ( bracket, getMaskingState, MaskingState(..) ) -- used by forkProcess
+import GHC.TopHandler   ( runIO )
+import GHC.IO ( unsafeUnmask, uninterruptibleMask_ )
+
+-- -----------------------------------------------------------------------------
+-- Process environment
+
+-- | 'getProcessID' calls @getpid@ to obtain the 'ProcessID' for
+--   the current process.
+getProcessID :: IO ProcessID
+getProcessID = c_getpid
+
+foreign import ccall unsafe "getpid"
+   c_getpid :: IO CPid
+
+-- | 'getProcessID' calls @getppid@ to obtain the 'ProcessID' for
+--   the parent of the current process.
+getParentProcessID :: IO ProcessID
+getParentProcessID = c_getppid
+
+foreign import ccall unsafe "getppid"
+  c_getppid :: IO CPid
+
+-- | 'getProcessGroupID' calls @getpgrp@ to obtain the
+--   'ProcessGroupID' for the current process.
+getProcessGroupID :: IO ProcessGroupID
+getProcessGroupID = c_getpgrp
+
+foreign import ccall unsafe "getpgrp"
+  c_getpgrp :: IO CPid
+
+-- | @'getProcessGroupIDOf' pid@ calls @getpgid@ to obtain the
+--   'ProcessGroupID' for process @pid@.
+getProcessGroupIDOf :: ProcessID -> IO ProcessGroupID
+getProcessGroupIDOf pid =
+  throwErrnoIfMinus1 "getProcessGroupIDOf" (c_getpgid pid)
+
+foreign import ccall unsafe "getpgid"
+  c_getpgid :: CPid -> IO CPid
+
+{-
+   To be added in the future, after the deprecation period for the
+   existing createProcessGroup has elapsed:
+
+-- | 'createProcessGroup' calls @setpgid(0,0)@ to make
+--   the current process a new process group leader.
+createProcessGroup :: IO ProcessGroupID
+createProcessGroup = do
+  throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid 0 0)
+  pgid <- getProcessGroupID
+  return pgid
+-}
+
+-- | @'createProcessGroupFor' pid@ calls @setpgid@ to make
+--   process @pid@ a new process group leader.
+createProcessGroupFor :: ProcessID -> IO ProcessGroupID
+createProcessGroupFor pid = do
+  throwErrnoIfMinus1_ "createProcessGroupFor" (c_setpgid pid 0)
+  return pid
+
+-- | @'joinProcessGroup' pgid@ calls @setpgid@ to set the
+--   'ProcessGroupID' of the current process to @pgid@.
+joinProcessGroup :: ProcessGroupID -> IO ()
+joinProcessGroup pgid =
+  throwErrnoIfMinus1_ "joinProcessGroup" (c_setpgid 0 pgid)
+
+{-
+   To be added in the future, after the deprecation period for the
+   existing setProcessGroupID has elapsed:
+
+-- | @'setProcessGroupID' pgid@ calls @setpgid@ to set the
+--   'ProcessGroupID' of the current process to @pgid@.
+setProcessGroupID :: ProcessGroupID -> IO ()
+setProcessGroupID pgid =
+  throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid 0 pgid)
+-}
+
+-- | @'setProcessGroupIDOf' pid pgid@ calls @setpgid@ to set the
+--   'ProcessGroupIDOf' for process @pid@ to @pgid@.
+setProcessGroupIDOf :: ProcessID -> ProcessGroupID -> IO ()
+setProcessGroupIDOf pid pgid =
+  throwErrnoIfMinus1_ "setProcessGroupIDOf" (c_setpgid pid pgid)
+
+foreign import ccall unsafe "setpgid"
+  c_setpgid :: CPid -> CPid -> IO CInt
+
+-- | 'createSession' calls @setsid@ to create a new session
+--   with the current process as session leader.
+createSession :: IO ProcessGroupID
+createSession = throwErrnoIfMinus1 "createSession" c_setsid
+
+foreign import ccall unsafe "setsid"
+  c_setsid :: IO CPid
+
+-- -----------------------------------------------------------------------------
+-- Process times
+
+-- All times in clock ticks (see getClockTick)
+
+data ProcessTimes
+  = ProcessTimes { elapsedTime     :: ClockTick
+                 , userTime        :: ClockTick
+                 , systemTime      :: ClockTick
+                 , childUserTime   :: ClockTick
+                 , childSystemTime :: ClockTick
+                 }
+
+-- | 'getProcessTimes' calls @times@ to obtain time-accounting
+--   information for the current process and its children.
+getProcessTimes :: IO ProcessTimes
+getProcessTimes = do
+   allocaBytes (#const sizeof(struct tms)) $ \p_tms -> do
+     elapsed <- throwErrnoIfMinus1 "getProcessTimes" (c_times p_tms)
+     ut  <- (#peek struct tms, tms_utime)  p_tms
+     st  <- (#peek struct tms, tms_stime)  p_tms
+     cut <- (#peek struct tms, tms_cutime) p_tms
+     cst <- (#peek struct tms, tms_cstime) p_tms
+     return (ProcessTimes{ elapsedTime     = elapsed,
+                           userTime        = ut,
+                           systemTime      = st,
+                           childUserTime   = cut,
+                           childSystemTime = cst
+                          })
+
+data {-# CTYPE "struct tms" #-} CTms
+
+foreign import capi unsafe "HsUnix.h times"
+  c_times :: Ptr CTms -> IO CClock
+
+-- -----------------------------------------------------------------------------
+-- Process scheduling priority
+
+nice :: Int -> IO ()
+nice prio = do
+  resetErrno
+  res <- c_nice (fromIntegral prio)
+  when (res == -1) $ do
+    err <- getErrno
+    when (err /= eOK) (throwErrno "nice")
+
+foreign import ccall unsafe "nice"
+  c_nice :: CInt -> IO CInt
+
+getProcessPriority      :: ProcessID      -> IO Int
+getProcessGroupPriority :: ProcessGroupID -> IO Int
+getUserPriority         :: UserID         -> IO Int
+
+getProcessPriority pid = do
+  r <- throwErrnoIfMinus1 "getProcessPriority" $
+         c_getpriority (#const PRIO_PROCESS) (fromIntegral pid)
+  return (fromIntegral r)
+
+getProcessGroupPriority pid = do
+  r <- throwErrnoIfMinus1 "getProcessPriority" $
+         c_getpriority (#const PRIO_PGRP) (fromIntegral pid)
+  return (fromIntegral r)
+
+getUserPriority uid = do
+  r <- throwErrnoIfMinus1 "getUserPriority" $
+         c_getpriority (#const PRIO_USER) (fromIntegral uid)
+  return (fromIntegral r)
+
+foreign import ccall unsafe "getpriority"
+  c_getpriority :: CInt -> CInt -> IO CInt
+
+setProcessPriority      :: ProcessID      -> Int -> IO ()
+setProcessGroupPriority :: ProcessGroupID -> Int -> IO ()
+setUserPriority         :: UserID         -> Int -> IO ()
+
+setProcessPriority pid val =
+  throwErrnoIfMinus1_ "setProcessPriority" $
+    c_setpriority (#const PRIO_PROCESS) (fromIntegral pid) (fromIntegral val)
+
+setProcessGroupPriority pid val =
+  throwErrnoIfMinus1_ "setProcessPriority" $
+    c_setpriority (#const PRIO_PGRP) (fromIntegral pid) (fromIntegral val)
+
+setUserPriority uid val =
+  throwErrnoIfMinus1_ "setUserPriority" $
+    c_setpriority (#const PRIO_USER) (fromIntegral uid) (fromIntegral val)
+
+foreign import ccall unsafe "setpriority"
+  c_setpriority :: CInt -> CInt -> CInt -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Forking, execution
+
+{- | 'forkProcess' corresponds to the POSIX @fork@ system call.
+The 'IO' action passed as an argument is executed in the child process; no other
+threads will be copied to the child process.
+On success, 'forkProcess' returns the child's 'ProcessID' to the parent process;
+in case of an error, an exception is thrown.
+
+The exception masking state of the executed action is inherited
+(c.f. 'forkIO'), see also 'forkProcessWithUnmask' (/since: 2.7.0.0/).
+
+'forkProcess' comes with a giant warning: since any other running
+threads are not copied into the child process, it's easy to go wrong:
+e.g. by accessing some shared resource that was held by another thread
+in the parent.
+-}
+
+forkProcess :: IO () -> IO ProcessID
+forkProcess action = do
+  -- wrap action to re-establish caller's masking state, as
+  -- 'forkProcessPrim' starts in 'MaskedInterruptible' state by
+  -- default; see also #1048
+  mstate <- getMaskingState
+  let action' = case mstate of
+          Unmasked              -> unsafeUnmask action
+          MaskedInterruptible   -> action
+          MaskedUninterruptible -> uninterruptibleMask_ action
+
+  bracket
+    (newStablePtr (runIO action'))
+    freeStablePtr
+    (\stable -> throwErrnoIfMinus1 "forkProcess" (forkProcessPrim stable))
+
+foreign import ccall "forkProcess" forkProcessPrim :: StablePtr (IO ()) -> IO CPid
+
+-- | Variant of 'forkProcess' in the style of 'forkIOWithUnmask'.
+--
+-- @since 2.7.0.0
+forkProcessWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ProcessID
+forkProcessWithUnmask action = forkProcess (action unsafeUnmask)
+
+-- -----------------------------------------------------------------------------
+-- Waiting for process termination
+
+-- | @'getProcessStatus' blk stopped pid@ calls @waitpid@, returning
+--   @'Just' tc@, the 'ProcessStatus' for process @pid@ if it is
+--   available, 'Nothing' otherwise.  If @blk@ is 'False', then
+--   @WNOHANG@ is set in the options for @waitpid@, otherwise not.
+--   If @stopped@ is 'True', then @WUNTRACED@ is set in the
+--   options for @waitpid@, otherwise not.
+getProcessStatus :: Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
+getProcessStatus block stopped pid =
+  alloca $ \wstatp -> do
+    pid' <- throwErrnoIfMinus1Retry "getProcessStatus"
+                (c_waitpid pid wstatp (waitOptions block stopped))
+    case pid' of
+      0  -> return Nothing
+      _  -> do ps <- readWaitStatus wstatp
+               return (Just ps)
+
+-- safe/interruptible, because this call might block
+foreign import ccall interruptible "waitpid"
+  c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
+
+-- | @'getGroupProcessStatus' blk stopped pgid@ calls @waitpid@,
+--   returning @'Just' (pid, tc)@, the 'ProcessID' and 'ProcessStatus'
+--   for any process in group @pgid@ if one is available, or 'Nothing'
+--   if there are child processes but none have exited.  If there are
+--   no child processes, then 'getGroupProcessStatus' raises an
+--   'isDoesNotExistError' exception.
+--
+--   If @blk@ is 'False', then @WNOHANG@ is set in the options for
+--   @waitpid@, otherwise not.  If @stopped@ is 'True', then
+--   @WUNTRACED@ is set in the options for @waitpid@, otherwise not.
+getGroupProcessStatus :: Bool
+                      -> Bool
+                      -> ProcessGroupID
+                      -> IO (Maybe (ProcessID, ProcessStatus))
+getGroupProcessStatus block stopped pgid =
+  alloca $ \wstatp -> do
+    pid <- throwErrnoIfMinus1Retry "getGroupProcessStatus"
+                (c_waitpid (-pgid) wstatp (waitOptions block stopped))
+    case pid of
+      0  -> return Nothing
+      _  -> do ps <- readWaitStatus wstatp
+               return (Just (pid, ps))
+
+-- | @'getAnyProcessStatus' blk stopped@ calls @waitpid@, returning
+--   @'Just' (pid, tc)@, the 'ProcessID' and 'ProcessStatus' for any
+--   child process if a child process has exited, or 'Nothing' if
+--   there are child processes but none have exited.  If there are no
+--   child processes, then 'getAnyProcessStatus' raises an
+--   'isDoesNotExistError' exception.
+--
+--   If @blk@ is 'False', then @WNOHANG@ is set in the options for
+--   @waitpid@, otherwise not.  If @stopped@ is 'True', then
+--   @WUNTRACED@ is set in the options for @waitpid@, otherwise not.
+getAnyProcessStatus :: Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus))
+getAnyProcessStatus block stopped = getGroupProcessStatus block stopped 1
+
+waitOptions :: Bool -> Bool -> CInt
+--             block   stopped
+waitOptions False False = (#const WNOHANG)
+waitOptions False True  = (#const (WNOHANG|WUNTRACED))
+waitOptions True  False = 0
+waitOptions True  True  = (#const WUNTRACED)
+
+-- Turn a (ptr to a) wait status into a ProcessStatus
+
+readWaitStatus :: Ptr CInt -> IO ProcessStatus
+readWaitStatus wstatp = do
+  wstat <- peek wstatp
+  decipherWaitStatus wstat
+
+-- -----------------------------------------------------------------------------
+-- Exiting
+
+-- | @'exitImmediately' status@ calls @_exit@ to terminate the process
+--   with the indicated exit @status@.
+--   The operation never returns. Since it does not use the Haskell exception
+--   system and it cannot be caught.
+--
+--   Note: Prior to @unix-2.8.0.0@ the type-signature of 'exitImmediately' was
+--   @ExitCode -> IO ()@.
+--
+-- @since 2.8.0.0
+exitImmediately :: ExitCode -> IO a
+exitImmediately status = do
+    _ <- c_exit (exitcode2Int status)
+    -- The above will exit the program, but need the following to satisfy
+    -- the type signature.
+    exitImmediately status
+  where
+    exitcode2Int ExitSuccess = 0
+    exitcode2Int (ExitFailure n) = fromIntegral n
+
+foreign import ccall unsafe "exit"
+  c_exit :: CInt -> IO ()
+
+-- -----------------------------------------------------------------------------
+-- Deprecated or subject to change
+
+{-# DEPRECATED createProcessGroup "This function is scheduled to be replaced by something different in the future, we therefore recommend that you do not use this version and use 'createProcessGroupFor' instead." #-} -- deprecated in 7.2
+-- | @'createProcessGroup' pid@ calls @setpgid@ to make
+--   process @pid@ a new process group leader.
+--   This function is currently deprecated,
+--   and might be changed to making the current
+--   process a new process group leader in future versions.
+createProcessGroup :: ProcessID -> IO ProcessGroupID
+createProcessGroup pid = do
+  throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid pid 0)
+  return pid
+
+{-# DEPRECATED setProcessGroupID "This function is scheduled to be replaced by something different in the future, we therefore recommend that you do not use this version and use 'setProcessGroupIDOf' instead." #-} -- deprecated in 7.2
+-- | @'setProcessGroupID' pid pgid@ calls @setpgid@ to set the
+--   'ProcessGroupID' for process @pid@ to @pgid@.
+--   This function is currently deprecated,
+--   and might be changed to setting the 'ProcessGroupID'
+--   for the current process in future versions.
+setProcessGroupID :: ProcessID -> ProcessGroupID -> IO ()
+setProcessGroupID pid pgid =
+  throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid pid pgid)
+
+-- -----------------------------------------------------------------------------

unix/System/Posix/Process/Internals.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE Trustworthy #-}
+
+module System.Posix.Process.Internals (
+       pPrPr_disableITimers, c_execvpe,
+       decipherWaitStatus, ProcessStatus(..) ) where
+
+import Foreign
+import Foreign.C
+import System.Exit
+import System.IO.Error
+import GHC.Conc (Signal)
+
+-- | The exit status of a process
+data ProcessStatus
+   = Exited ExitCode        -- ^ the process exited by calling
+                            -- @exit()@ or returning from @main@
+   | Terminated Signal Bool -- ^ the process was terminated by a
+                            -- signal, the @Bool@ is @True@ if a core
+                            -- dump was produced
+                            --
+                            -- @since 2.7.0.0
+   | Stopped Signal         -- ^ the process was stopped by a signal
+   deriving (Eq, Ord, Show)
+
+-- this function disables the itimer, which would otherwise cause confusing
+-- signals to be sent to the new process.
+foreign import capi unsafe "Rts.h stopTimer"
+  pPrPr_disableITimers :: IO ()
+
+foreign import ccall unsafe "__hsunix_execvpe"
+  c_execvpe :: CString -> Ptr CString -> Ptr CString -> IO CInt
+
+decipherWaitStatus :: CInt -> IO ProcessStatus
+decipherWaitStatus wstat =
+  if c_WIFEXITED wstat /= 0
+      then do
+        let exitstatus = c_WEXITSTATUS wstat
+        if exitstatus == 0
+           then return (Exited ExitSuccess)
+           else return (Exited (ExitFailure (fromIntegral exitstatus)))
+      else do
+        if c_WIFSIGNALED wstat /= 0
+           then do
+                let termsig    = c_WTERMSIG wstat
+                let coredumped = c_WCOREDUMP wstat /= 0
+                return (Terminated termsig coredumped)
+           else do
+                if c_WIFSTOPPED wstat /= 0
+                   then do
+                        let stopsig = c_WSTOPSIG wstat
+                        return (Stopped stopsig)
+                   else do
+                        ioError (mkIOError illegalOperationErrorType
+                                   "waitStatus" Nothing Nothing)
+
+
+foreign import capi unsafe "HsUnix.h WIFEXITED"
+  c_WIFEXITED :: CInt -> CInt
+
+foreign import capi unsafe "HsUnix.h WEXITSTATUS"
+  c_WEXITSTATUS :: CInt -> CInt
+
+foreign import capi unsafe "HsUnix.h WIFSIGNALED"
+  c_WIFSIGNALED :: CInt -> CInt
+
+foreign import capi unsafe "HsUnix.h WTERMSIG"
+  c_WTERMSIG :: CInt -> CInt
+
+foreign import capi unsafe "HsUnix.h WIFSTOPPED"
+  c_WIFSTOPPED :: CInt -> CInt
+
+foreign import capi unsafe "HsUnix.h WSTOPSIG"
+  c_WSTOPSIG :: CInt -> CInt
+
+foreign import capi unsafe "HsUnix.h WCOREDUMP"
+  c_WCOREDUMP :: CInt -> CInt
+

unix/System/Posix/Resource.hsc

@@ -0,0 +1,166 @@
+{-# LANGUAGE CApiFFI #-}
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Resource
+-- Copyright   :  (c) The University of Glasgow 2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX resource support
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Resource (
+    -- * Resource Limits
+    ResourceLimit(..), ResourceLimits(..), Resource(..),
+    getResourceLimit,
+    setResourceLimit,
+  ) where
+
+#include "HsUnix.h"
+
+import System.Posix.Types
+import Foreign
+import Foreign.C
+
+-- -----------------------------------------------------------------------------
+-- Resource limits
+
+data Resource
+  = ResourceCoreFileSize
+  | ResourceCPUTime
+  | ResourceDataSize
+  | ResourceFileSize
+  | ResourceOpenFiles
+  | ResourceStackSize
+#ifdef RLIMIT_AS
+  | ResourceTotalMemory
+#endif
+  deriving Eq
+
+data ResourceLimits
+  = ResourceLimits { softLimit, hardLimit :: ResourceLimit }
+  deriving Eq
+
+data ResourceLimit
+  = ResourceLimitInfinity
+  | ResourceLimitUnknown
+  | ResourceLimit Integer
+  deriving Eq
+
+data {-# CTYPE "struct rlimit" #-} RLimit
+
+foreign import capi unsafe "HsUnix.h getrlimit"
+  c_getrlimit :: CInt -> Ptr RLimit -> IO CInt
+
+foreign import capi unsafe "HsUnix.h setrlimit"
+  c_setrlimit :: CInt -> Ptr RLimit -> IO CInt
+
+getResourceLimit :: Resource -> IO ResourceLimits
+getResourceLimit res = do
+  allocaBytes (#const sizeof(struct rlimit)) $ \p_rlimit -> do
+    throwErrnoIfMinus1_ "getResourceLimit" $
+      c_getrlimit (packResource res) p_rlimit
+    soft <- (#peek struct rlimit, rlim_cur) p_rlimit
+    hard <- (#peek struct rlimit, rlim_max) p_rlimit
+    return (ResourceLimits {
+                softLimit = unpackRLimit soft,
+                hardLimit = unpackRLimit hard
+           })
+
+setResourceLimit :: Resource -> ResourceLimits -> IO ()
+setResourceLimit res ResourceLimits{softLimit=soft,hardLimit=hard} = do
+  allocaBytes (#const sizeof(struct rlimit)) $ \p_rlimit -> do
+    (#poke struct rlimit, rlim_cur) p_rlimit (packRLimit soft True)
+    (#poke struct rlimit, rlim_max) p_rlimit (packRLimit hard False)
+    throwErrnoIfMinus1_ "setResourceLimit" $
+        c_setrlimit (packResource res) p_rlimit
+    return ()
+
+packResource :: Resource -> CInt
+packResource ResourceCoreFileSize  = (#const RLIMIT_CORE)
+packResource ResourceCPUTime       = (#const RLIMIT_CPU)
+packResource ResourceDataSize      = (#const RLIMIT_DATA)
+packResource ResourceFileSize      = (#const RLIMIT_FSIZE)
+packResource ResourceOpenFiles     = (#const RLIMIT_NOFILE)
+packResource ResourceStackSize     = (#const RLIMIT_STACK)
+#ifdef RLIMIT_AS
+packResource ResourceTotalMemory   = (#const RLIMIT_AS)
+#endif
+
+unpackRLimit :: CRLim -> ResourceLimit
+unpackRLimit (#const RLIM_INFINITY)  = ResourceLimitInfinity
+unpackRLimit other
+#if defined(RLIM_SAVED_MAX)
+    | ((#const RLIM_SAVED_MAX) :: CRLim) /= (#const RLIM_INFINITY) &&
+      other == (#const RLIM_SAVED_MAX) = ResourceLimitUnknown
+#endif
+#if defined(RLIM_SAVED_CUR)
+    | ((#const RLIM_SAVED_CUR) :: CRLim) /= (#const RLIM_INFINITY) &&
+      other == (#const RLIM_SAVED_CUR) = ResourceLimitUnknown
+#endif
+    | otherwise = ResourceLimit (fromIntegral other)
+
+packRLimit :: ResourceLimit -> Bool -> CRLim
+packRLimit ResourceLimitInfinity _     = (#const RLIM_INFINITY)
+#if defined(RLIM_SAVED_CUR)
+packRLimit ResourceLimitUnknown  True  = (#const RLIM_SAVED_CUR)
+#endif
+#if defined(RLIM_SAVED_MAX)
+packRLimit ResourceLimitUnknown  False = (#const RLIM_SAVED_MAX)
+#endif
+#if ! defined(RLIM_SAVED_MAX) && !defined(RLIM_SAVED_CUR)
+packRLimit ResourceLimitUnknown  _     =
+    error
+      $ "System.Posix.Resource.packRLimit: " ++
+        "ResourceLimitUnknown but RLIM_SAVED_MAX/RLIM_SAVED_CUR not defined by platform"
+#endif
+packRLimit (ResourceLimit other) _     = fromIntegral other
+
+
+-- -----------------------------------------------------------------------------
+-- Test code
+
+{-
+import System.Posix
+import Control.Monad
+
+main = do
+ zipWithM_ (\r n -> setResourceLimit r ResourceLimits{
+                                        hardLimit = ResourceLimit n,
+                                        softLimit = ResourceLimit n })
+        allResources [1..]
+ showAll
+ mapM_ (\r -> setResourceLimit r ResourceLimits{
+                                        hardLimit = ResourceLimit 1,
+                                        softLimit = ResourceLimitInfinity })
+        allResources
+   -- should fail
+
+
+showAll =
+  mapM_ (\r -> getResourceLimit r >>= (putStrLn . showRLims)) allResources
+
+allResources =
+    [ResourceCoreFileSize, ResourceCPUTime, ResourceDataSize,
+        ResourceFileSize, ResourceOpenFiles, ResourceStackSize
+#ifdef RLIMIT_AS
+        , ResourceTotalMemory
+#endif
+        ]
+
+showRLims ResourceLimits{hardLimit=h,softLimit=s}
+  = "hard: " ++ showRLim h ++ ", soft: " ++ showRLim s
+
+showRLim ResourceLimitInfinity = "infinity"
+showRLim ResourceLimitUnknown  = "unknown"
+showRLim (ResourceLimit other)  = show other
+-}

unix/System/Posix/Semaphore.hsc

@@ -0,0 +1,131 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Semaphore
+-- Copyright   :  (c) Daniel Franke 2007
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX named semaphore support.
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Semaphore
+    (OpenSemFlags(..), Semaphore(),
+     semOpen, semUnlink, semWait, semTryWait, semThreadWait,
+     semPost, semGetValue)
+    where
+
+#include <semaphore.h>
+#include <fcntl.h>
+
+import Foreign.C
+import Foreign.ForeignPtr hiding (newForeignPtr)
+import Foreign.Concurrent
+import Foreign.Marshal
+import Foreign.Ptr
+import Foreign.Storable
+import System.Posix.Types
+import Control.Concurrent
+import Data.Bits
+
+data OpenSemFlags = OpenSemFlags { semCreate :: Bool,
+                                   -- ^ If true, create the semaphore if it
+                                   --   does not yet exist.
+                                   semExclusive :: Bool
+                                   -- ^ If true, throw an exception if the
+                                   --   semaphore already exists.
+                                 }
+
+newtype Semaphore = Semaphore (ForeignPtr ())
+
+-- | Open a named semaphore with the given name, flags, mode, and initial
+--   value.
+semOpen :: String -> OpenSemFlags -> FileMode -> Int -> IO Semaphore
+semOpen name flags mode value =
+    let cflags = (if semCreate flags then #{const O_CREAT} else 0) .|.
+                 (if semExclusive flags then #{const O_EXCL} else 0)
+        semOpen' cname =
+            do sem <- throwErrnoPathIfNull "semOpen" name $
+                      sem_open cname (toEnum cflags) mode (toEnum value)
+               fptr <- newForeignPtr sem (finalize sem)
+               return $ Semaphore fptr
+        finalize sem = throwErrnoPathIfMinus1_ "semOpen" name $
+                       sem_close sem in
+    withCAString name semOpen'
+
+-- | Delete the semaphore with the given name.
+semUnlink :: String -> IO ()
+semUnlink name = withCAString name semUnlink'
+    where semUnlink' cname = throwErrnoPathIfMinus1_ "semUnlink" name $
+                             sem_unlink cname
+
+-- | Lock the semaphore, blocking until it becomes available.  Since this
+--   is done through a system call, this will block the *entire runtime*,
+--   not just the current thread.  If this is not the behaviour you want,
+--   use semThreadWait instead.
+semWait :: Semaphore -> IO ()
+semWait (Semaphore fptr) = withForeignPtr fptr semWait'
+    where semWait' sem = throwErrnoIfMinus1Retry_ "semWait" $
+                         sem_wait sem
+
+-- | Attempt to lock the semaphore without blocking.  Immediately return
+--   False if it is not available.
+semTryWait :: Semaphore -> IO Bool
+semTryWait (Semaphore fptr) = withForeignPtr fptr semTrywait'
+    where semTrywait' sem = do res <- sem_trywait sem
+                               (if res == 0 then return True
+                                else do errno <- getErrno
+                                        (if errno == eINTR
+                                         then semTrywait' sem
+                                         else if errno == eAGAIN
+                                              then return False
+                                              else throwErrno "semTrywait"))
+
+-- | Poll the semaphore until it is available, then lock it.  Unlike
+--   semWait, this will block only the current thread rather than the
+--   entire process.
+semThreadWait :: Semaphore -> IO ()
+semThreadWait sem = do res <- semTryWait sem
+                       (if res then return ()
+                        else ( do { yield; semThreadWait sem } ))
+
+-- | Unlock the semaphore.
+semPost :: Semaphore -> IO ()
+semPost (Semaphore fptr) = withForeignPtr fptr semPost'
+    where semPost' sem = throwErrnoIfMinus1Retry_ "semPost" $
+                         sem_post sem
+
+-- | Return the semaphore's current value.
+semGetValue :: Semaphore -> IO Int
+semGetValue (Semaphore fptr) = withForeignPtr fptr semGetValue'
+    where semGetValue' sem = alloca (semGetValue_ sem)
+
+semGetValue_ :: Ptr () -> Ptr CInt -> IO Int
+semGetValue_ sem ptr = do throwErrnoIfMinus1Retry_ "semGetValue" $
+                            sem_getvalue sem ptr
+                          cint <- peek ptr
+                          return $ fromEnum cint
+
+foreign import ccall safe "sem_open"
+        sem_open :: CString -> CInt -> CMode -> CUInt -> IO (Ptr ())
+foreign import ccall safe "sem_close"
+        sem_close :: Ptr () -> IO CInt
+foreign import ccall safe "sem_unlink"
+        sem_unlink :: CString -> IO CInt
+
+foreign import ccall safe "sem_wait"
+        sem_wait :: Ptr () -> IO CInt
+foreign import ccall safe "sem_trywait"
+        sem_trywait :: Ptr () -> IO CInt
+foreign import ccall safe "sem_post"
+        sem_post :: Ptr () -> IO CInt
+foreign import ccall safe "sem_getvalue"
+        sem_getvalue :: Ptr () -> Ptr CInt -> IO Int

unix/System/Posix/SharedMem.hsc

@@ -0,0 +1,91 @@
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.SharedMem
+-- Copyright   :  (c) Daniel Franke 2007
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX shared memory support.
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.SharedMem
+    (ShmOpenFlags(..), shmOpen, shmUnlink)
+    where
+
+#include "HsUnix.h"
+
+#include <sys/types.h>
+#include <sys/mman.h>
+#include <fcntl.h>
+
+import System.Posix.Types
+#if defined(HAVE_SHM_OPEN) || defined(HAVE_SHM_UNLINK)
+import Foreign.C
+#endif
+#ifdef HAVE_SHM_OPEN
+import Data.Bits
+#endif
+
+data ShmOpenFlags = ShmOpenFlags
+    { shmReadWrite :: Bool,
+      -- ^ If true, open the shm object read-write rather than read-only.
+      shmCreate :: Bool,
+      -- ^ If true, create the shm object if it does not exist.
+      shmExclusive :: Bool,
+      -- ^ If true, throw an exception if the shm object already exists.
+      shmTrunc :: Bool
+      -- ^ If true, wipe the contents of the shm object after opening it.
+    }
+
+-- | Open a shared memory object with the given name, flags, and mode.
+shmOpen :: String -> ShmOpenFlags -> FileMode -> IO Fd
+#ifdef HAVE_SHM_OPEN
+shmOpen name flags mode =
+    do cflags0 <- return 0
+       cflags1 <- return $ cflags0 .|. (if shmReadWrite flags
+                                        then #{const O_RDWR}
+                                        else #{const O_RDONLY})
+       cflags2 <- return $ cflags1 .|. (if shmCreate flags then #{const O_CREAT}
+                                        else 0)
+       cflags3 <- return $ cflags2 .|. (if shmExclusive flags
+                                        then #{const O_EXCL}
+                                        else 0)
+       cflags4 <- return $ cflags3 .|. (if shmTrunc flags then #{const O_TRUNC}
+                                        else 0)
+       withCAString name (shmOpen' cflags4)
+    where shmOpen' cflags cname =
+              do fd <- throwErrnoIfMinus1 "shmOpen" $
+                       shm_open cname cflags mode
+                 return $ Fd fd
+#else
+shmOpen = error "System.Posix.SharedMem:shm_open: not available"
+#endif
+
+-- | Delete the shared memory object with the given name.
+shmUnlink :: String -> IO ()
+#ifdef HAVE_SHM_UNLINK
+shmUnlink name = withCAString name shmUnlink'
+    where shmUnlink' cname =
+              throwErrnoIfMinus1_ "shmUnlink" $ shm_unlink cname
+#else
+shmUnlink = error "System.Posix.SharedMem:shm_unlink: not available"
+#endif
+
+#ifdef HAVE_SHM_OPEN
+foreign import ccall unsafe "shm_open"
+        shm_open :: CString -> CInt -> CMode -> IO CInt
+#endif
+
+#ifdef HAVE_SHM_UNLINK
+foreign import ccall unsafe "shm_unlink"
+        shm_unlink :: CString -> IO CInt
+#endif

unix/System/Posix/Signals.hsc

@@ -0,0 +1,706 @@
+{-# LANGUAGE CApiFFI, CPP, DeriveDataTypeable, NondecreasingIndentation #-}
+{-# OPTIONS_GHC -fno-cse #-} -- global variables
+{-# LANGUAGE Trustworthy #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Signals
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX signal support
+--
+-----------------------------------------------------------------------------
+
+#include "HsUnixConfig.h"
+##include "HsUnixConfig.h"
+
+#ifdef HAVE_SIGNAL_H
+#include <signal.h>
+#endif
+
+module System.Posix.Signals (
+  -- * The Signal type
+  Signal,
+
+  -- * Specific signals
+  nullSignal,
+  internalAbort, sigABRT,
+  realTimeAlarm, sigALRM,
+  busError, sigBUS,
+  processStatusChanged, sigCHLD,
+  continueProcess, sigCONT,
+  floatingPointException, sigFPE,
+  lostConnection, sigHUP,
+  illegalInstruction, sigILL,
+  keyboardSignal, sigINT,
+  killProcess, sigKILL,
+  openEndedPipe, sigPIPE,
+  keyboardTermination, sigQUIT,
+  segmentationViolation, sigSEGV,
+  softwareStop, sigSTOP,
+  softwareTermination, sigTERM,
+  keyboardStop, sigTSTP,
+  backgroundRead, sigTTIN,
+  backgroundWrite, sigTTOU,
+  userDefinedSignal1, sigUSR1,
+  userDefinedSignal2, sigUSR2,
+#if CONST_SIGPOLL != -1
+  pollableEvent, sigPOLL,
+#endif
+  profilingTimerExpired, sigPROF,
+  badSystemCall, sigSYS,
+  breakpointTrap, sigTRAP,
+  urgentDataAvailable, sigURG,
+  virtualTimerExpired, sigVTALRM,
+  cpuTimeLimitExceeded, sigXCPU,
+  fileSizeLimitExceeded, sigXFSZ,
+
+  -- * Sending signals
+  raiseSignal,
+  signalProcess,
+  signalProcessGroup,
+
+  -- * Handling signals
+  Handler(Default,Ignore,Catch,CatchOnce,CatchInfo,CatchInfoOnce),
+  SignalInfo(..), SignalSpecificInfo(..),
+  installHandler,
+
+  -- * Signal sets
+  SignalSet,
+  emptySignalSet, fullSignalSet, reservedSignals,
+  addSignal, deleteSignal, inSignalSet,
+
+  -- * The process signal mask
+  getSignalMask, setSignalMask, blockSignals, unblockSignals,
+
+  -- * The alarm timer
+  scheduleAlarm,
+
+  -- * Waiting for signals
+  getPendingSignals,
+  awaitSignal,
+
+  -- * The @NOCLDSTOP@ flag
+  setStoppedChildFlag, queryStoppedChildFlag,
+
+  -- MISSING FUNCTIONALITY:
+  -- sigaction(), (inc. the sigaction structure + flags etc.)
+  -- the siginfo structure
+  -- sigaltstack()
+  -- sighold, sigignore, sigpause, sigrelse, sigset
+  -- siginterrupt
+  ) where
+
+import Data.Word
+import Foreign.C
+import Foreign.ForeignPtr
+import Foreign.Marshal
+import Foreign.Ptr
+import Foreign.Storable
+import System.IO.Unsafe (unsafePerformIO)
+import System.Posix.Types
+import System.Posix.Internals
+import System.Posix.Process
+import System.Posix.Process.Internals
+import Data.Dynamic
+
+##include "rts/Signals.h"
+
+import GHC.Conc hiding (Signal)
+
+-- -----------------------------------------------------------------------------
+-- Specific signals
+
+nullSignal :: Signal
+nullSignal = 0
+
+-- | Process abort signal.
+sigABRT   :: CInt
+sigABRT   = CONST_SIGABRT
+
+-- | Alarm clock.
+sigALRM   :: CInt
+sigALRM   = CONST_SIGALRM
+
+-- | Access to an undefined portion of a memory object.
+sigBUS    :: CInt
+sigBUS    = CONST_SIGBUS
+
+-- | Child process terminated, stopped, or continued.
+sigCHLD   :: CInt
+sigCHLD   = CONST_SIGCHLD
+
+-- | Continue executing, if stopped.
+sigCONT   :: CInt
+sigCONT   = CONST_SIGCONT
+
+-- | Erroneous arithmetic operation.
+sigFPE    :: CInt
+sigFPE    = CONST_SIGFPE
+
+-- | Hangup.
+sigHUP    :: CInt
+sigHUP    = CONST_SIGHUP
+
+-- | Illegal instruction.
+sigILL    :: CInt
+sigILL    = CONST_SIGILL
+
+-- | Terminal interrupt signal.
+sigINT    :: CInt
+sigINT    = CONST_SIGINT
+
+-- | Kill (cannot be caught or ignored).
+sigKILL   :: CInt
+sigKILL   = CONST_SIGKILL
+
+-- | Write on a pipe with no one to read it.
+sigPIPE   :: CInt
+sigPIPE   = CONST_SIGPIPE
+
+-- | Terminal quit signal.
+sigQUIT   :: CInt
+sigQUIT   = CONST_SIGQUIT
+
+-- | Invalid memory reference.
+sigSEGV   :: CInt
+sigSEGV   = CONST_SIGSEGV
+
+-- | Stop executing (cannot be caught or ignored).
+sigSTOP   :: CInt
+sigSTOP   = CONST_SIGSTOP
+
+-- | Termination signal.
+sigTERM   :: CInt
+sigTERM   = CONST_SIGTERM
+
+-- | Terminal stop signal.
+sigTSTP   :: CInt
+sigTSTP   = CONST_SIGTSTP
+
+-- | Background process attempting read.
+sigTTIN   :: CInt
+sigTTIN   = CONST_SIGTTIN
+
+-- | Background process attempting write.
+sigTTOU   :: CInt
+sigTTOU   = CONST_SIGTTOU
+
+-- | User-defined signal 1.
+sigUSR1   :: CInt
+sigUSR1   = CONST_SIGUSR1
+
+-- | User-defined signal 2.
+sigUSR2   :: CInt
+sigUSR2   = CONST_SIGUSR2
+
+#if CONST_SIGPOLL != -1
+-- | Pollable event.
+sigPOLL   :: CInt
+sigPOLL   = CONST_SIGPOLL
+#endif
+
+-- | Profiling timer expired.
+sigPROF   :: CInt
+sigPROF   = CONST_SIGPROF
+
+-- | Bad system call.
+sigSYS    :: CInt
+sigSYS    = CONST_SIGSYS
+
+-- | Trace/breakpoint trap.
+sigTRAP   :: CInt
+sigTRAP   = CONST_SIGTRAP
+
+-- | High bandwidth data is available at a socket.
+sigURG    :: CInt
+sigURG    = CONST_SIGURG
+
+-- | Virtual timer expired.
+sigVTALRM :: CInt
+sigVTALRM = CONST_SIGVTALRM
+
+-- | CPU time limit exceeded.
+sigXCPU   :: CInt
+sigXCPU   = CONST_SIGXCPU
+
+-- | File size limit exceeded.
+sigXFSZ   :: CInt
+sigXFSZ   = CONST_SIGXFSZ
+
+-- | Alias for 'sigABRT'.
+internalAbort ::Signal
+internalAbort = sigABRT
+
+-- | Alias for 'sigALRM'.
+realTimeAlarm :: Signal
+realTimeAlarm = sigALRM
+
+-- | Alias for 'sigBUS'.
+busError :: Signal
+busError = sigBUS
+
+-- | Alias for 'sigCHLD'.
+processStatusChanged :: Signal
+processStatusChanged = sigCHLD
+
+-- | Alias for 'sigCONT'.
+continueProcess :: Signal
+continueProcess = sigCONT
+
+-- | Alias for 'sigFPE'.
+floatingPointException :: Signal
+floatingPointException = sigFPE
+
+-- | Alias for 'sigHUP'.
+lostConnection :: Signal
+lostConnection = sigHUP
+
+-- | Alias for 'sigILL'.
+illegalInstruction :: Signal
+illegalInstruction = sigILL
+
+-- | Alias for 'sigINT'.
+keyboardSignal :: Signal
+keyboardSignal = sigINT
+
+-- | Alias for 'sigKILL'.
+killProcess :: Signal
+killProcess = sigKILL
+
+-- | Alias for 'sigPIPE'.
+openEndedPipe :: Signal
+openEndedPipe = sigPIPE
+
+-- | Alias for 'sigQUIT'.
+keyboardTermination :: Signal
+keyboardTermination = sigQUIT
+
+-- | Alias for 'sigSEGV'.
+segmentationViolation :: Signal
+segmentationViolation = sigSEGV
+
+-- | Alias for 'sigSTOP'.
+softwareStop :: Signal
+softwareStop = sigSTOP
+
+-- | Alias for 'sigTERM'.
+softwareTermination :: Signal
+softwareTermination = sigTERM
+
+-- | Alias for 'sigTSTP'.
+keyboardStop :: Signal
+keyboardStop = sigTSTP
+
+-- | Alias for 'sigTTIN'.
+backgroundRead :: Signal
+backgroundRead = sigTTIN
+
+-- | Alias for 'sigTTOU'.
+backgroundWrite :: Signal
+backgroundWrite = sigTTOU
+
+-- | Alias for 'sigUSR1'.
+userDefinedSignal1 :: Signal
+userDefinedSignal1 = sigUSR1
+
+-- | Alias for 'sigUSR2'.
+userDefinedSignal2 :: Signal
+userDefinedSignal2 = sigUSR2
+
+#if CONST_SIGPOLL != -1
+-- | Alias for 'sigPOLL'.
+pollableEvent :: Signal
+pollableEvent = sigPOLL
+#endif
+
+-- | Alias for 'sigPROF'.
+profilingTimerExpired :: Signal
+profilingTimerExpired = sigPROF
+
+-- | Alias for 'sigSYS'.
+badSystemCall :: Signal
+badSystemCall = sigSYS
+
+-- | Alias for 'sigTRAP'.
+breakpointTrap :: Signal
+breakpointTrap = sigTRAP
+
+-- | Alias for 'sigURG'.
+urgentDataAvailable :: Signal
+urgentDataAvailable = sigURG
+
+-- | Alias for 'sigVTALRM'.
+virtualTimerExpired :: Signal
+virtualTimerExpired = sigVTALRM
+
+-- | Alias for 'sigXCPU'.
+cpuTimeLimitExceeded :: Signal
+cpuTimeLimitExceeded = sigXCPU
+
+-- | Alias for 'sigXFSZ'.
+fileSizeLimitExceeded :: Signal
+fileSizeLimitExceeded = sigXFSZ
+
+-- -----------------------------------------------------------------------------
+-- Signal-related functions
+
+-- | @signalProcess int pid@ calls @kill@ to signal process @pid@
+--   with interrupt signal @int@.
+signalProcess :: Signal -> ProcessID -> IO ()
+signalProcess sig pid
+ = throwErrnoIfMinus1_ "signalProcess" (c_kill pid sig)
+
+foreign import ccall unsafe "kill"
+  c_kill :: CPid -> CInt -> IO CInt
+
+
+-- | @signalProcessGroup int pgid@ calls @kill@ to signal
+--  all processes in group @pgid@ with interrupt signal @int@.
+signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
+signalProcessGroup sig pgid
+  = throwErrnoIfMinus1_ "signalProcessGroup" (c_killpg pgid sig)
+
+foreign import ccall unsafe "killpg"
+  c_killpg :: CPid -> CInt -> IO CInt
+
+-- | @raiseSignal int@ calls @kill@ to signal the current process
+--   with interrupt signal @int@.
+raiseSignal :: Signal -> IO ()
+raiseSignal sig = throwErrnoIfMinus1_ "raiseSignal" (c_raise sig)
+
+-- See also note in GHC's rts/RtsUtils.c
+-- This is somewhat fragile because we need to keep the
+-- `#if`-conditional in sync with GHC's runtime.
+#if (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS) || defined(darwin_HOST_OS))
+foreign import ccall unsafe "genericRaise"
+  c_raise :: CInt -> IO CInt
+#else
+foreign import ccall unsafe "raise"
+  c_raise :: CInt -> IO CInt
+#endif
+
+
+type Signal = CInt
+
+-- | The actions to perform when a signal is received.
+data Handler = Default
+             | Ignore
+             -- not yet: | Hold
+             | Catch (IO ())
+             | CatchOnce (IO ())
+             | CatchInfo (SignalInfo -> IO ())     -- ^ @since 2.7.0.0
+             | CatchInfoOnce (SignalInfo -> IO ()) -- ^ @since 2.7.0.0
+  deriving (Typeable)
+
+-- | Information about a received signal (derived from @siginfo_t@).
+--
+-- @since 2.7.0.0
+data SignalInfo = SignalInfo {
+      siginfoSignal   :: Signal,
+      siginfoError    :: Errno,
+      siginfoSpecific :: SignalSpecificInfo
+  }
+
+-- | Information specific to a particular type of signal
+-- (derived from @siginfo_t@).
+--
+-- @since 2.7.0.0
+data SignalSpecificInfo
+  = NoSignalSpecificInfo
+  | SigChldInfo {
+      siginfoPid    :: ProcessID,
+      siginfoUid    :: UserID,
+      siginfoStatus :: ProcessStatus
+    }
+
+-- | @installHandler int handler iset@ calls @sigaction@ to install an
+--   interrupt handler for signal @int@.  If @handler@ is @Default@,
+--   @SIG_DFL@ is installed; if @handler@ is @Ignore@, @SIG_IGN@ is
+--   installed; if @handler@ is @Catch action@, a handler is installed
+--   which will invoke @action@ in a new thread when (or shortly after) the
+--   signal is received.
+--   If @iset@ is @Just s@, then the @sa_mask@ of the @sigaction@ structure
+--   is set to @s@; otherwise it is cleared.  The previously installed
+--   signal handler for @int@ is returned
+installHandler :: Signal
+               -> Handler
+               -> Maybe SignalSet       -- ^ other signals to block
+               -> IO Handler            -- ^ old handler
+
+#ifdef __PARALLEL_HASKELL__
+installHandler =
+  error "installHandler: not available for Parallel Haskell"
+#else
+
+installHandler sig handler _maybe_mask = do
+  ensureIOManagerIsRunning  -- for the threaded RTS
+
+  -- if we're setting the action to DFL or IGN, we should do that *first*
+  -- if we're setting a handler,
+  --   if the previous action was handle, then setHandler is ok
+  --   if the previous action was IGN/DFL, then setHandler followed by sig_install
+  (old_action, old_handler) <-
+    case handler of
+      Ignore  -> do
+        old_action  <- stg_sig_install sig STG_SIG_IGN nullPtr
+        old_handler <- setHandler sig Nothing
+        return (old_action, old_handler)
+
+      Default -> do
+        old_action  <- stg_sig_install sig STG_SIG_DFL nullPtr
+        old_handler <- setHandler sig Nothing
+        return (old_action, old_handler)
+
+      _some_kind_of_catch -> do
+        -- I don't think it's possible to get CatchOnce right.  If
+        -- there's a signal in flight, then we might run the handler
+        -- more than once.
+        let dyn = toDyn handler
+        old_handler <- case handler of
+            Catch         action -> setHandler sig (Just (const action,dyn))
+            CatchOnce     action -> setHandler sig (Just (const action,dyn))
+            CatchInfo     action -> setHandler sig (Just (getinfo action,dyn))
+            CatchInfoOnce action -> setHandler sig (Just (getinfo action,dyn))
+#if __GLASGOW_HASKELL__ < 811
+            _                    -> error "installHandler"
+#endif
+
+        let action = case handler of
+                Catch _         -> STG_SIG_HAN
+                CatchOnce _     -> STG_SIG_RST
+                CatchInfo _     -> STG_SIG_HAN
+                CatchInfoOnce _ -> STG_SIG_RST
+#if __GLASGOW_HASKELL__ < 811
+                _               -> error "installHandler"
+#endif
+
+        old_action <- stg_sig_install sig action nullPtr
+                   -- mask is pointless, so leave it NULL
+
+        return (old_action, old_handler)
+
+  case (old_handler,old_action) of
+    (_,       STG_SIG_DFL) -> return $ Default
+    (_,       STG_SIG_IGN) -> return $ Ignore
+    (Nothing, _)           -> return $ Ignore
+    (Just (_,dyn),  _)
+        | Just h <- fromDynamic dyn  -> return h
+        | Just io <- fromDynamic dyn -> return (Catch io)
+        -- handlers put there by the base package have type IO ()
+        | otherwise                  -> return Default
+
+foreign import ccall unsafe
+  stg_sig_install
+        :: CInt                         -- sig no.
+        -> CInt                         -- action code (STG_SIG_HAN etc.)
+        -> Ptr CSigset                  -- (in, out) blocked
+        -> IO CInt                      -- (ret) old action code
+
+getinfo :: (SignalInfo -> IO ()) -> ForeignPtr Word8 -> IO ()
+getinfo handler fp_info = do
+  si <- unmarshalSigInfo fp_info
+  handler si
+
+unmarshalSigInfo :: ForeignPtr Word8 -> IO SignalInfo
+unmarshalSigInfo fp = do
+  withForeignPtr fp $ \p -> do
+    sig   <- (#peek siginfo_t, si_signo) p
+    errno <- (#peek siginfo_t, si_errno) p
+    extra <- case sig of
+                _ | sig == sigCHLD -> do
+                    pid <- (#peek siginfo_t, si_pid) p
+                    uid <- (#peek siginfo_t, si_uid) p
+                    wstat <- (#peek siginfo_t, si_status) p
+                    pstat <- decipherWaitStatus wstat
+                    return SigChldInfo { siginfoPid = pid,
+                                         siginfoUid = uid,
+                                         siginfoStatus = pstat }
+                _ | otherwise ->
+                    return NoSignalSpecificInfo
+    return
+      SignalInfo {
+        siginfoSignal = sig,
+        siginfoError  = Errno errno,
+        siginfoSpecific = extra }
+
+#endif /* !__PARALLEL_HASKELL__ */
+
+-- -----------------------------------------------------------------------------
+-- Alarms
+
+-- | @scheduleAlarm i@ calls @alarm@ to schedule a real time
+--   alarm at least @i@ seconds in the future.
+scheduleAlarm :: Int -> IO Int
+scheduleAlarm secs = do
+   r <- c_alarm (fromIntegral secs)
+   return (fromIntegral r)
+
+foreign import ccall unsafe "alarm"
+  c_alarm :: CUInt -> IO CUInt
+
+-- -----------------------------------------------------------------------------
+-- The NOCLDSTOP flag
+
+foreign import ccall "&nocldstop" nocldstop :: Ptr Int
+
+-- | Tells the system whether or not to set the @SA_NOCLDSTOP@ flag when
+-- installing new signal handlers.
+setStoppedChildFlag :: Bool -> IO Bool
+setStoppedChildFlag b = do
+    rc <- peek nocldstop
+    poke nocldstop $ fromEnum (not b)
+    return (rc == (0::Int))
+
+-- | Queries the current state of the stopped child flag.
+queryStoppedChildFlag :: IO Bool
+queryStoppedChildFlag = do
+    rc <- peek nocldstop
+    return (rc == (0::Int))
+
+-- -----------------------------------------------------------------------------
+-- Manipulating signal sets
+
+newtype SignalSet = SignalSet (ForeignPtr CSigset)
+
+emptySignalSet :: SignalSet
+emptySignalSet = unsafePerformIO $ do
+  fp <- mallocForeignPtrBytes sizeof_sigset_t
+  throwErrnoIfMinus1_ "emptySignalSet" (withForeignPtr fp $ c_sigemptyset)
+  return (SignalSet fp)
+
+fullSignalSet :: SignalSet
+fullSignalSet = unsafePerformIO $ do
+  fp <- mallocForeignPtrBytes sizeof_sigset_t
+  throwErrnoIfMinus1_ "fullSignalSet" (withForeignPtr fp $ c_sigfillset)
+  return (SignalSet fp)
+
+-- | A set of signals reserved for use by the implementation.  In GHC, this will normally
+-- include either `sigVTALRM` or `sigALRM`.
+reservedSignals :: SignalSet
+reservedSignals = addSignal rtsTimerSignal emptySignalSet
+
+foreign import ccall rtsTimerSignal :: CInt
+
+infixr `addSignal`, `deleteSignal`
+addSignal :: Signal -> SignalSet -> SignalSet
+addSignal sig (SignalSet fp1) = unsafePerformIO $ do
+  fp2 <- mallocForeignPtrBytes sizeof_sigset_t
+  withForeignPtr fp1 $ \p1 ->
+    withForeignPtr fp2 $ \p2 -> do
+      copyBytes p2 p1 sizeof_sigset_t
+      throwErrnoIfMinus1_ "addSignal" (c_sigaddset p2 sig)
+  return (SignalSet fp2)
+
+deleteSignal :: Signal -> SignalSet -> SignalSet
+deleteSignal sig (SignalSet fp1) = unsafePerformIO $ do
+  fp2 <- mallocForeignPtrBytes sizeof_sigset_t
+  withForeignPtr fp1 $ \p1 ->
+    withForeignPtr fp2 $ \p2 -> do
+      copyBytes p2 p1 sizeof_sigset_t
+      throwErrnoIfMinus1_ "deleteSignal" (c_sigdelset p2 sig)
+  return (SignalSet fp2)
+
+inSignalSet :: Signal -> SignalSet -> Bool
+inSignalSet sig (SignalSet fp) = unsafePerformIO $
+  withForeignPtr fp $ \p -> do
+    r <- throwErrnoIfMinus1 "inSignalSet" (c_sigismember p sig)
+    return (r /= 0)
+
+-- | @getSignalMask@ calls @sigprocmask@ to determine the
+--   set of interrupts which are currently being blocked.
+getSignalMask :: IO SignalSet
+getSignalMask = do
+  fp <- mallocForeignPtrBytes sizeof_sigset_t
+  withForeignPtr fp $ \p ->
+    throwErrnoIfMinus1_ "getSignalMask" (c_sigprocmask 0 nullPtr p)
+  return (SignalSet fp)
+
+sigProcMask :: String -> CInt -> SignalSet -> IO ()
+sigProcMask fn how (SignalSet set) =
+  withForeignPtr set $ \p_set ->
+    throwErrnoIfMinus1_ fn (c_sigprocmask how p_set nullPtr)
+
+-- | @setSignalMask mask@ calls @sigprocmask@ with
+--   @SIG_SETMASK@ to block all interrupts in @mask@.
+setSignalMask :: SignalSet -> IO ()
+setSignalMask set = sigProcMask "setSignalMask" (CONST_SIG_SETMASK :: CInt) set
+
+-- | @blockSignals mask@ calls @sigprocmask@ with
+--   @SIG_BLOCK@ to add all interrupts in @mask@ to the
+--  set of blocked interrupts.
+blockSignals :: SignalSet -> IO ()
+blockSignals set = sigProcMask "blockSignals" (CONST_SIG_BLOCK :: CInt) set
+
+-- | @unblockSignals mask@ calls @sigprocmask@ with
+--   @SIG_UNBLOCK@ to remove all interrupts in @mask@ from the
+--   set of blocked interrupts.
+unblockSignals :: SignalSet -> IO ()
+unblockSignals set = sigProcMask "unblockSignals" (CONST_SIG_UNBLOCK :: CInt) set
+
+-- | @getPendingSignals@ calls @sigpending@ to obtain
+--   the set of interrupts which have been received but are currently blocked.
+getPendingSignals :: IO SignalSet
+getPendingSignals = do
+  fp <- mallocForeignPtrBytes sizeof_sigset_t
+  withForeignPtr fp $ \p ->
+   throwErrnoIfMinus1_ "getPendingSignals" (c_sigpending p)
+  return (SignalSet fp)
+
+-- | @awaitSignal iset@ suspends execution until an interrupt is received.
+-- If @iset@ is @Just s@, @awaitSignal@ calls @sigsuspend@, installing
+-- @s@ as the new signal mask before suspending execution; otherwise, it
+-- calls @sigsuspend@ with current signal mask. Note that RTS
+-- scheduler signal (either 'virtualTimerExpired' or 'realTimeAlarm')
+-- could cause premature termination of this call. It might be necessary to block that
+-- signal before invocation of @awaitSignal@ with 'blockSignals' 'reservedSignals'.
+--
+-- @awaitSignal@ returns when signal was received and processed by a
+-- signal handler, or if the signal could not be caught. If you have
+-- installed any signal handlers with @installHandler@, it may be wise
+-- to call @yield@ directly after @awaitSignal@ to ensure that the
+-- signal handler runs as promptly as possible.
+awaitSignal :: Maybe SignalSet -> IO ()
+awaitSignal maybe_sigset = do
+  fp <- case maybe_sigset of
+          Nothing -> do SignalSet fp <- getSignalMask; return fp
+          Just (SignalSet fp) -> return fp
+  withForeignPtr fp $ \p -> do
+  _ <- c_sigsuspend p
+  return ()
+  -- ignore the return value; according to the docs it can only ever be
+  -- (-1) with errno set to EINTR.
+  -- XXX My manpage says it can also return EFAULT. And why is ignoring
+  -- EINTR the right thing to do?
+
+foreign import ccall unsafe "sigsuspend"
+  c_sigsuspend :: Ptr CSigset -> IO CInt
+
+#if defined(darwin_HOST_OS) && __GLASGOW_HASKELL__ < 706
+-- see http://ghc.haskell.org/trac/ghc/ticket/7359#comment:3
+-- To be removed when support for GHC 7.4.x is dropped
+foreign import ccall unsafe "__hscore_sigdelset"
+  c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt
+
+foreign import ccall unsafe "__hscore_sigfillset"
+  c_sigfillset  :: Ptr CSigset -> IO CInt
+
+foreign import ccall unsafe "__hscore_sigismember"
+  c_sigismember :: Ptr CSigset -> CInt -> IO CInt
+#else
+foreign import capi unsafe "signal.h sigdelset"
+  c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt
+
+foreign import capi unsafe "signal.h sigfillset"
+  c_sigfillset  :: Ptr CSigset -> IO CInt
+
+foreign import capi unsafe "signal.h sigismember"
+  c_sigismember :: Ptr CSigset -> CInt -> IO CInt
+#endif
+
+foreign import ccall unsafe "sigpending"
+  c_sigpending :: Ptr CSigset -> IO CInt

unix/System/Posix/Signals/Exts.hsc

@@ -0,0 +1,47 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE Safe #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Signals.Exts
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX, includes Linuxisms/BSDisms)
+--
+-- non-POSIX signal support commonly available
+--
+-----------------------------------------------------------------------------
+
+#include "HsUnixConfig.h"
+##include "HsUnixConfig.h"
+
+#ifdef HAVE_SIGNAL_H
+#include <signal.h>
+#endif
+
+module System.Posix.Signals.Exts (
+  module System.Posix.Signals
+  , sigINFO
+  , sigWINCH
+  , infoEvent
+  , windowChange
+  ) where
+
+import Foreign.C
+import System.Posix.Signals
+
+sigINFO   :: CInt
+sigINFO   = CONST_SIGINFO
+
+sigWINCH   :: CInt
+sigWINCH   = CONST_SIGWINCH
+
+
+infoEvent :: Signal
+infoEvent = sigINFO
+
+windowChange :: Signal
+windowChange = sigWINCH

unix/System/Posix/Temp.hsc

@@ -0,0 +1,124 @@
+{-# LANGUAGE CApiFFI #-}
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Temp
+-- Copyright   :  (c) Volker Stolz <vs@foldr.org>
+--                    Deian Stefan <deian@cs.stanford.edu>
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org, vs@foldr.org, deian@cs.stanford.edu
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX temporary file and directory creation functions.
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Temp (
+        mkstemp, mkstemps, mkdtemp
+    ) where
+
+#include "HsUnix.h"
+
+import Foreign.C
+import System.IO
+#if !HAVE_MKDTEMP
+import System.Posix.Directory (createDirectory)
+#endif
+import System.Posix.IO
+import System.Posix.Types
+import System.Posix.Internals (withFilePath, peekFilePath)
+
+foreign import capi unsafe "HsUnix.h mkstemp"
+  c_mkstemp :: CString -> IO CInt
+
+-- | Make a unique filename and open it for reading\/writing. The returned
+-- 'FilePath' is the (possibly relative) path of the created file, which is
+-- padded with 6 random characters. The argument is the desired prefix of the
+-- filepath of the temporary file to be created.
+--
+-- If you aren't using GHC or Hugs then this function simply wraps mktemp and
+-- so shouldn't be considered safe.
+mkstemp :: String -> IO (FilePath, Handle)
+mkstemp template' = do
+  let template = template' ++ "XXXXXX"
+  withFilePath template $ \ ptr -> do
+    fd <- throwErrnoIfMinus1 "mkstemp" (c_mkstemp ptr)
+    name <- peekFilePath ptr
+    h <- fdToHandle (Fd fd)
+    return (name, h)
+
+#if HAVE_MKSTEMPS
+foreign import capi unsafe "HsUnix.h mkstemps"
+  c_mkstemps :: CString -> CInt -> IO CInt
+#endif
+
+-- | Make a unique filename with a given prefix and suffix and open it for
+-- reading\/writing. The returned 'FilePath' is the (possibly relative) path of
+-- the created file, which contains  6 random characters in between the prefix
+-- and suffix. The first argument is the desired prefix of the filepath of the
+-- temporary file to be created. The second argument is the suffix of the
+-- temporary file to be created.
+--
+-- If you are using as system that doesn't support the mkstemps glibc function
+-- (supported in glibc > 2.11) then this function simply throws an error.
+mkstemps :: String -> String -> IO (FilePath, Handle)
+#if HAVE_MKSTEMPS
+mkstemps prefix suffix = do
+  let template = prefix ++ "XXXXXX" ++ suffix
+      lenOfsuf = (fromIntegral $ length suffix) :: CInt
+  withFilePath template $ \ ptr -> do
+    fd <- throwErrnoIfMinus1 "mkstemps" (c_mkstemps ptr lenOfsuf)
+    name <- peekFilePath ptr
+    h <- fdToHandle (Fd fd)
+    return (name, h)
+#else
+mkstemps = error "System.Posix.Temp.mkstemps: not available on this platform"
+#endif
+
+#if HAVE_MKDTEMP
+foreign import capi unsafe "HsUnix.h mkdtemp"
+  c_mkdtemp :: CString -> IO CString
+#endif
+
+-- | Make a unique directory. The returned 'FilePath' is the path of the
+-- created directory, which is padded with 6 random characters. The argument is
+-- the desired prefix of the filepath of the temporary directory to be created.
+--
+-- If you are using as system that doesn't support the mkdtemp glibc function
+-- (supported in glibc > 2.1.91) then this function uses mktemp and so
+-- shouldn't be considered safe.
+mkdtemp :: String -> IO FilePath
+mkdtemp template' = do
+  let template = template' ++ "XXXXXX"
+#if HAVE_MKDTEMP
+  withFilePath template $ \ ptr -> do
+    _ <- throwErrnoIfNull "mkdtemp" (c_mkdtemp ptr)
+    name <- peekFilePath ptr
+    return name
+#else
+  name <- mktemp template
+  h <- createDirectory name (toEnum 0o700)
+  return name
+#endif
+
+#if !HAVE_MKDTEMP
+
+foreign import ccall unsafe "mktemp"
+  c_mktemp :: CString -> IO CString
+
+-- | Make a unique file name It is required that the template have six trailing
+-- \'X\'s. This function should be considered deprecated.
+{-# WARNING mktemp "This function is unsafe; use mkstemp instead" #-}
+mktemp :: String -> IO String
+mktemp template = do
+  withFilePath template $ \ ptr -> do
+    ptr <- throwErrnoIfNull "mktemp" (c_mktemp ptr)
+    peekFilePath ptr
+#endif
+

unix/System/Posix/Temp/ByteString.hsc

@@ -0,0 +1,124 @@
+{-# LANGUAGE CApiFFI #-}
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Temp.ByteString
+-- Copyright   :  (c) Volker Stolz <vs@foldr.org>
+--                    Deian Stefan <deian@cs.stanford.edu>
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org, vs@foldr.org, deian@cs.stanford.edu
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX temporary file and directory creation functions.
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Temp.ByteString (
+        mkstemp, mkstemps, mkdtemp
+    ) where
+
+#include "HsUnix.h"
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+
+import Foreign.C
+
+import System.IO
+import System.Posix.ByteString.FilePath
+#if !HAVE_MKDTEMP
+import System.Posix.Directory (createDirectory)
+#endif
+import System.Posix.IO
+import System.Posix.Types
+
+foreign import capi unsafe "HsUnix.h mkstemp"
+  c_mkstemp :: CString -> IO CInt
+
+-- | Make a unique filename and open it for reading\/writing. The returned
+-- 'RawFilePath' is the (possibly relative) path of the created file, which is
+-- padded with 6 random characters. The argument is the desired prefix of the
+-- filepath of the temporary file to be created.
+--
+-- If you aren't using GHC or Hugs then this function simply wraps mktemp and
+-- so shouldn't be considered safe.
+mkstemp :: ByteString -> IO (RawFilePath, Handle)
+mkstemp template' = do
+  let template = template' `B.append` (BC.pack "XXXXXX")
+  withFilePath template $ \ ptr -> do
+    fd <- throwErrnoIfMinus1 "mkstemp" (c_mkstemp ptr)
+    name <- peekFilePath ptr
+    h <- fdToHandle (Fd fd)
+    return (name, h)
+
+#if HAVE_MKSTEMPS
+foreign import capi unsafe "HsUnix.h mkstemps"
+  c_mkstemps :: CString -> CInt -> IO CInt
+#endif
+
+-- |'mkstemps' - make a unique filename with a given prefix and suffix
+-- and open it for reading\/writing (only safe on GHC & Hugs).
+-- The returned 'RawFilePath' is the (possibly relative) path of
+-- the created file, which contains  6 random characters in between
+-- the prefix and suffix.
+mkstemps :: ByteString -> ByteString -> IO (RawFilePath, Handle)
+#if HAVE_MKSTEMPS
+mkstemps prefix suffix = do
+  let template = prefix `B.append` (BC.pack "XXXXXX") `B.append` suffix
+      lenOfsuf = (fromIntegral $ B.length suffix) :: CInt
+  withFilePath template $ \ ptr -> do
+    fd <- throwErrnoIfMinus1 "mkstemps" (c_mkstemps ptr lenOfsuf)
+    name <- peekFilePath ptr
+    h <- fdToHandle (Fd fd)
+    return (name, h)
+#else
+mkstemps = error "System.Posix.Temp.mkstemps: not available on this platform"
+#endif
+
+#if HAVE_MKDTEMP
+foreign import capi unsafe "HsUnix.h mkdtemp"
+  c_mkdtemp :: CString -> IO CString
+#endif
+
+-- | Make a unique directory. The returned 'RawFilePath' is the path of the
+-- created directory, which is padded with 6 random characters. The argument is
+-- the desired prefix of the filepath of the temporary directory to be created.
+--
+-- If you aren't using GHC or Hugs then this function simply wraps mktemp and
+-- so shouldn't be considered safe.
+mkdtemp :: ByteString -> IO RawFilePath
+mkdtemp template' = do
+  let template = template' `B.append` (BC.pack "XXXXXX")
+#if HAVE_MKDTEMP
+  withFilePath template $ \ ptr -> do
+    _ <- throwErrnoIfNull "mkdtemp" (c_mkdtemp ptr)
+    name <- peekFilePath ptr
+    return name
+#else
+  name <- mktemp template
+  h <- createDirectory (BC.unpack name) (toEnum 0o700)
+  return name
+#endif
+
+#if !HAVE_MKDTEMP
+
+foreign import ccall unsafe "mktemp"
+  c_mktemp :: CString -> IO CString
+
+-- | Make a unique file name It is required that the template have six trailing
+-- \'X\'s. This function should be considered deprecated.
+{-# WARNING mktemp "This function is unsafe; use mkstemp instead" #-}
+mktemp :: ByteString -> IO RawFilePath
+mktemp template = do
+  withFilePath template $ \ ptr -> do
+    ptr <- throwErrnoIfNull "mktemp" (c_mktemp ptr)
+    peekFilePath ptr
+#endif
+

unix/System/Posix/Terminal.hsc

@@ -0,0 +1,219 @@
+{-# LANGUAGE CApiFFI #-}
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Terminal
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX Terminal support
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Terminal (
+  -- * Terminal support
+
+  -- ** Terminal attributes
+  TerminalAttributes,
+  getTerminalAttributes,
+  TerminalState(..),
+  setTerminalAttributes,
+
+  TerminalMode(..),
+  withoutMode,
+  withMode,
+  terminalMode,
+  bitsPerByte,
+  withBits,
+
+  ControlCharacter(..),
+  controlChar,
+  withCC,
+  withoutCC,
+
+  inputTime,
+  withTime,
+  minInput,
+  withMinInput,
+
+  BaudRate(..),
+  inputSpeed,
+  withInputSpeed,
+  outputSpeed,
+  withOutputSpeed,
+
+  -- ** Terminal operations
+  sendBreak,
+  drainOutput,
+  QueueSelector(..),
+  discardData,
+  FlowAction(..),
+  controlFlow,
+
+  -- ** Process groups
+  getTerminalProcessGroupID,
+  setTerminalProcessGroupID,
+
+  -- ** Testing a file descriptor
+  queryTerminal,
+  getTerminalName,
+  getControllingTerminalName,
+
+  -- ** Pseudoterminal operations
+  openPseudoTerminal,
+  getSlaveTerminalName
+  ) where
+
+#include "HsUnix.h"
+
+import Foreign
+import Foreign.C
+import System.Posix.Terminal.Common
+import System.Posix.Types
+#ifndef HAVE_OPENPTY
+import System.Posix.IO
+#endif
+
+import System.Posix.Internals (peekFilePath)
+
+#if !HAVE_CTERMID
+import System.IO.Error ( ioeSetLocation )
+import GHC.IO.Exception ( unsupportedOperation )
+#endif
+
+-- | @getTerminalName fd@ calls @ttyname@ to obtain a name associated
+--   with the terminal for @Fd@ @fd@. If @fd@ is associated
+--   with a terminal, @getTerminalName@ returns the name of the
+--   terminal.
+getTerminalName :: Fd -> IO FilePath
+getTerminalName (Fd fd) = do
+  s <- throwErrnoIfNull "getTerminalName" (c_ttyname fd)
+  peekFilePath s
+
+foreign import ccall unsafe "ttyname"
+  c_ttyname :: CInt -> IO CString
+
+-- | @getControllingTerminalName@ calls @ctermid@ to obtain
+--   a name associated with the controlling terminal for the process.  If a
+--   controlling terminal exists,
+--   @getControllingTerminalName@ returns the name of the
+--   controlling terminal.
+--
+-- Throws 'IOError' (\"unsupported operation\") if platform does not
+-- provide @ctermid(3)@ (use @#if HAVE_CTERMID@ CPP guard to
+-- detect availability).
+getControllingTerminalName :: IO FilePath
+#if HAVE_CTERMID
+getControllingTerminalName = do
+  s <- throwErrnoIfNull "getControllingTerminalName" (c_ctermid nullPtr)
+  peekFilePath s
+
+foreign import capi unsafe "termios.h ctermid"
+  c_ctermid :: CString -> IO CString
+#else
+{-# WARNING getControllingTerminalName
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_CTERMID@)" #-}
+getControllingTerminalName = ioError (ioeSetLocation unsupportedOperation "getControllingTerminalName")
+#endif
+
+-- | @getSlaveTerminalName@ calls @ptsname@ to obtain the name of the
+-- slave terminal associated with a pseudoterminal pair.  The file
+-- descriptor to pass in must be that of the master.
+getSlaveTerminalName :: Fd -> IO FilePath
+
+#ifdef HAVE_PTSNAME
+getSlaveTerminalName (Fd fd) = do
+  s <- throwErrnoIfNull "getSlaveTerminalName" (c_ptsname fd)
+  peekFilePath s
+
+# if __GLASGOW_HASKELL__ < 800
+-- see comment in cbits/HsUnix.c
+foreign import ccall unsafe "__hsunix_ptsname"
+  c_ptsname :: CInt -> IO CString
+# else
+foreign import capi unsafe "HsUnix.h ptsname"
+  c_ptsname :: CInt -> IO CString
+# endif
+#else
+getSlaveTerminalName _ =
+    ioError (errnoToIOError "getSlaveTerminalName" eNOSYS Nothing Nothing)
+#endif
+
+-- -----------------------------------------------------------------------------
+-- openPseudoTerminal needs to be here because it depends on
+-- getSlaveTerminalName.
+
+-- | @openPseudoTerminal@ creates a pseudoterminal (pty) pair, and
+-- returns the newly created pair as a (@master@, @slave@) tuple.
+openPseudoTerminal :: IO (Fd, Fd)
+
+#ifdef HAVE_OPENPTY
+openPseudoTerminal =
+  alloca $ \p_master ->
+    alloca $ \p_slave -> do
+      throwErrnoIfMinus1_ "openPty"
+          (c_openpty p_master p_slave nullPtr nullPtr nullPtr)
+      master <- peek p_master
+      slave <- peek p_slave
+      return (Fd master, Fd slave)
+
+foreign import ccall unsafe "openpty"
+  c_openpty :: Ptr CInt -> Ptr CInt -> CString -> Ptr CTermios -> Ptr a
+            -> IO CInt
+#else
+openPseudoTerminal = do
+  (Fd master) <- openFd "/dev/ptmx" ReadWrite Nothing
+                        defaultFileFlags{noctty=True}
+  throwErrnoIfMinus1_ "openPseudoTerminal" (c_grantpt master)
+  throwErrnoIfMinus1_ "openPseudoTerminal" (c_unlockpt master)
+  slaveName <- getSlaveTerminalName (Fd master)
+  slave <- openFd slaveName ReadWrite Nothing defaultFileFlags{noctty=True}
+  pushModule slave "ptem"
+  pushModule slave "ldterm"
+# ifndef __hpux
+  pushModule slave "ttcompat"
+# endif /* __hpux */
+  return (Fd master, slave)
+
+-- Push a STREAMS module, for System V systems.
+pushModule :: Fd -> String -> IO ()
+pushModule (Fd fd) name =
+  withCString name $ \p_name ->
+    throwErrnoIfMinus1_ "openPseudoTerminal"
+                        (c_push_module fd p_name)
+
+foreign import ccall unsafe "__hsunix_push_module"
+  c_push_module :: CInt -> CString -> IO CInt
+
+#ifdef HAVE_PTSNAME
+# if __GLASGOW_HASKELL__ < 800
+-- see comment in cbits/HsUnix.c
+foreign import ccall unsafe "__hsunix_grantpt"
+  c_grantpt :: CInt -> IO CInt
+
+foreign import ccall unsafe "__hsunix_unlockpt"
+  c_unlockpt :: CInt -> IO CInt
+# else
+foreign import capi unsafe "HsUnix.h grantpt"
+  c_grantpt :: CInt -> IO CInt
+
+foreign import capi unsafe "HsUnix.h unlockpt"
+  c_unlockpt :: CInt -> IO CInt
+# endif
+#else
+c_grantpt :: CInt -> IO CInt
+c_grantpt _ = return (fromIntegral 0)
+
+c_unlockpt :: CInt -> IO CInt
+c_unlockpt _ = return (fromIntegral 0)
+#endif /* HAVE_PTSNAME */
+#endif /* !HAVE_OPENPTY */
+

unix/System/Posix/Terminal/ByteString.hsc

@@ -0,0 +1,226 @@
+{-# LANGUAGE CApiFFI #-}
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Terminal.ByteString
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX Terminal support
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Terminal.ByteString (
+  -- * Terminal support
+
+  -- ** Terminal attributes
+  TerminalAttributes,
+  getTerminalAttributes,
+  TerminalState(..),
+  setTerminalAttributes,
+
+  TerminalMode(..),
+  withoutMode,
+  withMode,
+  terminalMode,
+  bitsPerByte,
+  withBits,
+
+  ControlCharacter(..),
+  controlChar,
+  withCC,
+  withoutCC,
+
+  inputTime,
+  withTime,
+  minInput,
+  withMinInput,
+
+  BaudRate(..),
+  inputSpeed,
+  withInputSpeed,
+  outputSpeed,
+  withOutputSpeed,
+
+  -- ** Terminal operations
+  sendBreak,
+  drainOutput,
+  QueueSelector(..),
+  discardData,
+  FlowAction(..),
+  controlFlow,
+
+  -- ** Process groups
+  getTerminalProcessGroupID,
+  setTerminalProcessGroupID,
+
+  -- ** Testing a file descriptor
+  queryTerminal,
+  getTerminalName,
+  getControllingTerminalName,
+
+  -- ** Pseudoterminal operations
+  openPseudoTerminal,
+  getSlaveTerminalName
+  ) where
+
+#include "HsUnix.h"
+
+import Foreign
+import System.Posix.Types
+import System.Posix.Terminal.Common
+#ifndef HAVE_OPENPTY
+import System.Posix.IO.ByteString (defaultFileFlags, openFd, noctty, OpenMode(ReadWrite))
+import Data.ByteString.Char8 as B ( pack, )
+#endif
+
+import Foreign.C hiding (
+     throwErrnoPath,
+     throwErrnoPathIf,
+     throwErrnoPathIf_,
+     throwErrnoPathIfNull,
+     throwErrnoPathIfMinus1,
+     throwErrnoPathIfMinus1_ )
+
+import System.Posix.ByteString.FilePath
+
+#if !HAVE_CTERMID
+import System.IO.Error ( ioeSetLocation )
+import GHC.IO.Exception ( unsupportedOperation )
+#endif
+
+-- | @getTerminalName fd@ calls @ttyname@ to obtain a name associated
+--   with the terminal for @Fd@ @fd@. If @fd@ is associated
+--   with a terminal, @getTerminalName@ returns the name of the
+--   terminal.
+getTerminalName :: Fd -> IO RawFilePath
+getTerminalName (Fd fd) = do
+  s <- throwErrnoIfNull "getTerminalName" (c_ttyname fd)
+  peekFilePath s
+
+foreign import ccall unsafe "ttyname"
+  c_ttyname :: CInt -> IO CString
+
+-- | @getControllingTerminalName@ calls @ctermid@ to obtain
+--   a name associated with the controlling terminal for the process.  If a
+--   controlling terminal exists,
+--   @getControllingTerminalName@ returns the name of the
+--   controlling terminal.
+--
+-- Throws 'IOError' (\"unsupported operation\") if platform does not
+-- provide @ctermid(3)@ (use @#if HAVE_CTERMID@ CPP guard to
+-- detect availability).
+getControllingTerminalName :: IO RawFilePath
+#if HAVE_CTERMID
+getControllingTerminalName = do
+  s <- throwErrnoIfNull "getControllingTerminalName" (c_ctermid nullPtr)
+  peekFilePath s
+
+foreign import capi unsafe "termios.h ctermid"
+  c_ctermid :: CString -> IO CString
+#else
+{-# WARNING getControllingTerminalName
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_CTERMID@)" #-}
+getControllingTerminalName = ioError (ioeSetLocation unsupportedOperation "getControllingTerminalName")
+#endif
+
+-- | @getSlaveTerminalName@ calls @ptsname@ to obtain the name of the
+-- slave terminal associated with a pseudoterminal pair.  The file
+-- descriptor to pass in must be that of the master.
+getSlaveTerminalName :: Fd -> IO RawFilePath
+
+#ifdef HAVE_PTSNAME
+getSlaveTerminalName (Fd fd) = do
+  s <- throwErrnoIfNull "getSlaveTerminalName" (c_ptsname fd)
+  peekFilePath s
+
+# if __GLASGOW_HASKELL__ < 800
+-- see comment in cbits/HsUnix.c
+foreign import ccall unsafe "__hsunix_ptsname"
+  c_ptsname :: CInt -> IO CString
+# else
+foreign import capi unsafe "HsUnix.h ptsname"
+  c_ptsname :: CInt -> IO CString
+# endif
+#else
+getSlaveTerminalName _ =
+    ioError (errnoToIOError "getSlaveTerminalName" eNOSYS Nothing Nothing)
+#endif
+
+-- -----------------------------------------------------------------------------
+-- openPseudoTerminal needs to be here because it depends on
+-- getSlaveTerminalName.
+
+-- | @openPseudoTerminal@ creates a pseudoterminal (pty) pair, and
+-- returns the newly created pair as a (@master@, @slave@) tuple.
+openPseudoTerminal :: IO (Fd, Fd)
+
+#ifdef HAVE_OPENPTY
+openPseudoTerminal =
+  alloca $ \p_master ->
+    alloca $ \p_slave -> do
+      throwErrnoIfMinus1_ "openPty"
+          (c_openpty p_master p_slave nullPtr nullPtr nullPtr)
+      master <- peek p_master
+      slave <- peek p_slave
+      return (Fd master, Fd slave)
+
+foreign import ccall unsafe "openpty"
+  c_openpty :: Ptr CInt -> Ptr CInt -> CString -> Ptr CTermios -> Ptr a
+            -> IO CInt
+#else
+openPseudoTerminal = do
+  (Fd master) <- openFd (B.pack "/dev/ptmx") ReadWrite Nothing
+                        defaultFileFlags{noctty=True}
+  throwErrnoIfMinus1_ "openPseudoTerminal" (c_grantpt master)
+  throwErrnoIfMinus1_ "openPseudoTerminal" (c_unlockpt master)
+  slaveName <- getSlaveTerminalName (Fd master)
+  slave <- openFd slaveName ReadWrite Nothing defaultFileFlags{noctty=True}
+  pushModule slave "ptem"
+  pushModule slave "ldterm"
+# ifndef __hpux
+  pushModule slave "ttcompat"
+# endif /* __hpux */
+  return (Fd master, slave)
+
+-- Push a STREAMS module, for System V systems.
+pushModule :: Fd -> String -> IO ()
+pushModule (Fd fd) name =
+  withCString name $ \p_name ->
+    throwErrnoIfMinus1_ "openPseudoTerminal"
+                        (c_push_module fd p_name)
+
+foreign import ccall unsafe "__hsunix_push_module"
+  c_push_module :: CInt -> CString -> IO CInt
+
+#if HAVE_PTSNAME
+# if __GLASGOW_HASKELL__ < 800
+-- see comment in cbits/HsUnix.c
+foreign import ccall unsafe "__hsunix_grantpt"
+  c_grantpt :: CInt -> IO CInt
+
+foreign import ccall unsafe "__hsunix_unlockpt"
+  c_unlockpt :: CInt -> IO CInt
+# else
+foreign import capi unsafe "HsUnix.h grantpt"
+  c_grantpt :: CInt -> IO CInt
+
+foreign import capi unsafe "HsUnix.h unlockpt"
+  c_unlockpt :: CInt -> IO CInt
+# endif
+#else
+c_grantpt :: CInt -> IO CInt
+c_grantpt _ = return (fromIntegral (0::Int))
+
+c_unlockpt :: CInt -> IO CInt
+c_unlockpt _ = return (fromIntegral (0::Int))
+#endif /* HAVE_PTSNAME */
+#endif /* !HAVE_OPENPTY */

unix/System/Posix/Terminal/Common.hsc

@@ -0,0 +1,881 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE Trustworthy #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Terminal.Common
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX Terminal support
+--
+-----------------------------------------------------------------------------
+
+-- see https://android.googlesource.com/platform/bionic/+/9ae59c0/libc/bionic/pathconf.c#37
+#if !defined(_POSIX_VDISABLE) && defined(__ANDROID__)
+#define _POSIX_VDISABLE -1
+#endif
+
+
+module System.Posix.Terminal.Common (
+  -- * Terminal support
+
+  -- ** Terminal attributes
+  TerminalAttributes,
+  getTerminalAttributes,
+  TerminalState(..),
+  setTerminalAttributes,
+
+  CTermios,
+  TerminalMode(..),
+  withoutMode,
+  withMode,
+  terminalMode,
+  bitsPerByte,
+  withBits,
+
+  ControlCharacter(..),
+  controlChar,
+  withCC,
+  withoutCC,
+
+  inputTime,
+  withTime,
+  minInput,
+  withMinInput,
+
+  BaudRate(..),
+  inputSpeed,
+  withInputSpeed,
+  outputSpeed,
+  withOutputSpeed,
+
+  -- ** Terminal operations
+  sendBreak,
+  drainOutput,
+  QueueSelector(..),
+  discardData,
+  FlowAction(..),
+  controlFlow,
+
+  -- ** Process groups
+  getTerminalProcessGroupID,
+  setTerminalProcessGroupID,
+
+  -- ** Testing a file descriptor
+  queryTerminal,
+  ) where
+
+#include "HsUnix.h"
+
+import Data.Bits
+import Data.Char
+import Foreign.C.Error ( throwErrnoIfMinus1, throwErrnoIfMinus1_ )
+import Foreign.C.Types
+import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, mallocForeignPtrBytes )
+import Foreign.Marshal.Utils ( copyBytes )
+import Foreign.Ptr ( Ptr, plusPtr )
+import Foreign.Storable ( Storable(..) )
+import System.IO.Unsafe ( unsafePerformIO )
+import System.Posix.Types
+import System.Posix.Internals ( CTermios )
+
+#if !HAVE_TCDRAIN
+import System.IO.Error ( ioeSetLocation )
+import GHC.IO.Exception ( unsupportedOperation )
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Terminal attributes
+
+newtype TerminalAttributes = TerminalAttributes (ForeignPtr CTermios)
+
+makeTerminalAttributes :: ForeignPtr CTermios -> TerminalAttributes
+makeTerminalAttributes = TerminalAttributes
+
+withTerminalAttributes :: TerminalAttributes -> (Ptr CTermios -> IO a) -> IO a
+withTerminalAttributes (TerminalAttributes termios) = withForeignPtr termios
+
+
+data TerminalMode
+        -- input flags
+   = InterruptOnBreak           -- ^ @BRKINT@ - Signal interrupt on break
+   | MapCRtoLF                  -- ^ @ICRNL@ - Map CR to NL on input
+   | IgnoreBreak                -- ^ @IGNBRK@ - Ignore break condition
+   | IgnoreCR                   -- ^ @IGNCR@ - Ignore CR
+   | IgnoreParityErrors         -- ^ @IGNPAR@ - Ignore characters with parity errors
+   | MapLFtoCR                  -- ^ @INLCR@ - Map NL to CR on input
+   | CheckParity                -- ^ @INPCK@ - Enable input parity check
+   | StripHighBit               -- ^ @ISTRIP@ - Strip character
+   | RestartOnAny               -- ^ @IXANY@ - Enable any character to restart output
+   | StartStopInput             -- ^ @IXOFF@ - Enable start/stop input control
+   | StartStopOutput            -- ^ @IXON@ - Enable start/stop output control
+   | MarkParityErrors           -- ^ @PARMRK@ - Mark parity errors
+
+        -- output flags
+   | ProcessOutput              -- ^ @OPOST@ - Post-process output
+   | MapLFtoCRLF                -- ^ @ONLCR@ - (XSI) Map NL to CR-NL on output
+                                --
+                                -- @since 2.8.0.0
+   | OutputMapCRtoLF            -- ^ @OCRNL@ - (XSI) Map CR to NL on output
+                                --
+                                -- @since 2.8.0.0
+   | NoCRAtColumnZero           -- ^ @ONOCR@ - (XSI) No CR output at column 0
+                                --
+                                -- @since 2.8.0.0
+   | ReturnMeansLF              -- ^ @ONLRET@ - (XSI) NL performs CR function
+                                --
+                                -- @since 2.8.0.0
+   | TabDelayMask0              -- ^ @TABDLY(TAB0)@ - (XSI) Select horizontal-tab delays: type 0
+                                --
+                                -- @since 2.8.0.0
+   | TabDelayMask3              -- ^ @TABDLY(TAB3)@ - (XSI) Select horizontal-tab delays: type 3
+                                --
+                                -- @since 2.8.0.0
+
+        -- control flags
+   | LocalMode                  -- ^ @CLOCAL@ - Ignore modem status lines
+   | ReadEnable                 -- ^ @CREAD@ - Enable receiver
+   | TwoStopBits                -- ^ @CSTOPB@ - Send two stop bits, else one
+   | HangupOnClose              -- ^ @HUPCL@ - Hang up on last close
+   | EnableParity               -- ^ @PARENB@ - Parity enable
+   | OddParity                  -- ^ @PARODD@ - Odd parity, else even
+
+        -- local modes
+   | EnableEcho                 -- ^ @ECHO@ - Enable echo
+   | EchoErase                  -- ^ @ECHOE@ - Echo erase character as error-correcting backspace
+   | EchoKill                   -- ^ @ECHOK@ - Echo KILL
+   | EchoLF                     -- ^ @ECHONL@ - Echo NL
+   | ProcessInput               -- ^ @ICANON@ - Canonical input (erase and kill processing)
+   | ExtendedFunctions          -- ^ @IEXTEN@ - Enable extended input character processing
+   | KeyboardInterrupts         -- ^ @ISIG@ - Enable signals
+   | NoFlushOnInterrupt         -- ^ @NOFLSH@ - Disable flush after interrupt or quit
+   | BackgroundWriteInterrupt   -- ^ @TOSTOP@ - Send @SIGTTOU@ for background output
+
+withoutMode :: TerminalAttributes -> TerminalMode -> TerminalAttributes
+withoutMode termios InterruptOnBreak = clearInputFlag (#const BRKINT) termios
+withoutMode termios MapCRtoLF = clearInputFlag (#const ICRNL) termios
+withoutMode termios IgnoreBreak = clearInputFlag (#const IGNBRK) termios
+withoutMode termios IgnoreCR = clearInputFlag (#const IGNCR) termios
+withoutMode termios IgnoreParityErrors = clearInputFlag (#const IGNPAR) termios
+withoutMode termios MapLFtoCR = clearInputFlag (#const INLCR) termios
+withoutMode termios CheckParity = clearInputFlag (#const INPCK) termios
+withoutMode termios StripHighBit = clearInputFlag (#const ISTRIP) termios
+withoutMode termios RestartOnAny = clearInputFlag (#const IXANY) termios
+withoutMode termios StartStopInput = clearInputFlag (#const IXOFF) termios
+withoutMode termios StartStopOutput = clearInputFlag (#const IXON) termios
+withoutMode termios MarkParityErrors = clearInputFlag (#const PARMRK) termios
+withoutMode termios ProcessOutput = clearOutputFlag (#const OPOST) termios
+withoutMode termios MapLFtoCRLF = clearOutputFlag (#const ONLCR) termios
+withoutMode termios OutputMapCRtoLF = clearOutputFlag (#const OCRNL) termios
+withoutMode termios NoCRAtColumnZero = clearOutputFlag (#const ONOCR) termios
+withoutMode termios ReturnMeansLF = clearOutputFlag (#const ONLRET) termios
+withoutMode termios TabDelayMask0 = clearOutputFlag (#const TAB0) termios
+withoutMode termios TabDelayMask3 = clearOutputFlag (#const TAB3) termios
+withoutMode termios LocalMode = clearControlFlag (#const CLOCAL) termios
+withoutMode termios ReadEnable = clearControlFlag (#const CREAD) termios
+withoutMode termios TwoStopBits = clearControlFlag (#const CSTOPB) termios
+withoutMode termios HangupOnClose = clearControlFlag (#const HUPCL) termios
+withoutMode termios EnableParity = clearControlFlag (#const PARENB) termios
+withoutMode termios OddParity = clearControlFlag (#const PARODD) termios
+withoutMode termios EnableEcho = clearLocalFlag (#const ECHO) termios
+withoutMode termios EchoErase = clearLocalFlag (#const ECHOE) termios
+withoutMode termios EchoKill = clearLocalFlag (#const ECHOK) termios
+withoutMode termios EchoLF = clearLocalFlag (#const ECHONL) termios
+withoutMode termios ProcessInput = clearLocalFlag (#const ICANON) termios
+withoutMode termios ExtendedFunctions = clearLocalFlag (#const IEXTEN) termios
+withoutMode termios KeyboardInterrupts = clearLocalFlag (#const ISIG) termios
+withoutMode termios NoFlushOnInterrupt = setLocalFlag (#const NOFLSH) termios
+withoutMode termios BackgroundWriteInterrupt = clearLocalFlag (#const TOSTOP) termios
+
+withMode :: TerminalAttributes -> TerminalMode -> TerminalAttributes
+withMode termios InterruptOnBreak = setInputFlag (#const BRKINT) termios
+withMode termios MapCRtoLF = setInputFlag (#const ICRNL) termios
+withMode termios IgnoreBreak = setInputFlag (#const IGNBRK) termios
+withMode termios IgnoreCR = setInputFlag (#const IGNCR) termios
+withMode termios IgnoreParityErrors = setInputFlag (#const IGNPAR) termios
+withMode termios MapLFtoCR = setInputFlag (#const INLCR) termios
+withMode termios CheckParity = setInputFlag (#const INPCK) termios
+withMode termios StripHighBit = setInputFlag (#const ISTRIP) termios
+withMode termios RestartOnAny = setInputFlag (#const IXANY) termios
+withMode termios StartStopInput = setInputFlag (#const IXOFF) termios
+withMode termios StartStopOutput = setInputFlag (#const IXON) termios
+withMode termios MarkParityErrors = setInputFlag (#const PARMRK) termios
+withMode termios ProcessOutput = setOutputFlag (#const OPOST) termios
+withMode termios MapLFtoCRLF = setOutputFlag (#const ONLCR) termios
+withMode termios OutputMapCRtoLF = setOutputFlag (#const OCRNL) termios
+withMode termios NoCRAtColumnZero = setOutputFlag (#const ONOCR) termios
+withMode termios ReturnMeansLF = setOutputFlag (#const ONLRET) termios
+withMode termios TabDelayMask0 = setOutputFlag (#const TAB0) termios
+withMode termios TabDelayMask3 = setOutputFlag (#const TAB3) termios
+withMode termios LocalMode = setControlFlag (#const CLOCAL) termios
+withMode termios ReadEnable = setControlFlag (#const CREAD) termios
+withMode termios TwoStopBits = setControlFlag (#const CSTOPB) termios
+withMode termios HangupOnClose = setControlFlag (#const HUPCL) termios
+withMode termios EnableParity = setControlFlag (#const PARENB) termios
+withMode termios OddParity = setControlFlag (#const PARODD) termios
+withMode termios EnableEcho = setLocalFlag (#const ECHO) termios
+withMode termios EchoErase = setLocalFlag (#const ECHOE) termios
+withMode termios EchoKill = setLocalFlag (#const ECHOK) termios
+withMode termios EchoLF = setLocalFlag (#const ECHONL) termios
+withMode termios ProcessInput = setLocalFlag (#const ICANON) termios
+withMode termios ExtendedFunctions = setLocalFlag (#const IEXTEN) termios
+withMode termios KeyboardInterrupts = setLocalFlag (#const ISIG) termios
+withMode termios NoFlushOnInterrupt = clearLocalFlag (#const NOFLSH) termios
+withMode termios BackgroundWriteInterrupt = setLocalFlag (#const TOSTOP) termios
+
+terminalMode :: TerminalMode -> TerminalAttributes -> Bool
+terminalMode InterruptOnBreak = testInputFlag (#const BRKINT)
+terminalMode MapCRtoLF = testInputFlag (#const ICRNL)
+terminalMode IgnoreBreak = testInputFlag (#const IGNBRK)
+terminalMode IgnoreCR = testInputFlag (#const IGNCR)
+terminalMode IgnoreParityErrors = testInputFlag (#const IGNPAR)
+terminalMode MapLFtoCR = testInputFlag (#const INLCR)
+terminalMode CheckParity = testInputFlag (#const INPCK)
+terminalMode StripHighBit = testInputFlag (#const ISTRIP)
+terminalMode RestartOnAny = testInputFlag (#const IXANY)
+terminalMode StartStopInput = testInputFlag (#const IXOFF)
+terminalMode StartStopOutput = testInputFlag (#const IXON)
+terminalMode MarkParityErrors = testInputFlag (#const PARMRK)
+terminalMode ProcessOutput = testOutputFlag (#const OPOST)
+terminalMode MapLFtoCRLF = testOutputFlag (#const ONLCR)
+terminalMode OutputMapCRtoLF = testOutputFlag (#const OCRNL)
+terminalMode NoCRAtColumnZero = testOutputFlag (#const ONOCR)
+terminalMode ReturnMeansLF = testOutputFlag (#const ONLRET)
+terminalMode TabDelayMask0 = testOutputFlag (#const TAB0)
+terminalMode TabDelayMask3 = testOutputFlag (#const TAB3)
+terminalMode LocalMode = testControlFlag (#const CLOCAL)
+terminalMode ReadEnable = testControlFlag (#const CREAD)
+terminalMode TwoStopBits = testControlFlag (#const CSTOPB)
+terminalMode HangupOnClose = testControlFlag (#const HUPCL)
+terminalMode EnableParity = testControlFlag (#const PARENB)
+terminalMode OddParity = testControlFlag (#const PARODD)
+terminalMode EnableEcho = testLocalFlag (#const ECHO)
+terminalMode EchoErase = testLocalFlag (#const ECHOE)
+terminalMode EchoKill = testLocalFlag (#const ECHOK)
+terminalMode EchoLF = testLocalFlag (#const ECHONL)
+terminalMode ProcessInput = testLocalFlag (#const ICANON)
+terminalMode ExtendedFunctions = testLocalFlag (#const IEXTEN)
+terminalMode KeyboardInterrupts = testLocalFlag (#const ISIG)
+terminalMode NoFlushOnInterrupt = not . testLocalFlag (#const NOFLSH)
+terminalMode BackgroundWriteInterrupt = testLocalFlag (#const TOSTOP)
+
+bitsPerByte :: TerminalAttributes -> Int
+bitsPerByte termios = unsafePerformIO $ do
+  withTerminalAttributes termios $ \p -> do
+    cflag <- (#peek struct termios, c_cflag) p
+    return $! (word2Bits (cflag .&. (#const CSIZE)))
+  where
+    word2Bits :: CTcflag -> Int
+    word2Bits x =
+        if x == (#const CS5) then 5
+        else if x == (#const CS6) then 6
+        else if x == (#const CS7) then 7
+        else if x == (#const CS8) then 8
+        else 0
+
+withBits :: TerminalAttributes -> Int -> TerminalAttributes
+withBits termios bits = unsafePerformIO $ do
+  withNewTermios termios $ \p -> do
+    cflag <- (#peek struct termios, c_cflag) p
+    (#poke struct termios, c_cflag) p
+       ((cflag .&. complement (#const CSIZE)) .|. mask bits)
+  where
+    mask :: Int -> CTcflag
+    mask 5 = (#const CS5)
+    mask 6 = (#const CS6)
+    mask 7 = (#const CS7)
+    mask 8 = (#const CS8)
+    mask _ = error "withBits bit value out of range [5..8]"
+
+data ControlCharacter
+  = EndOfFile           -- VEOF
+  | EndOfLine           -- VEOL
+  | Erase               -- VERASE
+  | Interrupt           -- VINTR
+  | Kill                -- VKILL
+  | Quit                -- VQUIT
+  | Start               -- VSTART
+  | Stop                -- VSTOP
+  | Suspend             -- VSUSP
+
+controlChar :: TerminalAttributes -> ControlCharacter -> Maybe Char
+controlChar termios cc = unsafePerformIO $ do
+  withTerminalAttributes termios $ \p -> do
+    let c_cc = (#ptr struct termios, c_cc) p
+    val <- peekElemOff c_cc (cc2Word cc)
+    if val == ((#const _POSIX_VDISABLE)::CCc)
+       then return Nothing
+       else return (Just (chr (fromEnum val)))
+
+withCC :: TerminalAttributes
+       -> (ControlCharacter, Char)
+       -> TerminalAttributes
+withCC termios (cc, c) = unsafePerformIO $ do
+  withNewTermios termios $ \p -> do
+    let c_cc = (#ptr struct termios, c_cc) p
+    pokeElemOff c_cc (cc2Word cc) (fromIntegral (ord c) :: CCc)
+
+withoutCC :: TerminalAttributes
+          -> ControlCharacter
+          -> TerminalAttributes
+withoutCC termios cc = unsafePerformIO $ do
+  withNewTermios termios $ \p -> do
+    let c_cc = (#ptr struct termios, c_cc) p
+    pokeElemOff c_cc (cc2Word cc) ((#const _POSIX_VDISABLE) :: CCc)
+
+inputTime :: TerminalAttributes -> Int
+inputTime termios = unsafePerformIO $ do
+  withTerminalAttributes termios $ \p -> do
+    c <- peekElemOff ((#ptr struct termios, c_cc) p) (#const VTIME)
+    return (fromEnum (c :: CCc))
+
+withTime :: TerminalAttributes -> Int -> TerminalAttributes
+withTime termios time = unsafePerformIO $ do
+  withNewTermios termios $ \p -> do
+    let c_cc = (#ptr struct termios, c_cc) p
+    pokeElemOff c_cc (#const VTIME) (fromIntegral time :: CCc)
+
+minInput :: TerminalAttributes -> Int
+minInput termios = unsafePerformIO $ do
+  withTerminalAttributes termios $ \p -> do
+    c <- peekElemOff ((#ptr struct termios, c_cc) p) (#const VMIN)
+    return (fromEnum (c :: CCc))
+
+withMinInput :: TerminalAttributes -> Int -> TerminalAttributes
+withMinInput termios count = unsafePerformIO $ do
+  withNewTermios termios $ \p -> do
+    let c_cc = (#ptr struct termios, c_cc) p
+    pokeElemOff c_cc (#const VMIN) (fromIntegral count :: CCc)
+
+data BaudRate
+  -- These are the standard rates stipulated by POSIX:
+  = B0
+  | B50
+  | B75
+  | B110
+  | B134
+  | B150
+  | B200
+  | B300
+  | B600
+  | B1200
+  | B1800
+  | B2400
+  | B4800
+  | B9600
+  | B19200
+  | B38400
+  -- These are non-standard rates that are often present on modern Unixes:
+  | B57600
+  | B115200
+  | B230400
+  | B460800
+  | B500000
+  | B576000
+  | B921600
+  | B1000000
+  | B1152000
+  | B1500000
+  | B2000000
+  | B2500000
+  | B3000000
+  | B3500000
+  | B4000000
+
+inputSpeed :: TerminalAttributes -> BaudRate
+inputSpeed termios = unsafePerformIO $ do
+  withTerminalAttributes termios $ \p -> do
+    w <- c_cfgetispeed p
+    return (word2Baud w)
+
+foreign import capi unsafe "termios.h cfgetispeed"
+  c_cfgetispeed :: Ptr CTermios -> IO CSpeed
+
+withInputSpeed :: TerminalAttributes -> BaudRate -> TerminalAttributes
+withInputSpeed termios br = unsafePerformIO $ do
+  withNewTermios termios $ \p -> c_cfsetispeed p (baud2Word br)
+
+foreign import capi unsafe "termios.h cfsetispeed"
+  c_cfsetispeed :: Ptr CTermios -> CSpeed -> IO CInt
+
+
+outputSpeed :: TerminalAttributes -> BaudRate
+outputSpeed termios = unsafePerformIO $ do
+  withTerminalAttributes termios $ \p ->  do
+    w <- c_cfgetospeed p
+    return (word2Baud w)
+
+foreign import capi unsafe "termios.h cfgetospeed"
+  c_cfgetospeed :: Ptr CTermios -> IO CSpeed
+
+withOutputSpeed :: TerminalAttributes -> BaudRate -> TerminalAttributes
+withOutputSpeed termios br = unsafePerformIO $ do
+  withNewTermios termios $ \p -> c_cfsetospeed p (baud2Word br)
+
+foreign import capi unsafe "termios.h cfsetospeed"
+  c_cfsetospeed :: Ptr CTermios -> CSpeed -> IO CInt
+
+-- | @getTerminalAttributes fd@ calls @tcgetattr@ to obtain
+--   the @TerminalAttributes@ associated with @Fd@ @fd@.
+getTerminalAttributes :: Fd -> IO TerminalAttributes
+getTerminalAttributes (Fd fd) = do
+  fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
+  withForeignPtr fp $ \p ->
+      throwErrnoIfMinus1_ "getTerminalAttributes" (c_tcgetattr fd p)
+  return $ makeTerminalAttributes fp
+
+foreign import capi unsafe "termios.h tcgetattr"
+  c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt
+
+data TerminalState
+  = Immediately
+  | WhenDrained
+  | WhenFlushed
+
+-- | @setTerminalAttributes fd attr ts@ calls @tcsetattr@ to change
+--   the @TerminalAttributes@ associated with @Fd@ @fd@ to
+--   @attr@, when the terminal is in the state indicated by @ts@.
+setTerminalAttributes :: Fd
+                      -> TerminalAttributes
+                      -> TerminalState
+                      -> IO ()
+setTerminalAttributes (Fd fd) termios state = do
+  withTerminalAttributes termios $ \p ->
+    throwErrnoIfMinus1_ "setTerminalAttributes"
+      (c_tcsetattr fd (state2Int state) p)
+  where
+    state2Int :: TerminalState -> CInt
+    state2Int Immediately = (#const TCSANOW)
+    state2Int WhenDrained = (#const TCSADRAIN)
+    state2Int WhenFlushed = (#const TCSAFLUSH)
+
+foreign import capi unsafe "termios.h tcsetattr"
+   c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt
+
+-- | @sendBreak fd duration@ calls @tcsendbreak@ to transmit a
+--   continuous stream of zero-valued bits on @Fd@ @fd@ for the
+--   specified implementation-dependent @duration@.
+sendBreak :: Fd -> Int -> IO ()
+sendBreak (Fd fd) duration
+  = throwErrnoIfMinus1_ "sendBreak" (c_tcsendbreak fd (fromIntegral duration))
+
+foreign import capi unsafe "termios.h tcsendbreak"
+  c_tcsendbreak :: CInt -> CInt -> IO CInt
+
+-- | @drainOutput fd@ calls @tcdrain@ to block until all output
+--   written to @Fd@ @fd@ has been transmitted.
+--
+-- Throws 'IOError' (\"unsupported operation\") if platform does not
+-- provide @tcdrain(3)@ (use @#if HAVE_TCDRAIN@ CPP guard to
+-- detect availability).
+drainOutput :: Fd -> IO ()
+#if HAVE_TCDRAIN
+drainOutput (Fd fd) = throwErrnoIfMinus1_ "drainOutput" (c_tcdrain fd)
+
+foreign import capi safe "termios.h tcdrain"
+  c_tcdrain :: CInt -> IO CInt
+#else
+{-# WARNING drainOutput
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_TCDRAIN@)" #-}
+drainOutput _ = ioError (ioeSetLocation unsupportedOperation "drainOutput")
+#endif
+
+data QueueSelector
+  = InputQueue          -- TCIFLUSH
+  | OutputQueue         -- TCOFLUSH
+  | BothQueues          -- TCIOFLUSH
+
+-- | @discardData fd queues@ calls @tcflush@ to discard
+--   pending input and\/or output for @Fd@ @fd@,
+--   as indicated by the @QueueSelector@ @queues@.
+discardData :: Fd -> QueueSelector -> IO ()
+discardData (Fd fd) queue =
+  throwErrnoIfMinus1_ "discardData" (c_tcflush fd (queue2Int queue))
+  where
+    queue2Int :: QueueSelector -> CInt
+    queue2Int InputQueue  = (#const TCIFLUSH)
+    queue2Int OutputQueue = (#const TCOFLUSH)
+    queue2Int BothQueues  = (#const TCIOFLUSH)
+
+foreign import capi unsafe "termios.h tcflush"
+  c_tcflush :: CInt -> CInt -> IO CInt
+
+data FlowAction
+  = SuspendOutput       -- ^ TCOOFF
+  | RestartOutput       -- ^ TCOON
+  | TransmitStop        -- ^ TCIOFF
+  | TransmitStart       -- ^ TCION
+
+-- | @controlFlow fd action@ calls @tcflow@ to control the
+--   flow of data on @Fd@ @fd@, as indicated by
+--   @action@.
+controlFlow :: Fd -> FlowAction -> IO ()
+controlFlow (Fd fd) action =
+  throwErrnoIfMinus1_ "controlFlow" (c_tcflow fd (action2Int action))
+  where
+    action2Int :: FlowAction -> CInt
+    action2Int SuspendOutput = (#const TCOOFF)
+    action2Int RestartOutput = (#const TCOON)
+    action2Int TransmitStop  = (#const TCIOFF)
+    action2Int TransmitStart = (#const TCION)
+
+foreign import capi unsafe "termios.h tcflow"
+  c_tcflow :: CInt -> CInt -> IO CInt
+
+-- | @getTerminalProcessGroupID fd@ calls @tcgetpgrp@ to
+--   obtain the @ProcessGroupID@ of the foreground process group
+--   associated with the terminal attached to @Fd@ @fd@.
+getTerminalProcessGroupID :: Fd -> IO ProcessGroupID
+getTerminalProcessGroupID (Fd fd) = do
+  throwErrnoIfMinus1 "getTerminalProcessGroupID" (c_tcgetpgrp fd)
+
+foreign import ccall unsafe "tcgetpgrp"
+  c_tcgetpgrp :: CInt -> IO CPid
+
+-- | @setTerminalProcessGroupID fd pgid@ calls @tcsetpgrp@ to
+--   set the @ProcessGroupID@ of the foreground process group
+--   associated with the terminal attached to @Fd@
+--   @fd@ to @pgid@.
+setTerminalProcessGroupID :: Fd -> ProcessGroupID -> IO ()
+setTerminalProcessGroupID (Fd fd) pgid =
+  throwErrnoIfMinus1_ "setTerminalProcessGroupID" (c_tcsetpgrp fd pgid)
+
+foreign import ccall unsafe "tcsetpgrp"
+  c_tcsetpgrp :: CInt -> CPid -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- file descriptor queries
+
+-- | @queryTerminal fd@ calls @isatty@ to determine whether or
+--   not @Fd@ @fd@ is associated with a terminal.
+queryTerminal :: Fd -> IO Bool
+queryTerminal (Fd fd) = do
+  r <- c_isatty fd
+  return (r == 1)
+  -- ToDo: the spec says that it can set errno to EBADF if the result is zero
+
+foreign import ccall unsafe "isatty"
+  c_isatty :: CInt -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- Local utility functions
+
+-- Convert Haskell ControlCharacter to Int
+
+cc2Word :: ControlCharacter -> Int
+cc2Word EndOfFile = (#const VEOF)
+cc2Word EndOfLine = (#const VEOL)
+cc2Word Erase     = (#const VERASE)
+cc2Word Interrupt = (#const VINTR)
+cc2Word Kill      = (#const VKILL)
+cc2Word Quit      = (#const VQUIT)
+cc2Word Suspend   = (#const VSUSP)
+cc2Word Start     = (#const VSTART)
+cc2Word Stop      = (#const VSTOP)
+
+-- Convert Haskell BaudRate to unsigned integral type (Word)
+
+baud2Word :: BaudRate -> CSpeed
+baud2Word B0 = (#const B0)
+baud2Word B50 = (#const B50)
+baud2Word B75 = (#const B75)
+baud2Word B110 = (#const B110)
+baud2Word B134 = (#const B134)
+baud2Word B150 = (#const B150)
+baud2Word B200 = (#const B200)
+baud2Word B300 = (#const B300)
+baud2Word B600 = (#const B600)
+baud2Word B1200 = (#const B1200)
+baud2Word B1800 = (#const B1800)
+baud2Word B2400 = (#const B2400)
+baud2Word B4800 = (#const B4800)
+baud2Word B9600 = (#const B9600)
+baud2Word B19200 = (#const B19200)
+baud2Word B38400 = (#const B38400)
+#ifdef B57600
+baud2Word B57600 = (#const B57600)
+#else
+baud2Word B57600 = error "B57600 not available on this system"
+#endif
+#ifdef B115200
+baud2Word B115200 = (#const B115200)
+#else
+baud2Word B115200 = error "B115200 not available on this system"
+#endif
+#ifdef B230400
+baud2Word B230400 = (#const B230400)
+#else
+baud2Word B230400 = error "B230400 not available on this system"
+#endif
+#ifdef B460800
+baud2Word B460800 = (#const B460800)
+#else
+baud2Word B460800 = error "B460800 not available on this system"
+#endif
+#ifdef B500000
+baud2Word B500000 = (#const B500000)
+#else
+baud2Word B500000 = error "B500000 not available on this system"
+#endif
+#ifdef B576000
+baud2Word B576000 = (#const B576000)
+#else
+baud2Word B576000 = error "B576000 not available on this system"
+#endif
+#ifdef B921600
+baud2Word B921600 = (#const B921600)
+#else
+baud2Word B921600 = error "B921600 not available on this system"
+#endif
+#ifdef B1000000
+baud2Word B1000000 = (#const B1000000)
+#else
+baud2Word B1000000 = error "B1000000 not available on this system"
+#endif
+#ifdef B1152000
+baud2Word B1152000 = (#const B1152000)
+#else
+baud2Word B1152000 = error "B1152000 not available on this system"
+#endif
+#ifdef B1500000
+baud2Word B1500000 = (#const B1500000)
+#else
+baud2Word B1500000 = error "B1500000 not available on this system"
+#endif
+#ifdef B2000000
+baud2Word B2000000 = (#const B2000000)
+#else
+baud2Word B2000000 = error "B2000000 not available on this system"
+#endif
+#ifdef B2500000
+baud2Word B2500000 = (#const B2500000)
+#else
+baud2Word B2500000 = error "B2500000 not available on this system"
+#endif
+#ifdef B3000000
+baud2Word B3000000 = (#const B3000000)
+#else
+baud2Word B3000000 = error "B3000000 not available on this system"
+#endif
+#ifdef B3500000
+baud2Word B3500000 = (#const B3500000)
+#else
+baud2Word B3500000 = error "B3500000 not available on this system"
+#endif
+#ifdef B4000000
+baud2Word B4000000 = (#const B4000000)
+#else
+baud2Word B4000000 = error "B4000000 not available on this system"
+#endif
+
+-- And convert a word back to a baud rate
+-- We really need some cpp macros here.
+
+word2Baud :: CSpeed -> BaudRate
+word2Baud x = case x of
+    (#const B0) -> B0
+    (#const B50) -> B50
+    (#const B75) -> B75
+    (#const B110) -> B110
+    (#const B134) -> B134
+    (#const B150) -> B150
+    (#const B200) -> B200
+    (#const B300) -> B300
+    (#const B600) -> B600
+    (#const B1200) -> B1200
+    (#const B1800) -> B1800
+    (#const B2400) -> B2400
+    (#const B4800) -> B4800
+    (#const B9600) -> B9600
+    (#const B19200) -> B19200
+    (#const B38400) -> B38400
+#ifdef B57600
+    (#const B57600) -> B57600
+#endif
+#ifdef B115200
+    (#const B115200) -> B115200
+#endif
+#ifdef B230400
+    (#const B230400) -> B230400
+#endif
+#ifdef B460800
+    (#const B460800) -> B460800
+#endif
+#ifdef B500000
+    (#const B500000) -> B500000
+#endif
+#ifdef B576000
+    (#const B576000) -> B576000
+#endif
+#ifdef B921600
+    (#const B921600) -> B921600
+#endif
+#ifdef B1000000
+    (#const B1000000) -> B1000000
+#endif
+#ifdef B1152000
+    (#const B1152000) -> B1152000
+#endif
+#ifdef B1500000
+    (#const B1500000) -> B1500000
+#endif
+#ifdef B2000000
+    (#const B2000000) -> B2000000
+#endif
+#ifdef B2500000
+    (#const B2500000) -> B2500000
+#endif
+#ifdef B3000000
+    (#const B3000000) -> B3000000
+#endif
+#ifdef B3500000
+    (#const B3500000) -> B3500000
+#endif
+#ifdef B4000000
+    (#const B4000000) -> B4000000
+#endif
+    _                 -> error "unknown baud rate"
+
+-- Clear termios i_flag
+
+clearInputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
+clearInputFlag flag termios = unsafePerformIO $ do
+  fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
+  withForeignPtr fp $ \p1 -> do
+    withTerminalAttributes termios $ \p2 -> do
+      copyBytes p1 p2 (#const sizeof(struct termios))
+      iflag <- (#peek struct termios, c_iflag) p2
+      (#poke struct termios, c_iflag) p1 (iflag .&. complement flag)
+  return $ makeTerminalAttributes fp
+
+-- Set termios i_flag
+
+setInputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
+setInputFlag flag termios = unsafePerformIO $ do
+  fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
+  withForeignPtr fp $ \p1 -> do
+    withTerminalAttributes termios $ \p2 -> do
+      copyBytes p1 p2 (#const sizeof(struct termios))
+      iflag <- (#peek struct termios, c_iflag) p2
+      (#poke struct termios, c_iflag) p1 (iflag .|. flag)
+  return $ makeTerminalAttributes fp
+
+-- Examine termios i_flag
+
+testInputFlag :: CTcflag -> TerminalAttributes -> Bool
+testInputFlag flag termios = unsafePerformIO $
+  withTerminalAttributes termios $ \p ->  do
+    iflag <- (#peek struct termios, c_iflag) p
+    return $! ((iflag .&. flag) /= 0)
+
+-- Clear termios c_flag
+
+clearControlFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
+clearControlFlag flag termios = unsafePerformIO $ do
+  fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
+  withForeignPtr fp $ \p1 -> do
+    withTerminalAttributes termios $ \p2 -> do
+      copyBytes p1 p2 (#const sizeof(struct termios))
+      cflag <- (#peek struct termios, c_cflag) p2
+      (#poke struct termios, c_cflag) p1 (cflag .&. complement flag)
+  return $ makeTerminalAttributes fp
+
+-- Set termios c_flag
+
+setControlFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
+setControlFlag flag termios = unsafePerformIO $ do
+  fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
+  withForeignPtr fp $ \p1 -> do
+    withTerminalAttributes termios $ \p2 -> do
+      copyBytes p1 p2 (#const sizeof(struct termios))
+      cflag <- (#peek struct termios, c_cflag) p2
+      (#poke struct termios, c_cflag) p1 (cflag .|. flag)
+  return $ makeTerminalAttributes fp
+
+-- Examine termios c_flag
+
+testControlFlag :: CTcflag -> TerminalAttributes -> Bool
+testControlFlag flag termios = unsafePerformIO $
+  withTerminalAttributes termios $ \p -> do
+    cflag <- (#peek struct termios, c_cflag) p
+    return $! ((cflag .&. flag) /= 0)
+
+-- Clear termios l_flag
+
+clearLocalFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
+clearLocalFlag flag termios = unsafePerformIO $ do
+  fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
+  withForeignPtr fp $ \p1 -> do
+    withTerminalAttributes termios $ \p2 -> do
+      copyBytes p1 p2 (#const sizeof(struct termios))
+      lflag <- (#peek struct termios, c_lflag) p2
+      (#poke struct termios, c_lflag) p1 (lflag .&. complement flag)
+  return $ makeTerminalAttributes fp
+
+-- Set termios l_flag
+
+setLocalFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
+setLocalFlag flag termios = unsafePerformIO $ do
+  fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
+  withForeignPtr fp $ \p1 -> do
+    withTerminalAttributes termios $ \p2 -> do
+      copyBytes p1 p2 (#const sizeof(struct termios))
+      lflag <- (#peek struct termios, c_lflag) p2
+      (#poke struct termios, c_lflag) p1 (lflag .|. flag)
+  return $ makeTerminalAttributes fp
+
+-- Examine termios l_flag
+
+testLocalFlag :: CTcflag -> TerminalAttributes -> Bool
+testLocalFlag flag termios = unsafePerformIO $
+  withTerminalAttributes termios $ \p ->  do
+    lflag <- (#peek struct termios, c_lflag) p
+    return $! ((lflag .&. flag) /= 0)
+
+-- Clear termios o_flag
+
+clearOutputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
+clearOutputFlag flag termios = unsafePerformIO $ do
+  fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
+  withForeignPtr fp $ \p1 -> do
+    withTerminalAttributes termios $ \p2 -> do
+      copyBytes p1 p2 (#const sizeof(struct termios))
+      oflag <- (#peek struct termios, c_oflag) p2
+      (#poke struct termios, c_oflag) p1 (oflag .&. complement flag)
+  return $ makeTerminalAttributes fp
+
+-- Set termios o_flag
+
+setOutputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
+setOutputFlag flag termios = unsafePerformIO $ do
+  fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
+  withForeignPtr fp $ \p1 -> do
+    withTerminalAttributes termios $ \p2 -> do
+      copyBytes p1 p2 (#const sizeof(struct termios))
+      oflag <- (#peek struct termios, c_oflag) p2
+      (#poke struct termios, c_oflag) p1 (oflag .|. flag)
+  return $ makeTerminalAttributes fp
+
+-- Examine termios o_flag
+
+testOutputFlag :: CTcflag -> TerminalAttributes -> Bool
+testOutputFlag flag termios = unsafePerformIO $
+  withTerminalAttributes termios $ \p -> do
+    oflag <- (#peek struct termios, c_oflag) p
+    return $! ((oflag .&. flag) /= 0)
+
+withNewTermios :: TerminalAttributes -> (Ptr CTermios -> IO a)
+  -> IO TerminalAttributes
+withNewTermios termios action = do
+  fp1 <- mallocForeignPtrBytes (#const sizeof(struct termios))
+  withForeignPtr fp1 $ \p1 -> do
+   withTerminalAttributes termios $ \p2 -> do
+    copyBytes p1 p2 (#const sizeof(struct termios))
+    _ <- action p1
+    return ()
+  return $ makeTerminalAttributes fp1

unix/System/Posix/Time.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Time
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX Time support
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Time (
+        epochTime,
+        -- ToDo: lots more from sys/time.h
+        -- how much already supported by System.Time?
+  ) where
+
+import System.Posix.Types
+import Foreign
+import Foreign.C
+
+-- -----------------------------------------------------------------------------
+-- epochTime
+
+-- | @epochTime@ calls @time@ to obtain the number of
+--   seconds that have elapsed since the epoch (Jan 01 00:00:00 GMT 1970).
+epochTime :: IO EpochTime
+epochTime = throwErrnoIfMinus1 "epochTime" (c_time nullPtr)
+
+foreign import capi unsafe "HsUnix.h time"
+  c_time :: Ptr CTime -> IO CTime

unix/System/Posix/Unistd.hsc

@@ -0,0 +1,264 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Unistd
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX miscellaneous stuff, mostly from unistd.h
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Unistd (
+    -- * System environment
+    SystemID(..),
+    getSystemID,
+
+    SysVar(..),
+    getSysVar,
+
+    -- * Sleeping
+    sleep, usleep, nanosleep,
+
+    -- * File synchronisation
+    fileSynchronise,
+    fileSynchroniseDataOnly,
+
+  {-
+    ToDo from unistd.h:
+      confstr,
+      lots of sysconf variables
+
+    -- use Network.BSD
+    gethostid, gethostname
+
+    -- should be in System.Posix.Files?
+    pathconf, fpathconf,
+
+    -- System.Posix.Signals
+    ualarm,
+
+    -- System.Posix.IO
+    read, write,
+
+    -- should be in System.Posix.User?
+    getEffectiveUserName,
+-}
+  ) where
+
+#include "HsUnix.h"
+
+import Foreign.C.Error
+import Foreign.C.String ( peekCString )
+import Foreign.C.Types
+import Foreign
+import System.Posix.Types
+import System.Posix.Internals
+
+#if !(HAVE_FSYNC && HAVE_FDATASYNC)
+import System.IO.Error ( ioeSetLocation )
+import GHC.IO.Exception ( unsupportedOperation )
+#endif
+
+-- -----------------------------------------------------------------------------
+-- System environment (uname())
+
+data SystemID =
+  SystemID { systemName :: String
+           , nodeName   :: String
+           , release    :: String
+           , version    :: String
+           , machine    :: String
+           }
+
+getSystemID :: IO SystemID
+getSystemID = do
+  allocaBytes (#const sizeof(struct utsname)) $ \p_sid -> do
+    throwErrnoIfMinus1_ "getSystemID" (c_uname p_sid)
+    sysN <- peekCString ((#ptr struct utsname, sysname) p_sid)
+    node <- peekCString ((#ptr struct utsname, nodename) p_sid)
+    rel  <- peekCString ((#ptr struct utsname, release) p_sid)
+    ver  <- peekCString ((#ptr struct utsname, version) p_sid)
+    mach <- peekCString ((#ptr struct utsname, machine) p_sid)
+    return (SystemID { systemName = sysN,
+                       nodeName   = node,
+                       release    = rel,
+                       version    = ver,
+                       machine    = mach
+                     })
+
+foreign import ccall unsafe "uname"
+   c_uname :: Ptr CUtsname -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- sleeping
+
+-- | Sleep for the specified duration (in seconds).  Returns the time remaining
+-- (if the sleep was interrupted by a signal, for example).
+--
+-- /GHC Note/: 'Control.Concurrent.threadDelay' is a better choice.  Since GHC
+-- uses signals for its internal clock, a call to 'sleep' will usually be
+-- interrupted immediately.  That makes 'sleep' unusable in a program compiled
+-- with GHC, unless the RTS timer is disabled (with @+RTS -V0@).  Furthermore,
+-- without the @-threaded@ option, 'sleep' will block all other user threads.
+-- Even with the @-threaded@ option, 'sleep' requires a full OS thread to
+-- itself.  'Control.Concurrent.threadDelay' has none of these shortcomings.
+--
+sleep :: Int -> IO Int
+sleep 0 = return 0
+sleep secs = do r <- c_sleep (fromIntegral secs); return (fromIntegral r)
+
+{-# WARNING sleep "This function has several shortcomings (see documentation). Please consider using Control.Concurrent.threadDelay instead." #-}
+
+foreign import ccall safe "sleep"
+  c_sleep :: CUInt -> IO CUInt
+
+-- | Sleep for the specified duration (in microseconds).
+--
+-- /GHC Note/: 'Control.Concurrent.threadDelay' is a better choice.
+-- Without the @-threaded@ option, 'usleep' will block all other user
+-- threads.  Even with the @-threaded@ option, 'usleep' requires a
+-- full OS thread to itself.  'Control.Concurrent.threadDelay' has
+-- neither of these shortcomings.
+--
+usleep :: Int -> IO ()
+#ifdef HAVE_NANOSLEEP
+usleep usecs = nanosleep (fromIntegral usecs * 1000)
+#else
+usleep 0 = return ()
+#ifdef USLEEP_RETURNS_VOID
+usleep usecs = c_usleep (fromIntegral usecs)
+#else
+usleep usecs = throwErrnoIfMinus1_ "usleep" (c_usleep (fromIntegral usecs))
+#endif
+
+#ifdef USLEEP_RETURNS_VOID
+foreign import ccall safe "usleep"
+  c_usleep :: CUInt -> IO ()
+#else
+foreign import ccall safe "usleep"
+  c_usleep :: CUInt -> IO CInt
+#endif
+#endif /* HAVE_NANOSLEEP */
+
+-- | Sleep for the specified duration (in nanoseconds)
+--
+-- /GHC Note/: the comment for 'usleep' also applies here.
+nanosleep :: Integer -> IO ()
+#ifndef HAVE_NANOSLEEP
+nanosleep = error "nanosleep: not available on this platform"
+#else
+nanosleep 0 = return ()
+nanosleep nsecs = do
+  allocaBytes (#const sizeof(struct timespec)) $ \pts1 -> do
+  allocaBytes (#const sizeof(struct timespec)) $ \pts2 -> do
+     let (tv_sec0, tv_nsec0) = nsecs `divMod` 1000000000
+     let
+       loop tv_sec tv_nsec = do
+         (#poke struct timespec, tv_sec)  pts1 tv_sec
+         (#poke struct timespec, tv_nsec) pts1 tv_nsec
+         res <- c_nanosleep pts1 pts2
+         if res == 0
+            then return ()
+            else do errno <- getErrno
+                    if errno == eINTR
+                       then do
+                           tv_sec'  <- (#peek struct timespec, tv_sec)  pts2
+                           tv_nsec' <- (#peek struct timespec, tv_nsec) pts2
+                           loop tv_sec' tv_nsec'
+                       else throwErrno "nanosleep"
+     loop (fromIntegral tv_sec0 :: CTime) (fromIntegral tv_nsec0 :: CTime)
+
+data {-# CTYPE "struct timespec" #-} CTimeSpec
+
+foreign import capi safe "HsUnix.h nanosleep"
+  c_nanosleep :: Ptr CTimeSpec -> Ptr CTimeSpec -> IO CInt
+#endif
+
+-- -----------------------------------------------------------------------------
+-- System variables
+
+data SysVar = ArgumentLimit
+            | ChildLimit
+            | ClockTick
+            | GroupLimit
+            | OpenFileLimit
+            | PosixVersion
+            | HasSavedIDs
+            | HasJobControl
+        -- ToDo: lots more
+
+getSysVar :: SysVar -> IO Integer
+getSysVar v =
+    case v of
+      ArgumentLimit -> sysconf (#const _SC_ARG_MAX)
+      ChildLimit    -> sysconf (#const _SC_CHILD_MAX)
+      ClockTick     -> sysconf (#const _SC_CLK_TCK)
+      GroupLimit    -> sysconf (#const _SC_NGROUPS_MAX)
+      OpenFileLimit -> sysconf (#const _SC_OPEN_MAX)
+      PosixVersion  -> sysconf (#const _SC_VERSION)
+      HasSavedIDs   -> sysconf (#const _SC_SAVED_IDS)
+      HasJobControl -> sysconf (#const _SC_JOB_CONTROL)
+
+sysconf :: CInt -> IO Integer
+sysconf n = do
+  r <- throwErrnoIfMinus1 "getSysVar" (c_sysconf n)
+  return (fromIntegral r)
+
+foreign import ccall unsafe "sysconf"
+  c_sysconf :: CInt -> IO CLong
+
+-- -----------------------------------------------------------------------------
+-- File synchronization
+
+-- | Performs @fsync(2)@ operation on file-descriptor.
+--
+-- Throws 'IOError' (\"unsupported operation\") if platform does not
+-- provide @fsync(2)@ (use @#if HAVE_FSYNC@ CPP guard to
+-- detect availability).
+--
+-- @since 2.7.1.0
+fileSynchronise :: Fd -> IO ()
+#if HAVE_FSYNC
+fileSynchronise fd = do
+  throwErrnoIfMinus1_ "fileSynchronise" (c_fsync fd)
+
+foreign import capi safe "unistd.h fsync"
+  c_fsync :: Fd -> IO CInt
+#else
+{-# WARNING fileSynchronise
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_FSYNC@)" #-}
+fileSynchronise _ = ioError (ioeSetLocation unsupportedOperation
+                             "fileSynchronise")
+#endif
+
+-- | Performs @fdatasync(2)@ operation on file-descriptor.
+--
+-- Throws 'IOError' (\"unsupported operation\") if platform does not
+-- provide @fdatasync(2)@ (use @#if HAVE_FDATASYNC@ CPP guard to
+-- detect availability).
+--
+-- @since 2.7.1.0
+fileSynchroniseDataOnly :: Fd -> IO ()
+#if HAVE_FDATASYNC
+fileSynchroniseDataOnly fd = do
+  throwErrnoIfMinus1_ "fileSynchroniseDataOnly" (c_fdatasync fd)
+
+foreign import capi safe "unistd.h fdatasync"
+  c_fdatasync :: Fd -> IO CInt
+#else
+{-# WARNING fileSynchroniseDataOnly
+    "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_FDATASYNC@)" #-}
+fileSynchroniseDataOnly _ = ioError (ioeSetLocation unsupportedOperation
+                                     "fileSynchroniseDataOnly")
+#endif

unix/System/Posix/User.hsc

@@ -0,0 +1,474 @@
+{-# LANGUAGE Trustworthy, CApiFFI #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.User
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX user\/group support
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.User (
+    -- * User environment
+    -- ** Querying the user environment
+    getRealUserID,
+    getRealGroupID,
+    getEffectiveUserID,
+    getEffectiveGroupID,
+    getGroups,
+    getLoginName,
+    getEffectiveUserName,
+
+    -- *** The group database
+    GroupEntry(..),
+    getGroupEntryForID,
+    getGroupEntryForName,
+    getAllGroupEntries,
+
+    -- *** The user database
+    UserEntry(..),
+    getUserEntryForID,
+    getUserEntryForName,
+    getAllUserEntries,
+
+    -- ** Modifying the user environment
+    setUserID,
+    setGroupID,
+    setEffectiveUserID,
+    setEffectiveGroupID,
+    setGroups
+
+  ) where
+
+#include "HsUnix.h"
+
+import System.Posix.Types
+import System.IO.Unsafe (unsafePerformIO)
+import Foreign.C
+import Foreign.Ptr
+import Foreign.Marshal
+import Foreign.Storable
+
+#if !defined(HAVE_GETPWNAM_R) || !defined(HAVE_GETPWUID_R) || defined(HAVE_GETPWENT) || defined(HAVE_GETGRENT)
+import Control.Concurrent.MVar  ( MVar, newMVar, withMVar )
+#endif
+#ifdef HAVE_GETPWENT
+import Control.Exception
+#endif
+import Control.Monad
+import System.IO.Error
+
+-- internal types
+data {-# CTYPE "struct passwd" #-} CPasswd
+data {-# CTYPE "struct group"  #-} CGroup
+
+-- -----------------------------------------------------------------------------
+-- user environment
+
+-- | @getRealUserID@ calls @getuid@ to obtain the real @UserID@
+--   associated with the current process.
+getRealUserID :: IO UserID
+getRealUserID = c_getuid
+
+foreign import ccall unsafe "getuid"
+  c_getuid :: IO CUid
+
+-- | @getRealGroupID@ calls @getgid@ to obtain the real @GroupID@
+--   associated with the current process.
+getRealGroupID :: IO GroupID
+getRealGroupID = c_getgid
+
+foreign import ccall unsafe "getgid"
+  c_getgid :: IO CGid
+
+-- | @getEffectiveUserID@ calls @geteuid@ to obtain the effective
+--   @UserID@ associated with the current process.
+getEffectiveUserID :: IO UserID
+getEffectiveUserID = c_geteuid
+
+foreign import ccall unsafe "geteuid"
+  c_geteuid :: IO CUid
+
+-- | @getEffectiveGroupID@ calls @getegid@ to obtain the effective
+--   @GroupID@ associated with the current process.
+getEffectiveGroupID :: IO GroupID
+getEffectiveGroupID = c_getegid
+
+foreign import ccall unsafe "getegid"
+  c_getegid :: IO CGid
+
+-- | @getGroups@ calls @getgroups@ to obtain the list of
+--   supplementary @GroupID@s associated with the current process.
+getGroups :: IO [GroupID]
+getGroups = do
+    ngroups <- c_getgroups 0 nullPtr
+    allocaArray (fromIntegral ngroups) $ \arr -> do
+       throwErrnoIfMinus1_ "getGroups" (c_getgroups ngroups arr)
+       groups <- peekArray (fromIntegral ngroups) arr
+       return groups
+
+foreign import ccall unsafe "getgroups"
+  c_getgroups :: CInt -> Ptr CGid -> IO CInt
+
+
+-- | @setGroups@ calls @setgroups@ to set the list of
+--   supplementary @GroupID@s associated with the current process.
+setGroups :: [GroupID] -> IO ()
+setGroups groups = do
+    withArrayLen groups $ \ ngroups arr ->
+       throwErrnoIfMinus1_ "setGroups" (c_setgroups (fromIntegral ngroups) arr)
+
+foreign import ccall unsafe "setgroups"
+  c_setgroups :: CInt -> Ptr CGid -> IO CInt
+
+
+
+-- | @getLoginName@ calls @getlogin@ to obtain the login name
+--   associated with the current process.
+getLoginName :: IO String
+getLoginName =  do
+    -- ToDo: use getlogin_r
+    str <- throwErrnoIfNull "getLoginName" c_getlogin
+    peekCAString str
+
+foreign import ccall unsafe "getlogin"
+  c_getlogin :: IO CString
+
+-- | @setUserID uid@ calls @setuid@ to set the real, effective, and
+--   saved set-user-id associated with the current process to @uid@.
+setUserID :: UserID -> IO ()
+setUserID uid = throwErrnoIfMinus1_ "setUserID" (c_setuid uid)
+
+foreign import ccall unsafe "setuid"
+  c_setuid :: CUid -> IO CInt
+
+-- | @setEffectiveUserID uid@ calls @seteuid@ to set the effective
+--   user-id associated with the current process to @uid@. This
+--   does not update the real user-id or set-user-id.
+setEffectiveUserID :: UserID -> IO ()
+setEffectiveUserID uid = throwErrnoIfMinus1_ "setEffectiveUserID" (c_seteuid uid)
+
+foreign import ccall unsafe "seteuid"
+  c_seteuid :: CUid -> IO CInt
+
+-- | @setGroupID gid@ calls @setgid@ to set the real, effective, and
+--   saved set-group-id associated with the current process to @gid@.
+setGroupID :: GroupID -> IO ()
+setGroupID gid = throwErrnoIfMinus1_ "setGroupID" (c_setgid gid)
+
+foreign import ccall unsafe "setgid"
+  c_setgid :: CGid -> IO CInt
+
+-- | @setEffectiveGroupID uid@ calls @setegid@ to set the effective
+--   group-id associated with the current process to @gid@. This
+--   does not update the real group-id or set-group-id.
+setEffectiveGroupID :: GroupID -> IO ()
+setEffectiveGroupID gid =
+  throwErrnoIfMinus1_ "setEffectiveGroupID" (c_setegid gid)
+
+
+foreign import ccall unsafe "setegid"
+  c_setegid :: CGid -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- User names
+
+-- | @getEffectiveUserName@ gets the name
+--   associated with the effective @UserID@ of the process.
+getEffectiveUserName :: IO String
+getEffectiveUserName = do
+    euid <- getEffectiveUserID
+    pw <- getUserEntryForID euid
+    return (userName pw)
+
+-- -----------------------------------------------------------------------------
+-- The group database (grp.h)
+
+data GroupEntry =
+ GroupEntry {
+  groupName    :: String,       -- ^ The name of this group (gr_name)
+  groupPassword :: String,      -- ^ The password for this group (gr_passwd)
+  groupID      :: GroupID,      -- ^ The unique numeric ID for this group (gr_gid)
+  groupMembers :: [String]      -- ^ A list of zero or more usernames that are members (gr_mem)
+ } deriving (Show, Read, Eq)
+
+-- | @getGroupEntryForID gid@ calls @getgrgid_r@ to obtain
+--   the @GroupEntry@ information associated with @GroupID@
+--   @gid@. This operation may fail with 'isDoesNotExistError'
+--   if no such group exists.
+getGroupEntryForID :: GroupID -> IO GroupEntry
+#ifdef HAVE_GETGRGID_R
+getGroupEntryForID gid =
+  allocaBytes (#const sizeof(struct group)) $ \pgr ->
+   doubleAllocWhileERANGE "getGroupEntryForID" "group" grBufSize unpackGroupEntry $
+     c_getgrgid_r gid pgr
+
+foreign import capi unsafe "HsUnix.h getgrgid_r"
+  c_getgrgid_r :: CGid -> Ptr CGroup -> CString
+                 -> CSize -> Ptr (Ptr CGroup) -> IO CInt
+#else
+getGroupEntryForID = error "System.Posix.User.getGroupEntryForID: not supported"
+#endif
+
+-- | @getGroupEntryForName name@ calls @getgrnam_r@ to obtain
+--   the @GroupEntry@ information associated with the group called
+--   @name@. This operation may fail with 'isDoesNotExistError'
+--   if no such group exists.
+getGroupEntryForName :: String -> IO GroupEntry
+#ifdef HAVE_GETGRNAM_R
+getGroupEntryForName name =
+  allocaBytes (#const sizeof(struct group)) $ \pgr ->
+    withCAString name $ \ pstr ->
+      doubleAllocWhileERANGE "getGroupEntryForName" "group" grBufSize unpackGroupEntry $
+        c_getgrnam_r pstr pgr
+
+foreign import capi unsafe "HsUnix.h getgrnam_r"
+  c_getgrnam_r :: CString -> Ptr CGroup -> CString
+                 -> CSize -> Ptr (Ptr CGroup) -> IO CInt
+#else
+getGroupEntryForName = error "System.Posix.User.getGroupEntryForName: not supported"
+#endif
+
+-- | @getAllGroupEntries@ returns all group entries on the system by
+--   repeatedly calling @getgrent@
+
+--
+-- getAllGroupEntries may fail with isDoesNotExistError on Linux due to
+-- this bug in glibc:
+--   http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=466647
+--
+getAllGroupEntries :: IO [GroupEntry]
+#ifdef HAVE_GETGRENT
+getAllGroupEntries =
+    withMVar lock $ \_ -> bracket_ c_setgrent c_endgrent $ worker []
+    where worker accum =
+              do resetErrno
+                 ppw <- throwErrnoIfNullAndError "getAllGroupEntries" $
+                        c_getgrent
+                 if ppw == nullPtr
+                     then return (reverse accum)
+                     else do thisentry <- unpackGroupEntry ppw
+                             worker (thisentry : accum)
+
+foreign import ccall unsafe "getgrent"
+  c_getgrent :: IO (Ptr CGroup)
+foreign import ccall unsafe "setgrent"
+  c_setgrent :: IO ()
+foreign import ccall unsafe "endgrent"
+  c_endgrent :: IO ()
+#else
+getAllGroupEntries = error "System.Posix.User.getAllGroupEntries: not supported"
+#endif
+
+#if defined(HAVE_GETGRGID_R) || defined(HAVE_GETGRNAM_R)
+grBufSize :: Int
+#if defined(HAVE_SYSCONF) && defined(HAVE_SC_GETGR_R_SIZE_MAX)
+grBufSize = sysconfWithDefault 1024 (#const _SC_GETGR_R_SIZE_MAX)
+#else
+grBufSize = 1024
+#endif
+#endif
+
+unpackGroupEntry :: Ptr CGroup -> IO GroupEntry
+unpackGroupEntry ptr = do
+   name    <- (#peek struct group, gr_name) ptr >>= peekCAString
+   passwd  <- (#peek struct group, gr_passwd) ptr >>= peekCAString
+   gid     <- (#peek struct group, gr_gid) ptr
+   mem     <- (#peek struct group, gr_mem) ptr
+   members <- peekArray0 nullPtr mem >>= mapM peekCAString
+   return (GroupEntry name passwd gid members)
+
+-- -----------------------------------------------------------------------------
+-- The user database (pwd.h)
+
+data UserEntry =
+ UserEntry {
+   userName      :: String,     -- ^ Textual name of this user (pw_name)
+   userPassword  :: String,     -- ^ Password -- may be empty or fake if shadow is in use (pw_passwd)
+   userID        :: UserID,     -- ^ Numeric ID for this user (pw_uid)
+   userGroupID   :: GroupID,    -- ^ Primary group ID (pw_gid)
+   userGecos     :: String,     -- ^ Usually the real name for the user (pw_gecos)
+   homeDirectory :: String,     -- ^ Home directory (pw_dir)
+   userShell     :: String      -- ^ Default shell (pw_shell)
+ } deriving (Show, Read, Eq)
+
+--
+-- getpwuid and getpwnam leave results in a static object. Subsequent
+-- calls modify the same object, which isn't threadsafe. We attempt to
+-- mitigate this issue, on platforms that don't provide the safe _r versions
+--
+-- Also, getpwent/setpwent require a global lock since they maintain
+-- an internal file position pointer.
+#if !defined(HAVE_GETPWNAM_R) || !defined(HAVE_GETPWUID_R) || defined(HAVE_GETPWENT) || defined(HAVE_GETGRENT)
+lock :: MVar ()
+lock = unsafePerformIO $ newMVar ()
+{-# NOINLINE lock #-}
+#endif
+
+-- | @getUserEntryForID gid@ calls @getpwuid_r@ to obtain
+--   the @UserEntry@ information associated with @UserID@
+--   @uid@. This operation may fail with 'isDoesNotExistError'
+--   if no such user exists.
+getUserEntryForID :: UserID -> IO UserEntry
+#ifdef HAVE_GETPWUID_R
+getUserEntryForID uid =
+  allocaBytes (#const sizeof(struct passwd)) $ \ppw ->
+    doubleAllocWhileERANGE "getUserEntryForID" "user" pwBufSize unpackUserEntry $
+      c_getpwuid_r uid ppw
+
+foreign import capi unsafe "HsUnix.h getpwuid_r"
+  c_getpwuid_r :: CUid -> Ptr CPasswd ->
+                        CString -> CSize -> Ptr (Ptr CPasswd) -> IO CInt
+#elif HAVE_GETPWUID
+getUserEntryForID uid = do
+  withMVar lock $ \_ -> do
+    ppw <- throwErrnoIfNull "getUserEntryForID" $ c_getpwuid uid
+    unpackUserEntry ppw
+
+foreign import ccall unsafe "getpwuid"
+  c_getpwuid :: CUid -> IO (Ptr CPasswd)
+#else
+getUserEntryForID = error "System.Posix.User.getUserEntryForID: not supported"
+#endif
+
+-- | @getUserEntryForName name@ calls @getpwnam_r@ to obtain
+--   the @UserEntry@ information associated with the user login
+--   @name@. This operation may fail with 'isDoesNotExistError'
+--   if no such user exists.
+getUserEntryForName :: String -> IO UserEntry
+#if HAVE_GETPWNAM_R
+getUserEntryForName name =
+  allocaBytes (#const sizeof(struct passwd)) $ \ppw ->
+    withCAString name $ \ pstr ->
+      doubleAllocWhileERANGE "getUserEntryForName" "user" pwBufSize unpackUserEntry $
+        c_getpwnam_r pstr ppw
+
+foreign import capi unsafe "HsUnix.h getpwnam_r"
+  c_getpwnam_r :: CString -> Ptr CPasswd
+               -> CString -> CSize -> Ptr (Ptr CPasswd) -> IO CInt
+#elif HAVE_GETPWNAM
+getUserEntryForName name = do
+  withCAString name $ \ pstr -> do
+    withMVar lock $ \_ -> do
+      ppw <- throwErrnoIfNull "getUserEntryForName" $ c_getpwnam pstr
+      unpackUserEntry ppw
+
+foreign import ccall unsafe "getpwnam"
+  c_getpwnam :: CString -> IO (Ptr CPasswd)
+#else
+getUserEntryForName = error "System.Posix.User.getUserEntryForName: not supported"
+#endif
+
+-- | @getAllUserEntries@ returns all user entries on the system by
+--   repeatedly calling @getpwent@
+getAllUserEntries :: IO [UserEntry]
+#ifdef HAVE_GETPWENT
+getAllUserEntries =
+    withMVar lock $ \_ -> bracket_ c_setpwent c_endpwent $ worker []
+    where worker accum =
+              do resetErrno
+                 ppw <- throwErrnoIfNullAndError "getAllUserEntries" $
+                        c_getpwent
+                 if ppw == nullPtr
+                     then return (reverse accum)
+                     else do thisentry <- unpackUserEntry ppw
+                             worker (thisentry : accum)
+
+foreign import capi unsafe "HsUnix.h getpwent"
+  c_getpwent :: IO (Ptr CPasswd)
+foreign import capi unsafe "HsUnix.h setpwent"
+  c_setpwent :: IO ()
+foreign import capi unsafe "HsUnix.h endpwent"
+  c_endpwent :: IO ()
+#else
+getAllUserEntries = error "System.Posix.User.getAllUserEntries: not supported"
+#endif
+
+#if defined(HAVE_GETPWUID_R) || defined(HAVE_GETPWNAM_R)
+pwBufSize :: Int
+#if  defined(HAVE_SYSCONF) && defined(HAVE_SC_GETPW_R_SIZE_MAX)
+pwBufSize = sysconfWithDefault 1024 (#const _SC_GETPW_R_SIZE_MAX)
+#else
+pwBufSize = 1024
+#endif
+#endif
+
+#ifdef HAVE_SYSCONF
+foreign import ccall unsafe "sysconf"
+  c_sysconf :: CInt -> IO CLong
+
+-- We need a default value since sysconf can fail and return -1
+-- even when the parameter name is defined in unistd.h.
+-- One example of this is _SC_GETPW_R_SIZE_MAX under
+-- Mac OS X 10.4.9 on i386.
+sysconfWithDefault :: Int -> CInt -> Int
+sysconfWithDefault def sc =
+    unsafePerformIO $ do v <- fmap fromIntegral $ c_sysconf sc
+                         return $ if v == (-1) then def else v
+#endif
+
+-- The following function is used by the getgr*_r, c_getpw*_r
+-- families of functions. These functions return their result
+-- in a struct that contains strings and they need a buffer
+-- that they can use to store those strings. We have to be
+-- careful to unpack the struct containing the result before
+-- the buffer is deallocated.
+doubleAllocWhileERANGE
+  :: String
+  -> String -- entry type: "user" or "group"
+  -> Int
+  -> (Ptr r -> IO a)
+  -> (Ptr b -> CSize -> Ptr (Ptr r) -> IO CInt)
+  -> IO a
+doubleAllocWhileERANGE loc enttype initlen unpack action =
+  alloca $ go initlen
+ where
+  go len res = do
+    r <- allocaBytes len $ \buf -> do
+           rc <- action buf (fromIntegral len) res
+           if rc /= 0
+             then return (Left rc)
+             else do p <- peek res
+                     when (p == nullPtr) $ notFoundErr
+                     fmap Right (unpack p)
+    case r of
+      Right x -> return x
+      Left rc | Errno rc == eRANGE ->
+        -- ERANGE means this is not an error
+        -- we just have to try again with a larger buffer
+        go (2 * len) res
+      Left rc ->
+        ioError (errnoToIOError loc (Errno rc) Nothing Nothing)
+  notFoundErr =
+    ioError $ flip ioeSetErrorString ("no such " ++ enttype)
+            $ mkIOError doesNotExistErrorType loc Nothing Nothing
+
+unpackUserEntry :: Ptr CPasswd -> IO UserEntry
+unpackUserEntry ptr = do
+   name   <- (#peek struct passwd, pw_name)   ptr >>= peekCAString
+   passwd <- (#peek struct passwd, pw_passwd) ptr >>= peekCAString
+   uid    <- (#peek struct passwd, pw_uid)    ptr
+   gid    <- (#peek struct passwd, pw_gid)    ptr
+#ifdef HAVE_NO_PASSWD_PW_GECOS
+   gecos  <- return ""  -- pw_gecos does not exist on android
+#else
+   gecos  <- (#peek struct passwd, pw_gecos)  ptr >>= peekCAString
+#endif
+   dir    <- (#peek struct passwd, pw_dir)    ptr >>= peekCAString
+   shell  <- (#peek struct passwd, pw_shell)  ptr >>= peekCAString
+   return (UserEntry name passwd uid gid gecos dir shell)
+
+-- Used when a function returns NULL to indicate either an error or
+-- EOF, depending on whether the global errno is nonzero.
+throwErrnoIfNullAndError :: String -> IO (Ptr a) -> IO (Ptr a)
+throwErrnoIfNullAndError loc act = do
+    rc <- act
+    errno <- getErrno
+    if rc == nullPtr && errno /= eOK
+       then throwErrno loc
+       else return rc

unix/aclocal.m4

@@ -0,0 +1,49 @@
+# FP_COMPUTE_INT(EXPRESSION, VARIABLE, INCLUDES, IF-FAILS)
+# --------------------------------------------------------
+# Assign VARIABLE the value of the compile-time EXPRESSION using INCLUDES for
+# compilation. Execute IF-FAILS when unable to determine the value. Works for
+# cross-compilation, too.
+#
+# Implementation note: We are lazy and use an internal autoconf macro, but it
+# is supported in autoconf versions 2.50 up to the actual 2.57, so there is
+# little risk.
+AC_DEFUN([FP_COMPUTE_INT],
+[_AC_COMPUTE_INT([$1], [$2], [$3], [$4])[]dnl
+])# FP_COMPUTE_INT
+
+
+# FP_CHECK_CONST(EXPRESSION, [INCLUDES = DEFAULT-INCLUDES], [VALUE-IF-FAIL = -1])
+# -------------------------------------------------------------------------------
+# Defines CONST_EXPRESSION to the value of the compile-time EXPRESSION, using
+# INCLUDES. If the value cannot be determined, use VALUE-IF-FAIL.
+AC_DEFUN([FP_CHECK_CONST],
+[AS_VAR_PUSHDEF([fp_Cache], [fp_cv_const_$1])[]dnl
+AC_CACHE_CHECK([value of $1], fp_Cache,
+[FP_COMPUTE_INT([$1], fp_check_const_result, [AC_INCLUDES_DEFAULT([$2])],
+                [fp_check_const_result=m4_default([$3], ['-1'])])
+AS_VAR_SET(fp_Cache, [$fp_check_const_result])])[]dnl
+AC_DEFINE_UNQUOTED(AS_TR_CPP([CONST_$1]), AS_VAR_GET(fp_Cache), [The value of $1.])[]dnl
+AS_VAR_POPDEF([fp_Cache])[]dnl
+])# FP_CHECK_CONST
+
+
+# FP_CHECK_CONSTS_TEMPLATE(EXPRESSION...)
+# ---------------------------------------
+# autoheader helper for FP_CHECK_CONSTS
+m4_define([FP_CHECK_CONSTS_TEMPLATE],
+[AC_FOREACH([fp_Const], [$1],
+  [AH_TEMPLATE(AS_TR_CPP(CONST_[]fp_Const),
+               [The value of ]fp_Const[.])])[]dnl
+])# FP_CHECK_CONSTS_TEMPLATE
+
+
+# FP_CHECK_CONSTS(EXPRESSION..., [INCLUDES = DEFAULT-INCLUDES], [VALUE-IF-FAIL = -1])
+# -----------------------------------------------------------------------------------
+# List version of FP_CHECK_CONST
+AC_DEFUN([FP_CHECK_CONSTS],
+[FP_CHECK_CONSTS_TEMPLATE([$1])dnl
+for fp_const_name in $1
+do
+FP_CHECK_CONST([$fp_const_name], [$2], [$3])
+done
+])# FP_CHECK_CONSTS

unix/cabal.haskell-ci

@@ -0,0 +1,2 @@
+ghc-head:      True
+unconstrained: False

unix/cabal.project

@@ -0,0 +1 @@
+packages: .

unix/cbits/HsUnix.c

@@ -0,0 +1,116 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow 2002
+ *
+ * Definitions for package `unix' which are visible in Haskell land.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "HsUnix.h"
+
+#ifdef HAVE_RTLDNEXT
+void *__hsunix_rtldNext (void) {return RTLD_NEXT;}
+#endif
+
+#ifdef HAVE_RTLDDEFAULT
+void *__hsunix_rtldDefault (void) {return RTLD_DEFAULT;}
+#endif
+
+#if HAVE_PTSNAME && (__GLASGOW_HASKELL__ < 800)
+// On Linux (and others), <stdlib.h> needs to be included while
+// `_XOPEN_SOURCE` is already defined. However, GHCs before GHC 8.0
+// didn't do that yet for CApiFFI, so we need this workaround here.
+
+char *__hsunix_ptsname(int fd)   { return ptsname(fd);  }
+int   __hsunix_grantpt(int fd)   { return grantpt(fd);  }
+int   __hsunix_unlockpt(int fd)  { return unlockpt(fd); }
+#endif
+
+// push a SVR4 STREAMS module; do nothing if STREAMS not available
+int __hsunix_push_module(int fd, const char *module)
+{
+#if defined(I_PUSH) && !defined(HAVE_DEV_PTC)
+    return ioctl(fd, I_PUSH, module);
+#else
+    return 0;
+#endif
+}
+
+/*
+ * GNU glibc 2.23 and later deprecate `readdir_r` in favour of plain old
+ * `readdir` which in some upcoming POSIX standard is going to required to be
+ * re-entrant.
+ * Eventually we want to drop `readder_r` all together, but want to be
+ * compatible with older unixen which may not have a re-entrant `readdir`.
+ * Solution is to make systems with *known* re-entrant `readir` use that and use
+ * `readdir_r` whereever we have it and don't *know* that `readdir` is
+ * re-entrant.
+ */
+
+#if defined (__GLIBC__) && (__GLIBC__ >= 2) && (__GLIBC_MINOR__ >= 23)
+#define USE_READDIR_R 0
+#else
+#define USE_READDIR_R 1
+#endif
+
+/*
+ * read an entry from the directory stream; opt for the
+ * re-entrant friendly way of doing this, if available.
+ */
+int __hscore_readdir( DIR *dirPtr, struct dirent **pDirEnt )
+{
+#if HAVE_READDIR_R && USE_READDIR_R
+  struct dirent* p;
+  int res;
+  static unsigned int nm_max = (unsigned int)-1;
+
+  if (pDirEnt == NULL) {
+    return -1;
+  }
+  if (nm_max == (unsigned int)-1) {
+#ifdef NAME_MAX
+    nm_max = NAME_MAX + 1;
+#else
+    nm_max = pathconf(".", _PC_NAME_MAX);
+    if (nm_max == -1) { nm_max = 255; }
+    nm_max++;
+#endif
+  }
+  p = (struct dirent*)malloc(sizeof(struct dirent) + nm_max);
+  if (p == NULL) return -1;
+  res = readdir_r(dirPtr, p, pDirEnt);
+  if (res != 0) {
+      *pDirEnt = NULL;
+      free(p);
+  }
+  else if (*pDirEnt == NULL) {
+    // end of stream
+    free(p);
+  }
+  return res;
+#else
+
+  if (pDirEnt == NULL) {
+    return -1;
+  }
+
+  *pDirEnt = readdir(dirPtr);
+  if (*pDirEnt == NULL) {
+    return -1;
+  } else {
+    return 0;
+  }
+#endif
+}
+
+char *__hscore_d_name( struct dirent* d )
+{
+  return (d->d_name);
+}
+
+void __hscore_free_dirent(struct dirent *dEnt)
+{
+#if HAVE_READDIR_R && USE_READDIR_R
+  free(dEnt);
+#endif
+}

unix/cbits/execvpe.c

@@ -0,0 +1,173 @@
+/* -----------------------------------------------------------------------------
+   (c) The University of Glasgow 1995-2004
+
+   Our low-level exec() variant.
+
+   Note: __hsunix_execvpe() is very similiar to the function
+         execvpe(3) as provided by glibc 2.11 and later. However, if
+         execvpe(3) is available, we use that instead.
+
+   -------------------------------------------------------------------------- */
+
+#include "HsUnixConfig.h"
+
+#include <errno.h>
+#include <sys/types.h>
+#if HAVE_SYS_WAIT_H
+# include <sys/wait.h>
+#endif
+#include <unistd.h>
+#include <sys/time.h>
+#include <stdlib.h>
+#include <string.h>
+#include <errno.h>
+
+#include "execvpe.h"
+
+#if !defined(execvpe) && !HAVE_DECL_EXECVPE
+// On some archs such as AIX, the prototype may be missing
+int execvpe(const char *file, char *const argv[], char *const envp[]);
+#endif
+
+/*
+ * We want the search semantics of execvp, but we want to provide our
+ * own environment, like execve.  The following copyright applies to
+ * this code, as it is a derivative of execvp:
+ *-
+ * Copyright (c) 1991 The Regents of the University of California.
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ *    notice, this list of conditions and the following disclaimer in the
+ *    documentation and/or other materials provided with the distribution.
+ * 3. All advertising materials mentioning features or use of this software
+ *    must display the following acknowledgement:
+ *	This product includes software developed by the University of
+ *	California, Berkeley and its contributors.
+ * 4. Neither the name of the University nor the names of its contributors
+ *    may be used to endorse or promote products derived from this software
+ *    without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ */
+
+int
+__hsunix_execvpe(const char *name, char *const argv[], char *const envp[])
+{
+#if HAVE_EXECVPE
+    return execvpe(name, argv, envp);
+#else
+    register int lp, ln;
+    register char *p;
+    int eacces=0, etxtbsy=0;
+    char *bp, *cur, *path, *buf = 0;
+
+    /* If it's an absolute or relative path name, it's easy. */
+    if (strchr(name, '/')) {
+	bp = (char *) name;
+	cur = path = buf = NULL;
+	goto retry;
+    }
+
+    /* Get the path we're searching. */
+    if (!(path = getenv("PATH"))) {
+# ifdef HAVE_CONFSTR
+        ln = confstr(_CS_PATH, NULL, 0);
+        if ((cur = path = malloc(ln + 1)) != NULL) {
+	    path[0] = ':';
+	    (void) confstr (_CS_PATH, path + 1, ln);
+	}
+# else
+        if ((cur = path = malloc(1 + 1)) != NULL) {
+	    path[0] = ':';
+	    path[1] = '\0';
+	}
+# endif
+    } else
+	cur = path = strdup(path);
+
+    if (path == NULL || (bp = buf = malloc(strlen(path)+strlen(name)+2)) == NULL)
+	goto done;
+
+    while (cur != NULL) {
+	p = cur;
+        if ((cur = strchr(cur, ':')) != NULL)
+	    *cur++ = '\0';
+
+	/*
+	 * It's a SHELL path -- double, leading and trailing colons mean the current
+	 * directory.
+	 */
+	if (!*p) {
+	    p = ".";
+	    lp = 1;
+	} else
+	    lp = strlen(p);
+	ln = strlen(name);
+
+	memcpy(buf, p, lp);
+	buf[lp] = '/';
+	memcpy(buf + lp + 1, name, ln);
+	buf[lp + ln + 1] = '\0';
+
+      retry:
+        (void) execve(bp, argv, envp);
+	switch (errno) {
+	case EACCES:
+	    eacces = 1;
+	    break;
+	case ENOTDIR:
+	case ENOENT:
+	    break;
+	case ENOEXEC:
+	    {
+		register size_t cnt;
+		register char **ap;
+
+		for (cnt = 0, ap = (char **) argv; *ap; ++ap, ++cnt)
+		    ;
+		if ((ap = malloc((cnt + 2) * sizeof(char *))) != NULL) {
+		    memcpy(ap + 2, argv + 1, cnt * sizeof(char *));
+
+		    ap[0] = "sh";
+		    ap[1] = bp;
+		    (void) execve("/bin/sh", ap, envp);
+		    free(ap);
+		}
+		goto done;
+	    }
+	case ETXTBSY:
+	    if (etxtbsy < 3)
+		(void) sleep(++etxtbsy);
+	    goto retry;
+	default:
+	    goto done;
+	}
+    }
+    if (eacces)
+	errno = EACCES;
+    else if (!errno)
+	errno = ENOENT;
+  done:
+    if (path)
+	free(path);
+    if (buf)
+	free(buf);
+    return (-1);
+#endif
+}

unix/changelog.md

@@ -0,0 +1,150 @@
+# Changelog for [`unix` package](http://hackage.haskell.org/package/unix)
+
+## 2.8.0.0 *UNRELEASED*
+
+  * Added terminal output flags to `System.Posix.Terminal.Common.TerminalMode`
+
+        IXANY, ONLCR, OCRNL, ONOCR, ONLRET, OFDEL, OFILL, NLDLY(NL0,NL1),
+        CRDLY(CR0,CR1,CR2,CR2), TABDLY(TAB0,TAB1,TAB2,TAB3) BSDLY(BS0,BS1),
+        VTDLY(VT0,VT1), FFDLY(FF0,FF1)
+
+  * Add support for `O_NOFOLLOW`, `O_CLOEXEC`, `O_DIRECTORY` and `O_SYNC`
+    (#6, #57)
+
+  * Refactor API of `openFd` removing `Maybe FileMode` argument,
+    which now must be passed as part of `OpenFileFlags`
+    (e.g. `defaultFileFlags { creat = Just mode }`)  (#58)
+
+  * Remove deprecated `execvpe(3)` legacy-emulation CPP macro
+
+  * Generalise return type of `exitImmediately` from `ExitCode -> IO ()` to
+    `∀a. ExitCode -> IO a` (#130)
+    
+  * Add `Read`, `Show`, `Eq`, and `Ord` typeclass instances to `OpenFileFlags` and `OpenMode`. (#75, #141)
+
+## 2.7.2.2  *May 2017*
+
+  * Bundled with GHC 8.2.1
+
+  * Improve Autoconf detection of `telldir`/`seekdir` and define
+    `_POSIX_VDISABLE` if missing for Android (#91,#90)
+
+  * Fix error message of `createSymbolicLink` (#84)
+
+## 2.7.2.1  *Nov 2016*
+
+  * Bundled with GHC 8.0.2
+
+  * Don't use `readdir_r` if its deprecated.
+
+  * Add argument documentation for Env modules
+
+## 2.7.2.0  *Apr 2016*
+
+  * Bundled with GHC 8.0.1
+
+  * Don't assume non-POSIX `WCOREDUMP(x)` macro exists
+
+  * Don't assume existence of `termios(3)` constants beyond `B38400`
+
+  * Don't assume existence of `ctermid(3)`/`tcdrain(3)`
+
+  * Change `drainOutput`'s `tcdrain(3)` into a `safe` FFI call
+
+  * Turn build error into compile warnings for exotic `struct stat`
+    configurations (GHC #8859)
+
+  * Improve detection of `fdatasync(2)` (GHC #11137)
+
+  * Drop support for Hugs
+
+  * Drop support for Cygwin (and Windows in general)
+
+## 2.7.1.0  *Dec 2014*
+
+  * Bundled with GHC 7.10.1
+
+  * Add support for `base-4.8.0.0`
+
+  * Tighten `SafeHaskell` bounds for GHC 7.10+
+
+  * Add haddock comments on `RTLD_NEXT` and `RTLD_DEFAULT`
+
+  * Deprecate function `haveRtldLocal`
+
+  * Fix `getGroupEntryForID/getGroupEntryForName` on Solaris. Solaris uses
+    CPP macros for required `getgrgid_r` and `getgrnam_r` functions definition
+    so the fix is to change from C ABI calling convention to C API calling
+    convention
+
+  * Fix potential type-mismatch in `telldir`/`seekdir` FFI imports
+
+  * Use CAPI FFI import for `truncate` to make sure the LFS-version is used.
+
+  * `executeFile`: Fix `ENOTDIR` error for entries with non-directory
+    components in `PATH` (and instead skip over non-directory `PATH`-elements)
+
+  * New functions in `System.Posix.Unistd`:
+     - `fileSynchronise` (aka `fsync(2)`), and
+     - `fileSynchroniseDataOnly` (aka `fdatasync(2)`)
+
+  * New module `System.Posix.Fcntl` providing
+     - `fileAdvise` (aka `posix_fadvise(2)`), and
+     - `fileAllocate` (aka `posix_fallocate(2)`)
+
+  * Fix SIGINFO and SIGWINCH definitions
+
+## 2.7.0.1  *Mar 2014*
+
+  * Bundled with GHC 7.8.1
+
+  * Handle `EROFS` and `ETXTBSY` as (non-exceptional) permission denied in
+    `fileAccess`
+
+  * Fix `getFileStatus` to retry `stat(2)` when it returns `EAGAIN`
+    (this can happen on Solaris)
+
+## 2.7.0.0  *Nov 2013*
+
+  * New `forkProcessWithUnmask` function in the style of `forkIOWithUnmask`
+
+  * Change `forkProcess` to inherit the exception masking state of its caller
+
+  * Add new `Bool` flag to `ProcessStatus(Terminated)` constructor
+    indicating whether a core dump occured
+
+  * New functions in `System.Posix.Files{,.ByteString}` for operating
+    on high resolution file timestamps:
+
+        setFdTimesHiRes :: Fd -> POSIXTime -> POSIXTime -> IO ()
+        setFileTimesHiRes :: FilePath -> POSIXTime -> POSIXTime -> IO ()
+        setSymbolicLinkTimesHiRes :: FilePath -> POSIXTime -> POSIXTime -> IO ()
+        touchFd :: Fd -> IO ()
+        touchSymbolicLink :: FilePath -> IO ()
+
+  * Export `SignalInfo(..)` and `SignalSpecificInfo(..)` as well as
+    the two `Handler` constructors `CatchInfo` and `CatchInfoOnce`
+    from `System.Posix.Signals`
+
+  * Don't export `seekDirStream` and `tellDirStream` if the underlying
+    `seekdir(3)`/`telldir(3)` system calls are not available (as on Android)
+
+  * Fix library detection of `shm*` on openSUSE (#8350)
+
+  * Minor documentation fixes/updates
+
+  * Update package to `cabal-version >= 1.10` format
+
+## 2.6.0.1  *Jan 2013*
+
+  * Bundled with GHC 7.6.2
+  * Fix memory corruption issue in `putEnv`
+  * Use `pthread_kill(3)` instead of `raise(2)` on OS X too
+
+## 2.6.0.0  *Sep 2012*
+
+  * Bundled with GHC 7.6.1
+  * New functions `mkdtemp` and `mkstemps` in `System.Posix.Temp`
+  * New functions `setEnvironment` and `cleanEnv`
+  * New functions `accessTimeHiRes`, `modificationTimeHiRes`, and
+    `statusChangeTimeHiRes` for accessing high resolution timestamps

unix/configure.ac

@@ -0,0 +1,240 @@
+AC_PREREQ([2.60])
+AC_INIT([Haskell unix package], [2.0], [libraries@haskell.org], [unix])
+
+# Safety check: Ensure that we are in the correct source directory.
+AC_CONFIG_SRCDIR([include/HsUnix.h])
+
+AC_PROG_CC
+
+dnl make extensions visible to allow feature-tests to detect them lateron
+AC_USE_SYSTEM_EXTENSIONS
+
+AC_CONFIG_HEADERS([include/HsUnixConfig.h])
+
+# Is this a Unix system?
+AC_CHECK_HEADER([dlfcn.h], [BUILD_PACKAGE_BOOL=True], [BUILD_PACKAGE_BOOL=False])
+AC_SUBST([BUILD_PACKAGE_BOOL])
+
+AC_C_CONST
+
+dnl ** Enable large file support.  NB. do this before testing the type of
+dnl    off_t, because it will affect the result of that test.
+dnl
+dnl WARNING: It's essential this check agrees with HsBaseConfig.h as otherwise
+dnl          the definitions of COff/coff_t don't line up
+AC_SYS_LARGEFILE
+
+AC_CHECK_HEADERS([dirent.h fcntl.h grp.h limits.h pwd.h signal.h string.h])
+AC_CHECK_HEADERS([sys/resource.h sys/stat.h sys/times.h sys/time.h])
+AC_CHECK_HEADERS([sys/utsname.h sys/wait.h])
+AC_CHECK_HEADERS([bsd/libutil.h libutil.h pty.h utmp.h])
+AC_CHECK_HEADERS([termios.h time.h unistd.h utime.h])
+
+AC_CHECK_FUNCS([getgrgid_r getgrnam_r getpwnam_r getpwuid_r getpwnam getpwuid])
+AC_CHECK_FUNCS([getpwent getgrent])
+AC_CHECK_FUNCS([lchown setenv sysconf unsetenv clearenv])
+AC_CHECK_FUNCS([nanosleep])
+AC_CHECK_FUNCS([ptsname])
+AC_CHECK_FUNCS([setitimer])
+AC_CHECK_FUNCS([readdir_r])
+
+dnl not available on android so check for it
+AC_CANONICAL_TARGET
+AS_CASE([$target_os],[*-android*],[],[AC_CHECK_FUNCS([telldir seekdir])])
+
+dnl When available, _NSGetEnviron() (defined in <crt_externs.h>) is
+dnl the preferred way to access environ(7)
+AC_CHECK_FUNCS([_NSGetEnviron])
+
+dnl This is e.g. available as a GNU extension in glibc 2.11+
+AC_CHECK_DECLS([execvpe])
+AC_CHECK_FUNCS([execvpe])
+
+AC_CHECK_MEMBERS([struct stat.st_atim])
+AC_CHECK_MEMBERS([struct stat.st_mtim])
+AC_CHECK_MEMBERS([struct stat.st_ctim])
+AC_CHECK_MEMBERS([struct stat.st_atimespec])
+AC_CHECK_MEMBERS([struct stat.st_mtimespec])
+AC_CHECK_MEMBERS([struct stat.st_ctimespec])
+AC_CHECK_MEMBERS([struct stat.st_atimensec])
+AC_CHECK_MEMBERS([struct stat.st_mtimensec])
+AC_CHECK_MEMBERS([struct stat.st_ctimensec])
+AC_CHECK_MEMBERS([struct stat.st_atime_n])
+AC_CHECK_MEMBERS([struct stat.st_mtime_n])
+AC_CHECK_MEMBERS([struct stat.st_ctime_n])
+AC_CHECK_MEMBERS([struct stat.st_uatime])
+AC_CHECK_MEMBERS([struct stat.st_umtime])
+AC_CHECK_MEMBERS([struct stat.st_uctime])
+
+AC_CHECK_MEMBER([struct passwd.pw_gecos], [], [AC_DEFINE([HAVE_NO_PASSWD_PW_GECOS],[],[Ignore the pw_gecos member of passwd where it does not exist])], [[#include <pwd.h>]])
+
+# Functions for changing file timestamps
+AC_CHECK_FUNCS([utimensat futimens])
+AC_CHECK_FUNCS([lutimes futimes])
+
+# Additional temp functions
+dnl androids bionic doesn't have mkstemps
+# We explicilty check for android, as the check AC_CHECK_FUNCS performs returns "yes" for mkstemps
+# when targetting android. See similar conditionals for seekdir and telldir.
+AS_CASE([$target_os],[*-android*],[AC_CHECK_FUNCS([mkdtemp])],[AC_CHECK_FUNCS([mkstemps mkdtemp])])
+
+# Functions for file synchronization and allocation control
+AC_CHECK_FUNCS([fsync])
+
+# On OSX linking against 'fdatasync' succeeds, but that doesn't pick
+# the expected the POSIX 'fdatasync' function.  So make sure that we
+# also have a function declaration in scope, in addition to being able
+# to link against 'fdatasync'.
+AC_CHECK_DECLS([fdatasync],[AC_CHECK_FUNCS([fdatasync])])
+
+
+AC_CHECK_FUNCS([posix_fadvise posix_fallocate])
+
+# Some termios(3) functions known to be missing sometimes (see also #55)
+AC_CHECK_DECLS([tcdrain],[AC_DEFINE([HAVE_TCDRAIN],[1],[Define to 1 if you have the `tcdrain' function.])],[],[AC_INCLUDES_DEFAULT
+#ifdef HAVE_TERMIOS_H
+#include <termios.h>
+#endif
+])
+
+AC_CHECK_DECLS([ctermid],[AC_DEFINE([HAVE_CTERMID],[1],[Define to 1 if you have the `ctermid' function.])],[],[AC_INCLUDES_DEFAULT
+#ifdef HAVE_TERMIOS_H
+#include <termios.h>
+#endif
+])
+
+# Avoid adding rt if absent or unneeded
+# shm_open needs -lrt on linux
+AC_SEARCH_LIBS(shm_open, rt, [AC_CHECK_FUNCS([shm_open shm_unlink])])
+AS_IF([test "x$ac_cv_search_shm_open" = x-lrt], [EXTRA_LIBS="$EXTRA_LIBS rt"])
+
+FP_CHECK_CONSTS([SIGABRT SIGALRM SIGBUS SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 SIGPOLL SIGPROF SIGSYS SIGTRAP SIGURG SIGVTALRM SIGXCPU SIGXFSZ SIG_BLOCK SIG_SETMASK SIG_UNBLOCK SIGINFO SIGWINCH], [
+#if HAVE_SIGNAL_H
+#include <signal.h>
+#endif])
+
+AC_MSG_CHECKING([for _SC_GETGR_R_SIZE_MAX])
+AC_EGREP_CPP(we_have_that_sysconf_thing,
+[
+#include <unistd.h>
+#ifdef _SC_GETGR_R_SIZE_MAX
+we_have_that_sysconf_thing
+#endif
+],
+[AC_MSG_RESULT([yes])
+AC_DEFINE([HAVE_SC_GETGR_R_SIZE_MAX], [1], [Define to 1 if <unistd.h> defines _SC_GETGR_R_SIZE_MAX.])],
+[AC_MSG_RESULT([no])])
+
+AC_MSG_CHECKING([for _SC_GETPW_R_SIZE_MAX])
+AC_EGREP_CPP(we_have_that_sysconf_thing,
+[
+#include <unistd.h>
+#ifdef _SC_GETPW_R_SIZE_MAX
+we_have_that_sysconf_thing
+#endif
+],
+[AC_MSG_RESULT([yes])
+AC_DEFINE([HAVE_SC_GETPW_R_SIZE_MAX], [1], [Define to 1 if <unistd.h> defines _SC_GETPW_R_SIZE_MAX.])],
+[AC_MSG_RESULT([no])])
+
+dnl ---------- usleep ----------
+dnl --- stolen from guile configure ---
+
+### On some systems usleep has no return value.  If it does have one,
+### we'd like to return it; otherwise, we'll fake it.
+AC_CACHE_CHECK([return type of usleep], fptools_cv_func_usleep_return_type,
+  [AC_EGREP_HEADER(changequote(<, >)<void[      ]+usleep>changequote([, ]),
+                   unistd.h,
+                   [fptools_cv_func_usleep_return_type=void],
+                   [fptools_cv_func_usleep_return_type=int])])
+case "$fptools_cv_func_usleep_return_type" in
+  "void" )
+    AC_DEFINE([USLEEP_RETURNS_VOID], [1], [Define if the system headers declare usleep to return void.])
+  ;;
+esac
+
+###  POSIX.1003.1 unsetenv returns 0 or -1 (EINVAL), but older implementations
+###  in common use return void.
+AC_CACHE_CHECK([return type of unsetenv], fptools_cv_func_unsetenv_return_type,
+  [AC_EGREP_HEADER(changequote(<, >)<void[      ]+unsetenv>changequote([, ]),
+                   stdlib.h,
+                   [fptools_cv_func_unsetenv_return_type=void],
+                   [fptools_cv_func_unsetenv_return_type=int])])
+case "$fptools_cv_func_unsetenv_return_type" in
+  "void" )
+    AC_DEFINE([UNSETENV_RETURNS_VOID], [1], [Define if stdlib.h declares unsetenv to return void.])
+  ;;
+esac
+
+dnl On some hosts (e.g. SuSe and Ubuntu Linux) RTLD_NEXT and RTLD_DEFAULT are
+dnl not visible without setting _GNU_SOURCE, which we really don't want to.
+dnl Also see comments in System/Posix/DynamicLinker/Prim.hsc.
+AC_MSG_CHECKING(for RTLD_NEXT from dlfcn.h)
+AC_EGREP_CPP(yes,
+[
+ #include <dlfcn.h>
+ #ifdef RTLD_NEXT
+        yes
+ #endif
+], [
+  AC_MSG_RESULT(yes)
+  AC_DEFINE([HAVE_RTLDNEXT], [1], [Define to 1 if we can see RTLD_NEXT in dlfcn.h.])
+], [
+  AC_MSG_RESULT(no)
+  ])    
+
+AC_MSG_CHECKING(for RTLD_DEFAULT from dlfcn.h)
+AC_EGREP_CPP(yes,
+[
+ #include <dlfcn.h>
+ #ifdef RTLD_DEFAULT
+        yes
+ #endif
+], [
+  AC_MSG_RESULT(yes)
+  AC_DEFINE([HAVE_RTLDDEFAULT], [1], [Define to 1 if RTLD_DEFAULT is available.])
+], [
+  AC_MSG_RESULT(no)
+  ])    
+
+AC_CHECK_FUNCS(openpty,,
+   AC_CHECK_LIB(util,openpty,
+     [AC_DEFINE(HAVE_OPENPTY) EXTRA_LIBS="$EXTRA_LIBS util"],
+     AC_CHECK_LIB(bsd,openpty, [AC_DEFINE(HAVE_OPENPTY) EXTRA_LIBS="$EXTRA_LIBS bsd"])
+   )
+)
+
+AC_MSG_CHECKING(for /dev/ptmx)
+if test -r /dev/ptmx
+then
+  AC_MSG_RESULT(yes)
+  AC_DEFINE(HAVE_DEV_PTMX, 1,
+  [Define if we have /dev/ptmx.])
+else
+  AC_MSG_RESULT(no)
+fi
+
+AC_MSG_CHECKING(for /dev/ptc)
+if test -r /dev/ptc
+then
+  AC_MSG_RESULT(yes)
+  AC_DEFINE(HAVE_DEV_PTC, 1,
+  [Define if we have /dev/ptc.])
+else
+  AC_MSG_RESULT(no)
+fi
+
+# Avoid adding dl if absent or unneeded
+AC_SEARCH_LIBS([dlopen], [dl], [EXTRA_LIBS="$EXTRA_LIBS $ac_lib"])
+
+# -{l,}pthread goo
+AC_CANONICAL_TARGET
+
+AC_SEARCH_LIBS(sem_close, pthread,
+    [EXTRA_LIBS="$EXTRA_LIBS $ac_lib"],
+    [AC_MSG_NOTICE([Not found])])
+
+AC_SUBST([EXTRA_LIBS])
+AC_CONFIG_FILES([unix.buildinfo])
+
+AC_OUTPUT

unix/include/HsUnix.h

@@ -0,0 +1,120 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow 2002
+ *
+ * Definitions for package `unix' which are visible in Haskell land.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef HSUNIX_H
+#define HSUNIX_H
+
+#include "HsUnixConfig.h"
+#include "HsFFI.h"
+
+/* ultra-evil... */
+#undef PACKAGE_BUGREPORT
+#undef PACKAGE_NAME
+#undef PACKAGE_STRING
+#undef PACKAGE_TARNAME
+#undef PACKAGE_VERSION
+
+#include <stdlib.h>
+#include <stdio.h>
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+#ifdef HAVE_SYS_TIMES_H
+#include <sys/times.h>
+#endif
+#ifdef HAVE_SYS_TIME_H
+#include <sys/time.h>
+#endif
+#ifdef HAVE_SYS_RESOURCE_H
+#include <sys/resource.h>
+#endif
+#ifdef HAVE_SYS_WAIT_H
+#include <sys/wait.h>
+#endif
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+#ifdef HAVE_TIME_H
+#include <time.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#ifdef HAVE_UTIME_H
+#include <utime.h>
+#endif
+#ifdef HAVE_FCNTL_H
+#include <fcntl.h>
+#endif
+#ifdef HAVE_LIMITS_H
+#include <limits.h>
+#endif
+#ifdef HAVE_TERMIOS_H
+#include <termios.h>
+#endif
+#ifdef HAVE_SYS_UTSNAME_H
+#include <sys/utsname.h>
+#endif
+#ifdef HAVE_PWD_H
+#include <pwd.h>
+#endif
+#ifdef HAVE_GRP_H
+#include <grp.h>
+#endif
+#ifdef HAVE_DIRENT_H
+#include <dirent.h>
+#endif
+
+#if defined(HAVE_BSD_LIBUTIL_H)
+#include <bsd/libutil.h>
+#elif defined(HAVE_LIBUTIL_H)
+#include <libutil.h>
+#endif
+#ifdef HAVE_PTY_H
+#include <pty.h>
+#endif
+#ifdef HAVE_UTMP_H
+#include <utmp.h>
+#endif
+
+#include <dlfcn.h>
+
+#ifdef HAVE_SIGNAL_H
+#include <signal.h>
+#endif
+
+/* defined in rts/posix/Signals.c */
+extern HsInt nocldstop;
+
+/* defined in libc */
+extern char **environ;
+
+#ifdef HAVE_RTLDNEXT
+void *__hsunix_rtldNext (void);
+#endif
+
+#ifdef HAVE_RTLDDEFAULT
+void *__hsunix_rtldDefault (void);
+#endif
+
+/* O_SYNC doesn't exist on Mac OS X and (at least some versions of) FreeBSD,
+fall back to O_FSYNC, which should be the same */
+#ifndef O_SYNC
+# define O_SYNC O_FSYNC
+#endif
+
+// not part of POSIX, hence may not be always defined
+#ifndef WCOREDUMP
+# define WCOREDUMP(s) 0
+#endif
+
+// push a SVR4 STREAMS module; do nothing if STREAMS not available
+int __hsunix_push_module(int fd, const char *module);
+
+#endif

unix/include/execvpe.h

@@ -0,0 +1,13 @@
+/* ----------------------------------------------------------------------------
+   (c) The University of Glasgow 2004
+
+   Interface for code in cbits/execvpe.c
+   ------------------------------------------------------------------------- */
+
+#ifndef HSUNIX_EXECVPE_H
+#define HSUNIX_EXECVPE_H
+
+extern int
+__hsunix_execvpe(const char *name, char *const argv[], char *const envp[]);
+
+#endif

unix/install-sh

@@ -0,0 +1,527 @@
+#!/bin/sh
+# install - install a program, script, or datafile
+
+scriptversion=2011-11-20.07; # UTC
+
+# This originates from X11R5 (mit/util/scripts/install.sh), which was
+# later released in X11R6 (xc/config/util/install.sh) with the
+# following copyright and license.
+#
+# Copyright (C) 1994 X Consortium
+#
+# Permission is hereby granted, free of charge, to any person obtaining a copy
+# of this software and associated documentation files (the "Software"), to
+# deal in the Software without restriction, including without limitation the
+# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+# sell copies of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be included in
+# all copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL THE
+# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN
+# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC-
+# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+#
+# Except as contained in this notice, the name of the X Consortium shall not
+# be used in advertising or otherwise to promote the sale, use or other deal-
+# ings in this Software without prior written authorization from the X Consor-
+# tium.
+#
+#
+# FSF changes to this file are in the public domain.
+#
+# Calling this script install-sh is preferred over install.sh, to prevent
+# 'make' implicit rules from creating a file called install from it
+# when there is no Makefile.
+#
+# This script is compatible with the BSD install script, but was written
+# from scratch.
+
+nl='
+'
+IFS=" ""	$nl"
+
+# set DOITPROG to echo to test this script
+
+# Don't use :- since 4.3BSD and earlier shells don't like it.
+doit=${DOITPROG-}
+if test -z "$doit"; then
+  doit_exec=exec
+else
+  doit_exec=$doit
+fi
+
+# Put in absolute file names if you don't have them in your path;
+# or use environment vars.
+
+chgrpprog=${CHGRPPROG-chgrp}
+chmodprog=${CHMODPROG-chmod}
+chownprog=${CHOWNPROG-chown}
+cmpprog=${CMPPROG-cmp}
+cpprog=${CPPROG-cp}
+mkdirprog=${MKDIRPROG-mkdir}
+mvprog=${MVPROG-mv}
+rmprog=${RMPROG-rm}
+stripprog=${STRIPPROG-strip}
+
+posix_glob='?'
+initialize_posix_glob='
+  test "$posix_glob" != "?" || {
+    if (set -f) 2>/dev/null; then
+      posix_glob=
+    else
+      posix_glob=:
+    fi
+  }
+'
+
+posix_mkdir=
+
+# Desired mode of installed file.
+mode=0755
+
+chgrpcmd=
+chmodcmd=$chmodprog
+chowncmd=
+mvcmd=$mvprog
+rmcmd="$rmprog -f"
+stripcmd=
+
+src=
+dst=
+dir_arg=
+dst_arg=
+
+copy_on_change=false
+no_target_directory=
+
+usage="\
+Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE
+   or: $0 [OPTION]... SRCFILES... DIRECTORY
+   or: $0 [OPTION]... -t DIRECTORY SRCFILES...
+   or: $0 [OPTION]... -d DIRECTORIES...
+
+In the 1st form, copy SRCFILE to DSTFILE.
+In the 2nd and 3rd, copy all SRCFILES to DIRECTORY.
+In the 4th, create DIRECTORIES.
+
+Options:
+     --help     display this help and exit.
+     --version  display version info and exit.
+
+  -c            (ignored)
+  -C            install only if different (preserve the last data modification time)
+  -d            create directories instead of installing files.
+  -g GROUP      $chgrpprog installed files to GROUP.
+  -m MODE       $chmodprog installed files to MODE.
+  -o USER       $chownprog installed files to USER.
+  -s            $stripprog installed files.
+  -t DIRECTORY  install into DIRECTORY.
+  -T            report an error if DSTFILE is a directory.
+
+Environment variables override the default commands:
+  CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG
+  RMPROG STRIPPROG
+"
+
+while test $# -ne 0; do
+  case $1 in
+    -c) ;;
+
+    -C) copy_on_change=true;;
+
+    -d) dir_arg=true;;
+
+    -g) chgrpcmd="$chgrpprog $2"
+	shift;;
+
+    --help) echo "$usage"; exit $?;;
+
+    -m) mode=$2
+	case $mode in
+	  *' '* | *'	'* | *'
+'*	  | *'*'* | *'?'* | *'['*)
+	    echo "$0: invalid mode: $mode" >&2
+	    exit 1;;
+	esac
+	shift;;
+
+    -o) chowncmd="$chownprog $2"
+	shift;;
+
+    -s) stripcmd=$stripprog;;
+
+    -t) dst_arg=$2
+	# Protect names problematic for 'test' and other utilities.
+	case $dst_arg in
+	  -* | [=\(\)!]) dst_arg=./$dst_arg;;
+	esac
+	shift;;
+
+    -T) no_target_directory=true;;
+
+    --version) echo "$0 $scriptversion"; exit $?;;
+
+    --)	shift
+	break;;
+
+    -*)	echo "$0: invalid option: $1" >&2
+	exit 1;;
+
+    *)  break;;
+  esac
+  shift
+done
+
+if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then
+  # When -d is used, all remaining arguments are directories to create.
+  # When -t is used, the destination is already specified.
+  # Otherwise, the last argument is the destination.  Remove it from $@.
+  for arg
+  do
+    if test -n "$dst_arg"; then
+      # $@ is not empty: it contains at least $arg.
+      set fnord "$@" "$dst_arg"
+      shift # fnord
+    fi
+    shift # arg
+    dst_arg=$arg
+    # Protect names problematic for 'test' and other utilities.
+    case $dst_arg in
+      -* | [=\(\)!]) dst_arg=./$dst_arg;;
+    esac
+  done
+fi
+
+if test $# -eq 0; then
+  if test -z "$dir_arg"; then
+    echo "$0: no input file specified." >&2
+    exit 1
+  fi
+  # It's OK to call 'install-sh -d' without argument.
+  # This can happen when creating conditional directories.
+  exit 0
+fi
+
+if test -z "$dir_arg"; then
+  do_exit='(exit $ret); exit $ret'
+  trap "ret=129; $do_exit" 1
+  trap "ret=130; $do_exit" 2
+  trap "ret=141; $do_exit" 13
+  trap "ret=143; $do_exit" 15
+
+  # Set umask so as not to create temps with too-generous modes.
+  # However, 'strip' requires both read and write access to temps.
+  case $mode in
+    # Optimize common cases.
+    *644) cp_umask=133;;
+    *755) cp_umask=22;;
+
+    *[0-7])
+      if test -z "$stripcmd"; then
+	u_plus_rw=
+      else
+	u_plus_rw='% 200'
+      fi
+      cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;;
+    *)
+      if test -z "$stripcmd"; then
+	u_plus_rw=
+      else
+	u_plus_rw=,u+rw
+      fi
+      cp_umask=$mode$u_plus_rw;;
+  esac
+fi
+
+for src
+do
+  # Protect names problematic for 'test' and other utilities.
+  case $src in
+    -* | [=\(\)!]) src=./$src;;
+  esac
+
+  if test -n "$dir_arg"; then
+    dst=$src
+    dstdir=$dst
+    test -d "$dstdir"
+    dstdir_status=$?
+  else
+
+    # Waiting for this to be detected by the "$cpprog $src $dsttmp" command
+    # might cause directories to be created, which would be especially bad
+    # if $src (and thus $dsttmp) contains '*'.
+    if test ! -f "$src" && test ! -d "$src"; then
+      echo "$0: $src does not exist." >&2
+      exit 1
+    fi
+
+    if test -z "$dst_arg"; then
+      echo "$0: no destination specified." >&2
+      exit 1
+    fi
+    dst=$dst_arg
+
+    # If destination is a directory, append the input filename; won't work
+    # if double slashes aren't ignored.
+    if test -d "$dst"; then
+      if test -n "$no_target_directory"; then
+	echo "$0: $dst_arg: Is a directory" >&2
+	exit 1
+      fi
+      dstdir=$dst
+      dst=$dstdir/`basename "$src"`
+      dstdir_status=0
+    else
+      # Prefer dirname, but fall back on a substitute if dirname fails.
+      dstdir=`
+	(dirname "$dst") 2>/dev/null ||
+	expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+	     X"$dst" : 'X\(//\)[^/]' \| \
+	     X"$dst" : 'X\(//\)$' \| \
+	     X"$dst" : 'X\(/\)' \| . 2>/dev/null ||
+	echo X"$dst" |
+	    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+		   s//\1/
+		   q
+		 }
+		 /^X\(\/\/\)[^/].*/{
+		   s//\1/
+		   q
+		 }
+		 /^X\(\/\/\)$/{
+		   s//\1/
+		   q
+		 }
+		 /^X\(\/\).*/{
+		   s//\1/
+		   q
+		 }
+		 s/.*/./; q'
+      `
+
+      test -d "$dstdir"
+      dstdir_status=$?
+    fi
+  fi
+
+  obsolete_mkdir_used=false
+
+  if test $dstdir_status != 0; then
+    case $posix_mkdir in
+      '')
+	# Create intermediate dirs using mode 755 as modified by the umask.
+	# This is like FreeBSD 'install' as of 1997-10-28.
+	umask=`umask`
+	case $stripcmd.$umask in
+	  # Optimize common cases.
+	  *[2367][2367]) mkdir_umask=$umask;;
+	  .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;;
+
+	  *[0-7])
+	    mkdir_umask=`expr $umask + 22 \
+	      - $umask % 100 % 40 + $umask % 20 \
+	      - $umask % 10 % 4 + $umask % 2
+	    `;;
+	  *) mkdir_umask=$umask,go-w;;
+	esac
+
+	# With -d, create the new directory with the user-specified mode.
+	# Otherwise, rely on $mkdir_umask.
+	if test -n "$dir_arg"; then
+	  mkdir_mode=-m$mode
+	else
+	  mkdir_mode=
+	fi
+
+	posix_mkdir=false
+	case $umask in
+	  *[123567][0-7][0-7])
+	    # POSIX mkdir -p sets u+wx bits regardless of umask, which
+	    # is incompatible with FreeBSD 'install' when (umask & 300) != 0.
+	    ;;
+	  *)
+	    tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$
+	    trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0
+
+	    if (umask $mkdir_umask &&
+		exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1
+	    then
+	      if test -z "$dir_arg" || {
+		   # Check for POSIX incompatibilities with -m.
+		   # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or
+		   # other-writable bit of parent directory when it shouldn't.
+		   # FreeBSD 6.1 mkdir -m -p sets mode of existing directory.
+		   ls_ld_tmpdir=`ls -ld "$tmpdir"`
+		   case $ls_ld_tmpdir in
+		     d????-?r-*) different_mode=700;;
+		     d????-?--*) different_mode=755;;
+		     *) false;;
+		   esac &&
+		   $mkdirprog -m$different_mode -p -- "$tmpdir" && {
+		     ls_ld_tmpdir_1=`ls -ld "$tmpdir"`
+		     test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1"
+		   }
+		 }
+	      then posix_mkdir=:
+	      fi
+	      rmdir "$tmpdir/d" "$tmpdir"
+	    else
+	      # Remove any dirs left behind by ancient mkdir implementations.
+	      rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null
+	    fi
+	    trap '' 0;;
+	esac;;
+    esac
+
+    if
+      $posix_mkdir && (
+	umask $mkdir_umask &&
+	$doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir"
+      )
+    then :
+    else
+
+      # The umask is ridiculous, or mkdir does not conform to POSIX,
+      # or it failed possibly due to a race condition.  Create the
+      # directory the slow way, step by step, checking for races as we go.
+
+      case $dstdir in
+	/*) prefix='/';;
+	[-=\(\)!]*) prefix='./';;
+	*)  prefix='';;
+      esac
+
+      eval "$initialize_posix_glob"
+
+      oIFS=$IFS
+      IFS=/
+      $posix_glob set -f
+      set fnord $dstdir
+      shift
+      $posix_glob set +f
+      IFS=$oIFS
+
+      prefixes=
+
+      for d
+      do
+	test X"$d" = X && continue
+
+	prefix=$prefix$d
+	if test -d "$prefix"; then
+	  prefixes=
+	else
+	  if $posix_mkdir; then
+	    (umask=$mkdir_umask &&
+	     $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break
+	    # Don't fail if two instances are running concurrently.
+	    test -d "$prefix" || exit 1
+	  else
+	    case $prefix in
+	      *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;;
+	      *) qprefix=$prefix;;
+	    esac
+	    prefixes="$prefixes '$qprefix'"
+	  fi
+	fi
+	prefix=$prefix/
+      done
+
+      if test -n "$prefixes"; then
+	# Don't fail if two instances are running concurrently.
+	(umask $mkdir_umask &&
+	 eval "\$doit_exec \$mkdirprog $prefixes") ||
+	  test -d "$dstdir" || exit 1
+	obsolete_mkdir_used=true
+      fi
+    fi
+  fi
+
+  if test -n "$dir_arg"; then
+    { test -z "$chowncmd" || $doit $chowncmd "$dst"; } &&
+    { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } &&
+    { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false ||
+      test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1
+  else
+
+    # Make a couple of temp file names in the proper directory.
+    dsttmp=$dstdir/_inst.$$_
+    rmtmp=$dstdir/_rm.$$_
+
+    # Trap to clean up those temp files at exit.
+    trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0
+
+    # Copy the file name to the temp name.
+    (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") &&
+
+    # and set any options; do chmod last to preserve setuid bits.
+    #
+    # If any of these fail, we abort the whole thing.  If we want to
+    # ignore errors from any of these, just make sure not to ignore
+    # errors from the above "$doit $cpprog $src $dsttmp" command.
+    #
+    { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } &&
+    { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } &&
+    { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } &&
+    { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } &&
+
+    # If -C, don't bother to copy if it wouldn't change the file.
+    if $copy_on_change &&
+       old=`LC_ALL=C ls -dlL "$dst"	2>/dev/null` &&
+       new=`LC_ALL=C ls -dlL "$dsttmp"	2>/dev/null` &&
+
+       eval "$initialize_posix_glob" &&
+       $posix_glob set -f &&
+       set X $old && old=:$2:$4:$5:$6 &&
+       set X $new && new=:$2:$4:$5:$6 &&
+       $posix_glob set +f &&
+
+       test "$old" = "$new" &&
+       $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1
+    then
+      rm -f "$dsttmp"
+    else
+      # Rename the file to the real destination.
+      $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null ||
+
+      # The rename failed, perhaps because mv can't rename something else
+      # to itself, or perhaps because mv is so ancient that it does not
+      # support -f.
+      {
+	# Now remove or move aside any old file at destination location.
+	# We try this two ways since rm can't unlink itself on some
+	# systems and the destination file might be busy for other
+	# reasons.  In this case, the final cleanup might fail but the new
+	# file should still install successfully.
+	{
+	  test ! -f "$dst" ||
+	  $doit $rmcmd -f "$dst" 2>/dev/null ||
+	  { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null &&
+	    { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; }
+	  } ||
+	  { echo "$0: cannot unlink or rename $dst" >&2
+	    (exit 1); exit 1
+	  }
+	} &&
+
+	# Now rename the file to the real destination.
+	$doit $mvcmd "$dsttmp" "$dst"
+      }
+    fi || exit 1
+
+    trap '' 0
+  fi
+done
+
+# Local variables:
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "scriptversion="
+# time-stamp-format: "%:y-%02m-%02d.%02H"
+# time-stamp-time-zone: "UTC"
+# time-stamp-end: "; # UTC"
+# End:

unix/prologue.txt

@@ -0,0 +1 @@
+POSIX functionality.

unix/tests/.gitignore

@@ -0,0 +1,42 @@
+.hpc*/
+*.o
+*.hi
+*.comp.std*
+*.run.std*
+*.eventlog
+*.genscript
+*.exe
+*.interp.stderr
+*.interp.stdout
+
+# specific files
+/T1185
+/T3816
+/T8108
+/executeFile001
+/fdReadBuf001
+/fileStatus
+/fileStatusByteString
+/fileexist01
+/forkprocess01
+/getEnvironment01
+/getEnvironment02
+/getGroupEntryForName
+/getUserEntryForName
+/libposix/po003.out
+/libposix/posix002
+/libposix/posix003
+/libposix/posix004
+/libposix/posix005
+/libposix/posix006
+/libposix/posix009
+/libposix/posix010
+/libposix/posix014
+/processGroup001
+/processGroup002
+/queryfdoption01
+/resourceLimit
+/signals001
+/signals002
+/signals004
+/user001

unix/tests/Makefile

@@ -0,0 +1,7 @@
+# This Makefile runs the tests using GHC's testsuite framework.  It
+# assumes the package is part of a GHC build tree with the testsuite
+# installed in ../../../testsuite.
+
+TOP=../../../testsuite
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk

unix/tests/T1185.hs

@@ -0,0 +1,24 @@
+module Main where
+
+import Control.Concurrent
+import System.Posix
+import System.IO
+import System.Exit
+
+main =
+    do putStrLn "running..."
+       (stdinr, stdinw) <- createPipe
+       (stdoutr, stdoutw) <- createPipe
+       pid <- forkProcess $ do hw <- fdToHandle stdoutw
+                               hr <- fdToHandle stdinr
+                               closeFd stdinw
+                               hGetContents hr >>= hPutStr hw
+                               hClose hr
+                               hClose hw
+                               exitImmediately ExitSuccess
+       threadDelay 100000
+       closeFd stdoutw
+       closeFd stdinw
+       hr2 <- fdToHandle stdoutr
+       hGetContents hr2 >>= putStr
+       getProcessStatus True False pid >>= print

unix/tests/T1185.stdout

@@ -0,0 +1,2 @@
+running...
+Just (Exited ExitSuccess)

unix/tests/T3816.hs

@@ -0,0 +1,4 @@
+import System.Posix
+main = do
+  getAllGroupEntries >>= print . (>0) . length
+  getAllGroupEntries >>= print . (>0) . length

unix/tests/T3816.stdout

@@ -0,0 +1,2 @@
+True
+True

unix/tests/T8108.hs

@@ -0,0 +1,8 @@
+import Control.Monad
+import Control.Concurrent
+import System.Posix.User
+
+main = do
+    void $ forkIO $ forever $ getGroupEntryForID 0
+    void $ forkIO $ forever $ getGroupEntryForID 0
+    threadDelay (3*1000*1000)

unix/tests/all.T

@@ -0,0 +1,74 @@
+
+test('signals001',  normal, compile_and_run, ['-package unix -cpp'])
+test('signals002', [], compile_and_run, ['-package unix'])
+test('fileexist01', normal, compile_and_run, ['-package unix'])
+
+# test #4512
+test('forkprocess01', extra_ways(['threaded1_ls']), compile_and_run,
+     ['-package unix'])
+
+#
+# user001 may fail due to this bug in glibc:
+#   http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=466647
+#
+# Ticket #1487. The glibc implementation of getlogin, which is called by
+# getLoginName, requires that a terminal is connected to filedescriptor 0.
+# See: https://sourceware.org/git/?p=glibc.git;a=blob;f=sysdeps/unix/getlogin.c
+# Therefore we have to omit the 'ghci' way, because it relies on redirecting
+# stdin from file.
+#
+# But getLoginName also fails on GNU/Linux when using a terminal emulator
+# that doesn't write login records to /var/run/utmp. Running:
+#   $ logname
+# should print your login name. If it doesn't, the getLoginName test in user001
+# would fail, so we disabled that test.
+#
+test('user001', omit_ways(['ghci']), compile_and_run, ['-package unix'])
+test('resourceLimit', normal, compile_and_run, ['-package unix'])
+
+x86FreeBsdFail = when(platform('i386-unknown-freebsd'), expect_fail)
+
+test('queryfdoption01', [omit_ways(['ghci']), x86FreeBsdFail], compile_and_run,
+     ['-package unix'])
+test('getEnvironment01', x86FreeBsdFail, compile_and_run, ['-package unix'])
+test('getEnvironment02', x86FreeBsdFail, compile_and_run, ['-package unix'])
+test('getGroupEntryForName', [x86FreeBsdFail, exit_code(1)], compile_and_run,
+     ['-package unix'])
+test('getUserEntryForName', [x86FreeBsdFail, exit_code(1)], compile_and_run,
+     ['-package unix'])
+
+
+test('signals004', normal, compile_and_run, ['-package unix'])
+
+if ('threaded1' in config.run_ways):
+   only_threaded_ways = only_ways(['ghci','threaded1','threaded2'])
+else:
+   only_threaded_ways = skip
+
+test('fdReadBuf001', only_threaded_ways, compile_and_run, ['-package unix'])
+
+test('fileStatus',
+     extra_clean(['dir', 'regular', 'link-dir', 'link-regular']),
+     compile_and_run,
+     ['-package unix'])
+
+test('fileStatusByteString',
+     extra_clean(['dir', 'regular', 'link-dir', 'link-regular']),
+     compile_and_run,
+     ['-package unix'])
+
+
+test('T1185', normal, compile_and_run, ['-package unix'])
+
+# This test fails for me on x86/Linux with a "does not exist" error.
+# Running with strace shows it is trying to talk to winbindd (part of
+# Samba), so I think the failure has nothing to do with GHC.  Also it
+# works on a different machine that doesn't have Samba installed.
+#  --SDM 18/05/2010
+test('T3816', normal, compile_and_run, ['-package unix'])
+
+test('processGroup001', normal, compile_and_run, ['-package unix'])
+test('processGroup002', normal, compile_and_run, ['-package unix'])
+test('executeFile001', omit_ways(prof_ways + ['threaded2']), compile_and_run, ['-package unix'])
+
+test('T8108', normal, compile_and_run, ['-package unix'])

unix/tests/executeFile001.hs

@@ -0,0 +1,6 @@
+
+import System.Posix.Process
+
+main :: IO ()
+main = executeFile "echo" True ["arg1", "ar   g2"] Nothing
+

unix/tests/executeFile001.stdout

@@ -0,0 +1 @@
+arg1 ar   g2

unix/tests/fdReadBuf001.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+import System.Posix
+import Control.Monad
+import Foreign
+import Control.Concurrent
+import Data.Char
+import System.Exit
+
+size  = 10000
+block = 512
+
+main = do
+  (rd,wr) <- createPipe
+  let bytes = take size (map (fromIntegral.ord) (cycle ['a'..'z']))
+  allocaBytes size $ \p -> do
+    pokeArray p bytes
+    forkIO $ do r <- fdWriteBuf wr p (fromIntegral size)
+                when (fromIntegral r /= size) $ error "fdWriteBuf failed"
+  allocaBytes block $ \p -> do
+    let loop text = do
+           r <- fdReadBuf rd p block
+           let (chunk,rest) = splitAt (fromIntegral r) text
+           chars <- peekArray (fromIntegral r) p
+           when (chars /= chunk) $ error $ "mismatch: expected="++show chunk++", found="++show chars
+           when (null rest) $ exitWith ExitSuccess
+           loop rest
+    loop bytes

unix/tests/fileStatus.hs

@@ -0,0 +1,109 @@
+
+-- GHC trac #2969
+
+import System.Posix.Files
+import System.Posix.Directory
+import System.Posix.IO
+import Control.Exception as E
+import Control.Monad
+
+main = do
+  cleanup
+  fs <- testRegular
+  ds <- testDir
+  testSymlink fs ds
+  cleanup
+
+regular      = "regular"
+dir          = "dir"
+link_regular = "link-regular"
+link_dir     = "link-dir"
+
+testRegular = do
+  createFile regular ownerReadMode
+  (fs, _) <- getStatus regular
+  let expected = (False,False,False,True,False,False,False)
+      actual   = snd (statusElements fs)
+  when (actual /= expected) $
+    fail "unexpected file status bits for regular file"
+  return fs
+
+testDir = do
+  createDirectory dir ownerReadMode
+  (ds, _) <- getStatus dir
+  let expected = (False,False,False,False,True,False,False)
+      actual   = snd (statusElements ds)
+  when (actual /= expected) $
+    fail "unexpected file status bits for directory"
+  return ds
+
+testSymlink fs ds = do
+  createSymbolicLink regular link_regular
+  createSymbolicLink dir     link_dir
+  (fs', ls)  <- getStatus link_regular
+  (ds', lds) <- getStatus link_dir
+
+  let expected = (False,False,False,False,False,True,False)
+      actualF  = snd (statusElements ls)
+      actualD  = snd (statusElements lds)
+
+  when (actualF /= expected) $
+    fail "unexpected file status bits for symlink to regular file"
+
+  when (actualD /= expected) $
+    fail "unexpected file status bits for symlink to directory"
+
+  when (statusElements fs /= statusElements fs') $
+    fail "status for a file does not match when it's accessed via a symlink"
+
+  when (statusElements ds /= statusElements ds') $
+    fail "status for a directory does not match when it's accessed via a symlink"
+
+cleanup = do
+  ignoreIOExceptions $ removeDirectory dir
+  mapM_ (ignoreIOExceptions . removeLink)
+        [regular, link_regular, link_dir]
+
+ignoreIOExceptions io = io `E.catch`
+                        ((\_ -> return ()) :: IOException -> IO ())
+
+getStatus f = do
+  fs  <- getFileStatus f
+  ls  <- getSymbolicLinkStatus f
+
+  fd  <- openFd f ReadOnly defaultFileFlags
+  fs' <- getFdStatus fd
+
+  when (statusElements fs /= statusElements fs') $
+    fail "getFileStatus and getFdStatus give inconsistent results"
+
+  when (not (isSymbolicLink ls) && statusElements fs /= statusElements fs') $
+    fail $ "getFileStatus and getSymbolicLinkStatus give inconsistent results "
+        ++ "on a file that is not a symbolic link"
+
+  return (fs, ls)
+
+-- Yay for 20-element tuples!
+statusElements fs = (,)
+  (deviceID fs
+  ,fileMode fs
+  ,linkCount fs
+  ,fileOwner fs
+  ,fileGroup fs
+  ,specialDeviceID fs
+  ,fileSize fs
+  ,accessTime fs
+  ,accessTimeHiRes fs
+  ,modificationTime fs
+  ,modificationTimeHiRes fs
+  ,statusChangeTime fs
+  ,statusChangeTimeHiRes fs
+  )
+  (isBlockDevice fs
+  ,isCharacterDevice fs
+  ,isNamedPipe fs
+  ,isRegularFile fs
+  ,isDirectory fs
+  ,isSymbolicLink fs
+  ,isSocket fs
+  )

unix/tests/fileStatusByteString.hs

@@ -0,0 +1,108 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- GHC trac #2969
+
+import System.Posix.ByteString
+import Control.Exception as E
+import Control.Monad
+
+main = do
+  cleanup
+  fs <- testRegular
+  ds <- testDir
+  testSymlink fs ds
+  cleanup
+
+regular      = "regular2"
+dir          = "dir2"
+link_regular = "link-regular2"
+link_dir     = "link-dir2"
+
+testRegular = do
+  createFile regular ownerReadMode
+  (fs, _) <- getStatus regular
+  let expected = (False,False,False,True,False,False,False)
+      actual   = snd (statusElements fs)
+  when (actual /= expected) $
+    fail "unexpected file status bits for regular file"
+  return fs
+
+testDir = do
+  createDirectory dir ownerReadMode
+  (ds, _) <- getStatus dir
+  let expected = (False,False,False,False,True,False,False)
+      actual   = snd (statusElements ds)
+  when (actual /= expected) $
+    fail "unexpected file status bits for directory"
+  return ds
+
+testSymlink fs ds = do
+  createSymbolicLink regular link_regular
+  createSymbolicLink dir     link_dir
+  (fs', ls)  <- getStatus link_regular
+  (ds', lds) <- getStatus link_dir
+
+  let expected = (False,False,False,False,False,True,False)
+      actualF  = snd (statusElements ls)
+      actualD  = snd (statusElements lds)
+
+  when (actualF /= expected) $
+    fail "unexpected file status bits for symlink to regular file"
+
+  when (actualD /= expected) $
+    fail "unexpected file status bits for symlink to directory"
+
+  when (statusElements fs /= statusElements fs') $
+    fail "status for a file does not match when it's accessed via a symlink"
+
+  when (statusElements ds /= statusElements ds') $
+    fail "status for a directory does not match when it's accessed via a symlink"
+
+cleanup = do
+  ignoreIOExceptions $ removeDirectory dir
+  mapM_ (ignoreIOExceptions . removeLink)
+        [regular, link_regular, link_dir]
+
+ignoreIOExceptions io = io `E.catch`
+                        ((\_ -> return ()) :: IOException -> IO ())
+
+getStatus f = do
+  fs  <- getFileStatus f
+  ls  <- getSymbolicLinkStatus f
+
+  fd  <- openFd f ReadOnly defaultFileFlags
+  fs' <- getFdStatus fd
+
+  when (statusElements fs /= statusElements fs') $
+    fail "getFileStatus and getFdStatus give inconsistent results"
+
+  when (not (isSymbolicLink ls) && statusElements fs /= statusElements fs') $
+    fail $ "getFileStatus and getSymbolicLinkStatus give inconsistent results "
+        ++ "on a file that is not a symbolic link"
+
+  return (fs, ls)
+
+-- Yay for 20-element tuples!
+statusElements fs = (,)
+  (deviceID fs
+  ,fileMode fs
+  ,linkCount fs
+  ,fileOwner fs
+  ,fileGroup fs
+  ,specialDeviceID fs
+  ,fileSize fs
+  ,accessTime fs
+  ,accessTimeHiRes fs
+  ,modificationTime fs
+  ,modificationTimeHiRes fs
+  ,statusChangeTime fs
+  ,statusChangeTimeHiRes fs
+  )
+  (isBlockDevice fs
+  ,isCharacterDevice fs
+  ,isNamedPipe fs
+  ,isRegularFile fs
+  ,isDirectory fs
+  ,isSymbolicLink fs
+  ,isSocket fs
+  )

unix/tests/fileexist01.hs

@@ -0,0 +1,5 @@
+-- test System.Posix.fileExist
+import System.Posix
+main = do
+  fileExist "fileexist01.hs" >>= print
+  fileExist "does not exist" >>= print

unix/tests/fileexist01.stdout

@@ -0,0 +1,2 @@
+True
+False

unix/tests/forkprocess01.hs

@@ -0,0 +1,9 @@
+-- Test that we can call exitFailure in a forked process, and have it
+-- communicated properly to the parent.
+import System.Exit
+import System.Posix.Process
+main = do
+  p <- forkProcess $ exitWith (ExitFailure 72)
+  r <- getProcessStatus True False p
+  print r
+

unix/tests/forkprocess01.stdout

@@ -0,0 +1 @@
+Just (Exited (ExitFailure 72))

unix/tests/getEnvironment01.hs

@@ -0,0 +1,8 @@
+
+-- test for trac #781 (GHCi on x86_64, cannot link to static data in
+-- shared libs)
+
+import System.Posix.Env
+
+main = getEnvironment >>= (print . (0 <=) . length)
+

unix/tests/getEnvironment01.stdout

@@ -0,0 +1 @@
+True

unix/tests/getEnvironment02.hs

@@ -0,0 +1,8 @@
+
+-- test for trac #781 (GHCi on x86_64, cannot link to static data in
+-- shared libs)
+
+import System.Posix.Env.ByteString
+
+main = getEnvironment >>= (print . (0 <=) . length)
+

unix/tests/getEnvironment02.stdout

@@ -0,0 +1 @@
+True

unix/tests/getGroupEntryForName.hs

@@ -0,0 +1,5 @@
+
+import System.Posix.User
+
+main :: IO ()
+main = getGroupEntryForName "thisIsNotMeantToExist" >> return ()

unix/tests/getGroupEntryForName.stderr

@@ -0,0 +1 @@
+getGroupEntryForName: getGroupEntryForName: does not exist (no such group)

unix/tests/getUserEntryForName.hs

@@ -0,0 +1,5 @@
+
+import System.Posix.User
+
+main :: IO ()
+main = getUserEntryForName "thisIsNotMeantToExist" >> return ()

unix/tests/getUserEntryForName.stderr

@@ -0,0 +1 @@
+getUserEntryForName: getUserEntryForName: does not exist (no such user)

unix/tests/libposix/Makefile

@@ -0,0 +1,7 @@
+# This Makefile runs the tests using GHC's testsuite framework.  It
+# assumes the package is part of a GHC build tree with the testsuite
+# installed in ../../../testsuite.
+
+TOP=../../../../testsuite
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk

unix/tests/libposix/all.T

@@ -0,0 +1,16 @@
+test('posix002', [ reqlib('unix'), omit_ways(prof_ways), fragile_for(16550, ['threaded2']) ],
+                 compile_and_run, [''])
+
+# Skip on mingw32: assumes existence of 'pwd' and /tmp
+test('posix003', [when(opsys('mingw32'), skip), extra_clean(['po003.out'])],
+                 compile_and_run, [''])
+
+test('posix004', [ reqlib('unix') ], compile_and_run, [''])
+
+test('posix005', [reqlib('unix') ], compile_and_run, [''])
+
+test('posix006', reqlib('unix'), compile_and_run, [''])
+test('posix009', [ omit_ways(threaded_ways), reqlib('unix') ], compile_and_run, [''])
+test('posix010', reqlib('unix'), compile_and_run, [''])
+
+test('posix014', [ reqlib('unix') ], compile_and_run, [''])

unix/tests/libposix/posix002.hs

@@ -0,0 +1,4 @@
+import System.Posix.Process
+
+main =
+    executeFile "printenv" True [] (Just [("ONE","1"),("TWO","2")])

unix/tests/libposix/posix002.stdout

@@ -0,0 +1,2 @@
+ONE=1
+TWO=2

unix/tests/libposix/posix003.hs

@@ -0,0 +1,17 @@
+
+import Control.Monad
+import Data.Char
+import System.Exit
+import System.IO
+import System.Process
+
+main = do hw <- openFile "po003.out" WriteMode
+          ph <- runProcess "pwd" [] (Just "/dev") Nothing Nothing (Just hw) Nothing
+          ec <- waitForProcess ph
+          hClose hw
+          unless (ec == ExitSuccess) $ error "pwd failed"
+          hr <- openFile "po003.out" ReadMode
+          output <- hGetContents hr
+          putStrLn ("Got: " ++ show (filter (not . isSpace) output))
+          hClose hr
+

unix/tests/libposix/posix003.stdout

@@ -0,0 +1 @@
+Got: "/dev"

unix/tests/libposix/posix004.hs

@@ -0,0 +1,48 @@
+
+import System.Exit (ExitCode(..), exitWith)
+import System.Posix.Process
+import System.Posix.Signals
+
+main = do test1
+          test2
+          test3
+          test4
+          putStrLn "I'm happy."
+
+test1 = do
+    -- Force SIGFPE exceptions to not be ignored.  Under some
+    -- circumstances this test will be run with SIGFPE
+    -- ignored, see #7399
+    installHandler sigFPE Default Nothing
+    forkProcess $ raiseSignal floatingPointException
+    Just (pid, tc) <- getAnyProcessStatus True False
+    case tc of
+        Terminated sig _ | sig == floatingPointException -> return ()
+        _ -> error "unexpected termination cause"
+
+test2 = do
+    forkProcess $ exitImmediately (ExitFailure 42)
+    Just (pid, tc) <- getAnyProcessStatus True False
+    case tc of
+        Exited (ExitFailure 42) -> return ()
+        _ -> error "unexpected termination cause (2)"
+
+test3 = do
+    forkProcess $ exitImmediately ExitSuccess
+    Just (pid, tc) <- getAnyProcessStatus True False
+    case tc of
+        Exited ExitSuccess -> return ()
+        _ -> error "unexpected termination cause (3)"
+
+test4 = do
+    forkProcess $ raiseSignal softwareStop
+    Just (pid, tc) <- getAnyProcessStatus True True
+    case tc of
+        Stopped sig | sig == softwareStop -> do
+            signalProcess killProcess pid
+            Just (pid, tc) <- getAnyProcessStatus True True
+            case tc of
+                Terminated sig _ | sig == killProcess -> return ()
+                _ -> error "unexpected termination cause (5)"
+        _ -> error "unexpected termination cause (4)"
+

unix/tests/libposix/posix004.stdout

@@ -0,0 +1 @@
+I'm happy.

unix/tests/libposix/posix005.hs

@@ -0,0 +1,24 @@
+import Data.List (sort)
+import System.IO
+import System.Posix.Env
+
+printEnv :: IO ()
+printEnv = getEnvironment >>= print . sort
+
+main = do
+    hSetBuffering stdout NoBuffering
+    term <- getEnv "TERM"
+    maybe (return ()) putStrLn term
+    setEnvironment [("one","1"),("two","2")]
+    printEnv
+    setEnv "foo" "bar" True
+    printEnv
+    setEnv "foo" "baz" True
+    printEnv
+    setEnv "fu" "bar" True
+    printEnv
+    unsetEnv "foo"
+    printEnv
+    clearEnv
+    printEnv
+

unix/tests/libposix/posix005.stdout

@@ -0,0 +1,7 @@
+vt100
+[("one","1"),("two","2")]
+[("foo","bar"),("one","1"),("two","2")]
+[("foo","baz"),("one","1"),("two","2")]
+[("foo","baz"),("fu","bar"),("one","1"),("two","2")]
+[("fu","bar"),("one","1"),("two","2")]
+[]

unix/tests/libposix/posix006.hs

@@ -0,0 +1,18 @@
+
+import System.Posix.Time
+import System.Posix.Unistd
+import System.Posix.Signals
+
+main = do start <- epochTime
+          blockSignals reservedSignals -- see #4504
+          sleep 1
+          finish <- epochTime
+          let slept = finish - start
+          if slept >= 1 && slept <= 2
+              then putStrLn "OK"
+              else do putStr "Started: "
+                      print start
+                      putStr "Finished: "
+                      print finish
+                      putStr "Slept: "
+                      print slept

unix/tests/libposix/posix006.stdout

@@ -0,0 +1 @@
+OK

unix/tests/libposix/posix009.hs

@@ -0,0 +1,15 @@
+import System.Posix.Signals
+import System.Posix.Unistd
+
+main = do
+    putStrLn "Blocking real time alarms."
+    blockSignals (addSignal realTimeAlarm reservedSignals)
+    putStrLn "Scheduling an alarm in 2 seconds..."
+    scheduleAlarm 2
+    putStrLn "Sleeping 5 seconds."
+    sleep 5
+    putStrLn "Woken up"
+    ints <- getPendingSignals
+    putStrLn "Checking pending interrupts for RealTimeAlarm"
+    print (inSignalSet realTimeAlarm ints)
+

unix/tests/libposix/posix009.stdout

@@ -0,0 +1,6 @@
+Blocking real time alarms.
+Scheduling an alarm in 2 seconds...
+Sleeping 5 seconds.
+Woken up
+Checking pending interrupts for RealTimeAlarm
+True

unix/tests/libposix/posix010.hs

@@ -0,0 +1,16 @@
+import System.Posix
+
+main = do
+    root <- getUserEntryForName "root"
+    putStrLn (ue2String root)
+    root' <- getUserEntryForID (userID root)
+    putStrLn (ue2String root')
+    if homeDirectory root == homeDirectory root' &&
+       userShell     root == userShell     root'
+        then putStrLn "OK"
+        else putStrLn "Mismatch"
+
+ue2String ue = concat [name, ":", show uid, ":", show gid]
+    where name = userName ue
+          uid = userID ue
+          gid = userGroupID ue

unix/tests/libposix/posix010.stdout

@@ -0,0 +1,3 @@
+root:0:0
+root:0:0
+OK

unix/tests/libposix/posix014.hs

@@ -0,0 +1,13 @@
+-- !! Basic pipe usage
+module Main (main) where
+
+import System.Posix
+
+main = do
+  (rd, wd) <- createPipe
+  pid <- forkProcess $ do (str, _) <- fdRead rd 32
+                          putStrLn str
+  fdWrite wd "Hi, there - forked child calling"
+  getProcessStatus True False pid
+  return ()
+