@@ -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 | |||
@@ -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 | |||
@@ -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 = () | |||
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. | |||
@@ -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. |
@@ -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. |
@@ -0,0 +1,6 @@ | |||
module Main (main) where | |||
import Distribution.Simple | |||
main :: IO () | |||
main = defaultMainWithHooks autoconfUserHooks |
@@ -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 | |||
-} |
@@ -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 |
@@ -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) |
@@ -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 |
@@ -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 |
@@ -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 |
@@ -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 () |
@@ -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 () |
@@ -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 ()) |
@@ -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 () |
@@ -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 |
@@ -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 |
@@ -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 |
@@ -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 () |
@@ -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 | |||
@@ -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 |
@@ -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 |
@@ -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 |
@@ -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 |
@@ -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) } |
@@ -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) } |
@@ -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 |
@@ -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 | |||
@@ -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 |
@@ -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) | |||
-- ----------------------------------------------------------------------------- |
@@ -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 | |||
@@ -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 | |||
-} |
@@ -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 |
@@ -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 |
@@ -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 |
@@ -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 |
@@ -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 | |||
@@ -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 | |||
@@ -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 */ | |||
@@ -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 */ |
@@ -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 |
@@ -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 |
@@ -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 |
@@ -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 |
@@ -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 |
@@ -0,0 +1,2 @@ | |||
ghc-head: True | |||
unconstrained: False |
@@ -0,0 +1 @@ | |||
packages: . |
@@ -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 | |||
} |
@@ -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 | |||
} |
@@ -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 |
@@ -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 |
@@ -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 |
@@ -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 |
@@ -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: |
@@ -0,0 +1 @@ | |||
POSIX functionality. |
@@ -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 |
@@ -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 |
@@ -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 |
@@ -0,0 +1,2 @@ | |||
running... | |||
Just (Exited ExitSuccess) |
@@ -0,0 +1,4 @@ | |||
import System.Posix | |||
main = do | |||
getAllGroupEntries >>= print . (>0) . length | |||
getAllGroupEntries >>= print . (>0) . length |
@@ -0,0 +1,2 @@ | |||
True | |||
True |
@@ -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) |
@@ -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']) |
@@ -0,0 +1,6 @@ | |||
import System.Posix.Process | |||
main :: IO () | |||
main = executeFile "echo" True ["arg1", "ar g2"] Nothing | |||
@@ -0,0 +1 @@ | |||
arg1 ar g2 |
@@ -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 |
@@ -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 | |||
) |
@@ -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 | |||
) |
@@ -0,0 +1,5 @@ | |||
-- test System.Posix.fileExist | |||
import System.Posix | |||
main = do | |||
fileExist "fileexist01.hs" >>= print | |||
fileExist "does not exist" >>= print |
@@ -0,0 +1,2 @@ | |||
True | |||
False |
@@ -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 | |||
@@ -0,0 +1 @@ | |||
Just (Exited (ExitFailure 72)) |
@@ -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) | |||
@@ -0,0 +1 @@ | |||
True |
@@ -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) | |||
@@ -0,0 +1 @@ | |||
True |
@@ -0,0 +1,5 @@ | |||
import System.Posix.User | |||
main :: IO () | |||
main = getGroupEntryForName "thisIsNotMeantToExist" >> return () |
@@ -0,0 +1 @@ | |||
getGroupEntryForName: getGroupEntryForName: does not exist (no such group) |
@@ -0,0 +1,5 @@ | |||
import System.Posix.User | |||
main :: IO () | |||
main = getUserEntryForName "thisIsNotMeantToExist" >> return () |
@@ -0,0 +1 @@ | |||
getUserEntryForName: getUserEntryForName: does not exist (no such user) |
@@ -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 |
@@ -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, ['']) |
@@ -0,0 +1,4 @@ | |||
import System.Posix.Process | |||
main = | |||
executeFile "printenv" True [] (Just [("ONE","1"),("TWO","2")]) |
@@ -0,0 +1,2 @@ | |||
ONE=1 | |||
TWO=2 |
@@ -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 | |||
@@ -0,0 +1 @@ | |||
Got: "/dev" |
@@ -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)" | |||
@@ -0,0 +1 @@ | |||
I'm happy. |
@@ -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 | |||
@@ -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")] | |||
[] |
@@ -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 |
@@ -0,0 +1 @@ | |||
OK |
@@ -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) | |||
@@ -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 |
@@ -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 |
@@ -0,0 +1,3 @@ | |||
root:0:0 | |||
root:0:0 | |||
OK |
@@ -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 () | |||