hasufell/hpath
1
1
Fork 0
Code Issues 8 Pull Requests Releases Wiki Activity

Some some

Browse Source
This commit is contained in:
Julian Ospald 2020-04-14 11:27:28 +02:00
parent e194fdec91
commit eea53e7113
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
123 changed files with 14143 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.travis.yml
View File

@ -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

1
cabal.project
View File

@ -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

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

@ -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.

31
unix/LICENSE Normal file
View File

@ -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.

15
unix/README.md Normal file
View File

@ -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.

6
unix/Setup.hs Normal file
View File

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

189
unix/System/Posix.hs Normal file
View File

@ -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
-}

69
unix/System/Posix/ByteString.hs Normal file
View File

@ -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

127
unix/System/Posix/ByteString/FilePath.hsc Normal file
View File

@ -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)

164
unix/System/Posix/Directory.hsc Normal file
View File

@ -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

165
unix/System/Posix/Directory/ByteString.hsc Normal file
View File

@ -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

88
unix/System/Posix/Directory/Common.hsc Normal file
View File

@ -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

72
unix/System/Posix/DynamicLinker.hsc Normal file
View File

@ -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 ()

73
unix/System/Posix/DynamicLinker/ByteString.hsc Normal file
View File

@ -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 ()

92
unix/System/Posix/DynamicLinker/Common.hsc Normal file
View File

@ -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 ())

121
unix/System/Posix/DynamicLinker/Module.hsc Normal file
View File

@ -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 ()

79
unix/System/Posix/DynamicLinker/Module/ByteString.hsc Normal file
View File

@ -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

123
unix/System/Posix/DynamicLinker/Prim.hsc Normal file
View File

@ -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

205
unix/System/Posix/Env.hsc Normal file
View File

@ -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

184
unix/System/Posix/Env/ByteString.hsc Normal file
View File

@ -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 ()

63
unix/System/Posix/Error.hs Normal file
View File

@ -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

104
unix/System/Posix/Fcntl.hsc Normal file
View File

@ -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

448
unix/System/Posix/Files.hsc Normal file
View File

@ -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

448
unix/System/Posix/Files/ByteString.hsc Normal file
View File

@ -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

605
unix/System/Posix/Files/Common.hsc Normal file
View File

@ -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

92
unix/System/Posix/IO.hsc Normal file
View File

@ -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) }

92
unix/System/Posix/IO/ByteString.hsc Normal file
View File

@ -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) }

443
unix/System/Posix/IO/Common.hsc Normal file
View File

@ -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

125
unix/System/Posix/Process.hsc Normal file
View File

@ -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

136
unix/System/Posix/Process/ByteString.hsc Normal file
View File

@ -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

430
unix/System/Posix/Process/Common.hsc Normal file
View File

@ -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)
-- -----------------------------------------------------------------------------

78
unix/System/Posix/Process/Internals.hs Normal file
View File

@ -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

166
unix/System/Posix/Resource.hsc Normal file
View File

@ -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
-}

131
unix/System/Posix/Semaphore.hsc Normal file
View File

@ -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

91
unix/System/Posix/SharedMem.hsc Normal file
View File

@ -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

706
unix/System/Posix/Signals.hsc Normal file
View File

@ -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

47
unix/System/Posix/Signals/Exts.hsc Normal file
View File

@ -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

124
unix/System/Posix/Temp.hsc Normal file
View File

@ -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

124
unix/System/Posix/Temp/ByteString.hsc Normal file
View File

@ -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

219
unix/System/Posix/Terminal.hsc Normal file
View File

@ -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 */

226
unix/System/Posix/Terminal/ByteString.hsc Normal file
View File

@ -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 */

881
unix/System/Posix/Terminal/Common.hsc Normal file
View File

@ -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

41
unix/System/Posix/Time.hs Normal file
View File

@ -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

264
unix/System/Posix/Unistd.hsc Normal file
View File

@ -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

474
unix/System/Posix/User.hsc Normal file
View File

@ -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

49
unix/aclocal.m4 vendored Normal file
View File

@ -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

2
unix/cabal.haskell-ci Normal file
View File

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

1
unix/cabal.project Normal file
View File

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

116
unix/cbits/HsUnix.c Normal file
View File

@ -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
}

173
unix/cbits/execvpe.c Normal file
View File

@ -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
}

150
unix/changelog.md Normal file
View File

@ -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

1466
unix/config.guess vendored Executable file
View File

File diff suppressed because it is too large Load Diff

1836
unix/config.sub vendored Executable file
View File

File diff suppressed because it is too large Load Diff

240
unix/configure.ac Normal file
View File

@ -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

120
unix/include/HsUnix.h Normal file
View File

@ -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

13
unix/include/execvpe.h Normal file
View File

@ -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

527
unix/install-sh Executable file
View File

@ -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:

1
unix/prologue.txt Normal file
View File

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

42
unix/tests/.gitignore vendored Normal file
View File

@ -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

7
unix/tests/Makefile Normal file
View File

@ -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

24
unix/tests/T1185.hs Normal file
View File

@ -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

2
unix/tests/T1185.stdout Normal file
View File

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

4
unix/tests/T3816.hs Normal file
View File

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

2
unix/tests/T3816.stdout Normal file
View File

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

8
unix/tests/T8108.hs Normal file
View File

@ -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)

74
unix/tests/all.T Normal file
View File

@ -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'])

6
unix/tests/executeFile001.hs Normal file
View File

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

1
unix/tests/executeFile001.stdout Normal file
View File

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

27
unix/tests/fdReadBuf001.hs Normal file
View File

@ -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

109
unix/tests/fileStatus.hs Normal file
View File

@ -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
)

108
unix/tests/fileStatusByteString.hs Normal file
View File

@ -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
)

5
unix/tests/fileexist01.hs Normal file
View File

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

2
unix/tests/fileexist01.stdout Normal file
View File

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

9
unix/tests/forkprocess01.hs Normal file
View File

@ -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

1
unix/tests/forkprocess01.stdout Normal file
View File

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

8
unix/tests/getEnvironment01.hs Normal file
View File

@ -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)

1
unix/tests/getEnvironment01.stdout Normal file
View File

@ -0,0 +1 @@
True

8
unix/tests/getEnvironment02.hs Normal file
View File

@ -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)

1
unix/tests/getEnvironment02.stdout Normal file
View File

@ -0,0 +1 @@
True

5
unix/tests/getGroupEntryForName.hs Normal file
View File

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

1
unix/tests/getGroupEntryForName.stderr Normal file
View File

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

5
unix/tests/getUserEntryForName.hs Normal file
View File

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

1
unix/tests/getUserEntryForName.stderr Normal file
View File

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

7
unix/tests/libposix/Makefile Normal file
View File

@ -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

16
unix/tests/libposix/all.T Normal file
View File

@ -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, [''])

4
unix/tests/libposix/posix002.hs Normal file
View File

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

2
unix/tests/libposix/posix002.stdout Normal file
View File

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

17
unix/tests/libposix/posix003.hs Normal file
View File

@ -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

1
unix/tests/libposix/posix003.stdout Normal file
View File

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

48
unix/tests/libposix/posix004.hs Normal file
View File

@ -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)"

1
unix/tests/libposix/posix004.stdout Normal file
View File

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

24
unix/tests/libposix/posix005.hs Normal file
View File

@ -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

7
unix/tests/libposix/posix005.stdout Normal file
View File

@ -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")]
[]

18
unix/tests/libposix/posix006.hs Normal file
View File

@ -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

1
unix/tests/libposix/posix006.stdout Normal file
View File

@ -0,0 +1 @@
OK

15
unix/tests/libposix/posix009.hs Normal file
View File

@ -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)

6
unix/tests/libposix/posix009.stdout Normal file
View File

@ -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

16
unix/tests/libposix/posix010.hs Normal file
View File

@ -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

3
unix/tests/libposix/posix010.stdout Normal file
View File

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

13
unix/tests/libposix/posix014.hs Normal file
View File

@ -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 ()

Some files were not shown because too many files have changed in this diff Show More