diff options
32 files changed, 3949 insertions, 1857 deletions
diff --git a/System/Posix.hs b/System/Posix.hs index ad51792..7ad88a2 100644 --- a/System/Posix.hs +++ b/System/Posix.hs @@ -30,7 +30,10 @@ module System.Posix ( module System.Posix.User, module System.Posix.Resource, module System.Posix.Semaphore, - module System.Posix.SharedMem + module System.Posix.SharedMem, + module System.Posix.DynamicLinker, +-- XXX 'Module' type clashes with GHC +-- module System.Posix.DynamicLinker.Module ) where import System.Posix.Types @@ -48,6 +51,9 @@ 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 diff --git a/System/Posix/ByteString.hs b/System/Posix/ByteString.hs new file mode 100644 index 0000000..7ee8bdb --- /dev/null +++ b/System/Posix/ByteString.hs @@ -0,0 +1,69 @@ +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Safe #-} +#endif +----------------------------------------------------------------------------- +-- | +-- 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) +-- +-- POSIX 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 diff --git a/System/Posix/ByteString/FilePath.hsc b/System/Posix/ByteString/FilePath.hsc new file mode 100644 index 0000000..55cd16a --- /dev/null +++ b/System/Posix/ByteString/FilePath.hsc @@ -0,0 +1,123 @@ +#if __GLASGOW_HASKELL__ >= 701 +{-# 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 +import Foreign.C hiding ( + throwErrnoPath, + throwErrnoPathIf, + throwErrnoPathIf_, + throwErrnoPathIfNull, + throwErrnoPathIfMinus1, + throwErrnoPathIfMinus1_ ) + +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) diff --git a/System/Posix/Directory.hsc b/System/Posix/Directory.hsc index 48e7390..870795b 100644 --- a/System/Posix/Directory.hsc +++ b/System/Posix/Directory.hsc @@ -3,9 +3,10 @@ #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif + ----------------------------------------------------------------------------- -- | --- Module : System.Posix.Files +-- Module : System.Posix.Directory -- Copyright : (c) The University of Glasgow 2002 -- License : BSD-style (see the file libraries/base/LICENSE) -- @@ -13,7 +14,7 @@ -- Stability : provisional -- Portability : non-portable (requires POSIX) -- --- POSIX directory support +-- String-based POSIX directory support -- ----------------------------------------------------------------------------- @@ -42,6 +43,9 @@ import System.Posix.Error import System.Posix.Types import Foreign import Foreign.C + +import System.Posix.Directory.Common + #if __GLASGOW_HASKELL__ > 700 import System.Posix.Internals (withFilePath, peekFilePath) #elif __GLASGOW_HASKELL__ > 611 @@ -70,8 +74,6 @@ createDirectory name mode = foreign import ccall unsafe "mkdir" c_mkdir :: CString -> CMode -> IO CInt -newtype DirStream = DirStream (Ptr CDir) - -- | @openDirStream dir@ calls @opendir@ to obtain a -- directory stream for @dir@. openDirStream :: FilePath -> IO DirStream @@ -109,9 +111,6 @@ readDirStream (DirStream dirp) = then return [] else throwErrno "readDirStream" -type CDir = () -type CDirent = () - -- traversing directories foreign import ccall unsafe "__hscore_readdir" c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt @@ -122,45 +121,6 @@ foreign import ccall unsafe "__hscore_free_dirent" foreign import ccall unsafe "__hscore_d_name" d_name :: Ptr CDirent -> IO CString --- | @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 - -seekDirStream :: DirStream -> DirStreamOffset -> IO () -seekDirStream (DirStream dirp) (DirStreamOffset off) = - c_seekdir dirp off - -foreign import ccall unsafe "seekdir" - c_seekdir :: Ptr CDir -> COff -> IO () - -tellDirStream :: DirStream -> IO DirStreamOffset -tellDirStream (DirStream dirp) = do - off <- c_telldir dirp - return (DirStreamOffset off) - -foreign import ccall unsafe "telldir" - c_telldir :: Ptr CDir -> IO COff - -{- - Renamings of functionality provided via Directory interface, - kept around for b.wards compatibility and for having more POSIXy - names --} -- | @getWorkingDirectory@ calls @getcwd@ to obtain the name -- of the current working directory. @@ -206,10 +166,3 @@ removeDirectory path = foreign import ccall unsafe "rmdir" c_rmdir :: CString -> IO CInt - -changeWorkingDirectoryFd :: Fd -> IO () -changeWorkingDirectoryFd (Fd fd) = - throwErrnoIfMinus1Retry_ "changeWorkingDirectoryFd" (c_fchdir fd) - -foreign import ccall unsafe "fchdir" - c_fchdir :: CInt -> IO CInt diff --git a/System/Posix/Directory/ByteString.hsc b/System/Posix/Directory/ByteString.hsc new file mode 100644 index 0000000..9159d05 --- /dev/null +++ b/System/Posix/Directory/ByteString.hsc @@ -0,0 +1,155 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# 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 +-- +----------------------------------------------------------------------------- + +module System.Posix.Directory.ByteString ( + -- * Creating and removing directories + createDirectory, removeDirectory, + + -- * Reading directories + DirStream, + openDirStream, + readDirStream, + rewindDirStream, + closeDirStream, + DirStreamOffset, + tellDirStream, + seekDirStream, + + -- * The working dirctory + 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 ccall unsafe "__hsunix_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 = do + p <- mallocBytes long_path_size + go p long_path_size + where go p bytes = do + p' <- c_getcwd p (fromIntegral bytes) + if p' /= nullPtr + then do s <- peekFilePath p' + free p' + return s + else do errno <- getErrno + if errno == eRANGE + then do let bytes' = bytes * 2 + p'' <- reallocBytes p bytes' + go p'' bytes' + else throwErrno "getCurrentDirectory" + +foreign import ccall unsafe "getcwd" + c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar) + +foreign import ccall unsafe "__hsunix_long_path_size" + long_path_size :: Int + +-- | @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 diff --git a/System/Posix/Directory/Common.hsc b/System/Posix/Directory/Common.hsc new file mode 100644 index 0000000..9b49357 --- /dev/null +++ b/System/Posix/Directory/Common.hsc @@ -0,0 +1,80 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# 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 +-- +----------------------------------------------------------------------------- + +module System.Posix.Directory.Common ( + DirStream(..), CDir, CDirent, DirStreamOffset(..), + rewindDirStream, + closeDirStream, + seekDirStream, + tellDirStream, + changeWorkingDirectoryFd, + ) where + +import System.IO.Error +import System.Posix.Error +import System.Posix.Types +import Foreign +import Foreign.C + +newtype DirStream = DirStream (Ptr CDir) + +type CDir = () +type 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 + +seekDirStream :: DirStream -> DirStreamOffset -> IO () +seekDirStream (DirStream dirp) (DirStreamOffset off) = + c_seekdir dirp off + +foreign import ccall unsafe "seekdir" + c_seekdir :: Ptr CDir -> COff -> IO () + +tellDirStream :: DirStream -> IO DirStreamOffset +tellDirStream (DirStream dirp) = do + off <- c_telldir dirp + return (DirStreamOffset off) + +foreign import ccall unsafe "telldir" + c_telldir :: Ptr CDir -> IO COff + +changeWorkingDirectoryFd :: Fd -> IO () +changeWorkingDirectoryFd (Fd fd) = + throwErrnoIfMinus1Retry_ "changeWorkingDirectoryFd" (c_fchdir fd) + +foreign import ccall unsafe "fchdir" + c_fchdir :: CInt -> IO CInt diff --git a/System/Posix/DynamicLinker.hsc b/System/Posix/DynamicLinker.hsc index ac6efb0..7683fc3 100644 --- a/System/Posix/DynamicLinker.hsc +++ b/System/Posix/DynamicLinker.hsc @@ -48,13 +48,14 @@ module System.Posix.DynamicLinker ( where +import System.Posix.DynamicLinker.Common +import System.Posix.DynamicLinker.Prim + #include "HsUnix.h" -import System.Posix.DynamicLinker.Prim -import Control.Exception ( bracket ) +import Control.Exception ( bracket ) import Control.Monad ( liftM ) -import Foreign.Ptr ( Ptr, nullPtr, FunPtr, nullFunPtr ) -import Foreign.C.String +import Foreign #if __GLASGOW_HASKELL__ > 611 import System.Posix.Internals ( withFilePath ) #else @@ -67,39 +68,8 @@ dlopen path flags = do withFilePath path $ \ p -> do liftM DLHandle $ throwDLErrorIf "dlopen" (== nullPtr) $ c_dlopen p (packRTLDFlags flags) -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 - withDL :: String -> [RTLDFlags] -> (DL -> IO a) -> IO a withDL file flags f = bracket (dlopen file flags) (dlclose) f withDL_ :: String -> [RTLDFlags] -> (DL -> IO a) -> IO () withDL_ file flags f = withDL file flags f >> return () - --- |'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 () diff --git a/System/Posix/DynamicLinker/ByteString.hsc b/System/Posix/DynamicLinker/ByteString.hsc new file mode 100644 index 0000000..6525eb9 --- /dev/null +++ b/System/Posix/DynamicLinker/ByteString.hsc @@ -0,0 +1,70 @@ +#if __GLASGOW_HASKELL__ >= 701 +{-# 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 () diff --git a/System/Posix/DynamicLinker/Common.hsc b/System/Posix/DynamicLinker/Common.hsc new file mode 100644 index 0000000..2b5e0d9 --- /dev/null +++ b/System/Posix/DynamicLinker/Common.hsc @@ -0,0 +1,90 @@ +#if __GLASGOW_HASKELL__ >= 701 +{-# 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 ()) diff --git a/System/Posix/DynamicLinker/Module.hsc b/System/Posix/DynamicLinker/Module.hsc index c678fed..2e5d6fe 100644 --- a/System/Posix/DynamicLinker/Module.hsc +++ b/System/Posix/DynamicLinker/Module.hsc @@ -60,7 +60,8 @@ where #include "HsUnix.h" import System.Posix.DynamicLinker -import Foreign.Ptr ( Ptr, nullPtr, FunPtr ) +import System.Posix.DynamicLinker.Common +import Foreign.Ptr ( Ptr, nullPtr, FunPtr ) #if __GLASGOW_HASKELL__ > 611 import System.Posix.Internals ( withFilePath ) #else @@ -70,10 +71,6 @@ withFilePath :: FilePath -> (CString -> IO a) -> IO a withFilePath = withCString #endif --- abstract handle for dynamically loaded module (EXPORTED) --- -newtype Module = Module (Ptr ()) - unModule :: Module -> (Ptr ()) unModule (Module adr) = adr diff --git a/System/Posix/DynamicLinker/Module/ByteString.hsc b/System/Posix/DynamicLinker/Module/ByteString.hsc new file mode 100644 index 0000000..59f45e2 --- /dev/null +++ b/System/Posix/DynamicLinker/Module/ByteString.hsc @@ -0,0 +1,77 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# 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 diff --git a/System/Posix/DynamicLinker/Prim.hsc b/System/Posix/DynamicLinker/Prim.hsc index 2e5409e..9a21d77 100644 --- a/System/Posix/DynamicLinker/Prim.hsc +++ b/System/Posix/DynamicLinker/Prim.hsc @@ -30,7 +30,7 @@ module System.Posix.DynamicLinker.Prim ( packRTLDFlags, RTLDFlags(..), packDL, - DL(..) + DL(..), ) where diff --git a/System/Posix/Env/ByteString.hsc b/System/Posix/Env/ByteString.hsc new file mode 100644 index 0000000..70b3f73 --- /dev/null +++ b/System/Posix/Env/ByteString.hsc @@ -0,0 +1,165 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#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 -> IO (Maybe ByteString) +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 -> ByteString -> IO ByteString +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 darwin_HOST_OS +-- You should not access _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)] +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 -> IO () +#ifdef HAVE_UNSETENV + +unsetEnv name = B.useAsCString name $ \ s -> + throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s) + +foreign import ccall unsafe "__hsunix_unsetenv" + c_unsetenv :: CString -> IO CInt +#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 -> 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 -> ByteString -> 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 () diff --git a/System/Posix/Files.hsc b/System/Posix/Files.hsc index 5606388..5916d1a 100644 --- a/System/Posix/Files.hsc +++ b/System/Posix/Files.hsc @@ -89,13 +89,15 @@ module System.Posix.Files ( PathVar(..), getPathVar, getFdPathVar, ) where + +import Foreign +import Foreign.C + import System.Posix.Error import System.Posix.Types -import System.IO.Unsafe -import Data.Bits import System.Posix.Internals -import Foreign hiding (unsafePerformIO) -import Foreign.C +import System.Posix.Files.Common + #if __GLASGOW_HASKELL__ > 700 import System.Posix.Internals (withFilePath, peekFilePath) #elif __GLASGOW_HASKELL__ > 611 @@ -118,114 +120,7 @@ peekFilePathLen = peekCStringLen #endif -- ----------------------------------------------------------------------------- --- 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) +-- chmod() -- | @setFileMode path mode@ changes permission of the file given by @path@ -- to @mode@. This operation may fail with 'throwErrnoPathIfMinus1_' if @path@ @@ -238,25 +133,6 @@ setFileMode name m = withFilePath name $ \s -> do throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) --- | @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 - -- ----------------------------------------------------------------------------- -- access() @@ -298,92 +174,6 @@ access name flags = then return False else throwErrnoPath "fileAccess" name --- ----------------------------------------------------------------------------- --- 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 modification. -modificationTime :: FileStatus -> EpochTime --- | Time of last status change (i.e. owner, group, link count, mode, etc.). -statusChangeTime :: FileStatus -> EpochTime - -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) - --- | 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 -- | @getFileStatus path@ calls gets the @FileStatus@ information (user ID, -- size, access times, etc.) for the file @path@. @@ -397,16 +187,6 @@ getFileStatus path = do throwErrnoPathIfMinus1_ "getFileStatus" path (c_stat s p) return (FileStatus fp) --- | @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) - -- | 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. @@ -420,10 +200,10 @@ getSymbolicLinkStatus path = do throwErrnoPathIfMinus1_ "getSymbolicLinkStatus" path (c_lstat s p) return (FileStatus fp) -foreign import ccall unsafe "__hsunix_lstat" +foreign import ccall unsafe "__hsunix_lstat" c_lstat :: CString -> Ptr CStat -> IO CInt --- | @createNamedPipe fifo mode@ +-- | @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 @@ -546,17 +326,6 @@ setOwnerAndGroup name uid gid = do foreign import ccall unsafe "chown" c_chown :: CString -> CUid -> CGid -> IO CInt --- | 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 - #if HAVE_LCHOWN -- | Acts as 'setOwnerAndGroup' but does not follow symlinks (and thus -- changes permissions on the link itself). @@ -611,81 +380,9 @@ setFileSize file off = foreign import ccall unsafe "truncate" c_truncate :: CString -> COff -> IO CInt --- | 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 - - -- | @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 @@ -701,19 +398,3 @@ getPathVar name v = do foreign import ccall unsafe "pathconf" c_pathconf :: CString -> CInt -> IO CLong - - --- | @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 diff --git a/System/Posix/Files/ByteString.hsc b/System/Posix/Files/ByteString.hsc new file mode 100644 index 0000000..5853ab9 --- /dev/null +++ b/System/Posix/Files/ByteString.hsc @@ -0,0 +1,382 @@ +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- 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, + 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, touchFile, + + -- * 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 + +-- ----------------------------------------------------------------------------- +-- 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) + 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 -> + throwErrnoPathIfMinus1_ "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 ccall unsafe "__hsunix_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 ccall unsafe "__hsunix_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" file1 (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 + +-- ----------------------------------------------------------------------------- +-- utime() + +-- | @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) + +-- | @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) + +-- ----------------------------------------------------------------------------- +-- 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 ccall unsafe "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 diff --git a/System/Posix/Files/Common.hsc b/System/Posix/Files/Common.hsc new file mode 100644 index 0000000..2894244 --- /dev/null +++ b/System/Posix/Files/Common.hsc @@ -0,0 +1,408 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- 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, + 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, + ) where + +import System.Posix.Error +import System.Posix.Types +import System.IO.Unsafe +import Data.Bits +import System.Posix.Internals +import Foreign hiding (unsafePerformIO) +import Foreign.C + +-- ----------------------------------------------------------------------------- +-- 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 modification. +modificationTime :: FileStatus -> EpochTime +-- | Time of last status change (i.e. owner, group, link count, mode, etc.). +statusChangeTime :: FileStatus -> EpochTime + +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) + +-- | 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) + +-- ----------------------------------------------------------------------------- +-- 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 diff --git a/System/Posix/IO.hsc b/System/Posix/IO.hsc index c1a2d0c..c5b8e55 100644 --- a/System/Posix/IO.hsc +++ b/System/Posix/IO.hsc @@ -21,6 +21,8 @@ -- ----------------------------------------------------------------------------- +#include "HsUnix.h" + module System.Posix.IO ( -- * Input \/ Output @@ -66,36 +68,9 @@ module System.Posix.IO ( ) where -import System.IO -import System.IO.Error import System.Posix.Types import System.Posix.Error -import qualified System.Posix.Internals as Base - -import Foreign -import Foreign.C -import Data.Bits - -#ifdef __GLASGOW_HASKELL__ -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO.Handle -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) -#else -import GHC.IOBase -import GHC.Handle hiding (fdToHandle) -import qualified GHC.Handle -#endif -#endif - -#ifdef __HUGS__ -import Hugs.Prelude (IOException(..), IOErrorType(..)) -import qualified Hugs.IO (handleToFd, openFd) -#endif +import System.Posix.IO.Common #if __GLASGOW_HASKELL__ > 611 import System.Posix.Internals ( withFilePath ) @@ -104,81 +79,6 @@ withFilePath :: FilePath -> (CString -> IO a) -> IO a withFilePath = withCString #endif -#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 - --- |Correspond to some of the int flags from C's fcntl.h. -data OpenFileFlags = - OpenFileFlags { - append :: Bool, -- ^ O_APPEND - exclusive :: Bool, -- ^ O_EXCL - noctty :: Bool, -- ^ O_NOCTTY - nonBlock :: Bool, -- ^ O_NONBLOCK - trunc :: Bool -- ^ O_TRUNC - } - - --- |Default values for the 'OpenFileFlags' type. False for each of --- append, exclusive, noctty, nonBlock, and trunc. -defaultFileFlags :: OpenFileFlags -defaultFileFlags = - OpenFileFlags { - append = False, - exclusive = False, - noctty = False, - nonBlock = False, - trunc = False - } - - -- |Open and optionally create this file. See 'System.Posix.Files' -- for information on how to use the 'FileMode' type. openFd :: FilePath @@ -186,32 +86,10 @@ openFd :: FilePath -> Maybe FileMode -- ^Just x => creates the file with the given modes, Nothing => the file must exist. -> OpenFileFlags -> IO Fd -openFd name how maybe_mode (OpenFileFlags appendFlag exclusiveFlag nocttyFlag - nonBlockFlag truncateFlag) = do - withFilePath name $ \s -> do - fd <- throwErrnoPathIfMinus1Retry "openFd" name (c_open s 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) - - (creat, mode_w) = case maybe_mode 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 ccall unsafe "__hscore_open" - c_open :: CString -> CInt -> CMode -> IO CInt +openFd name how maybe_mode flags = do + withFilePath name $ \str -> do + throwErrnoPathIfMinus1Retry "openFd" name $ + open_ str how maybe_mode flags -- |Create and open this file in WriteOnly mode. A special case of -- 'openFd'. See 'System.Posix.Files' for information on how to use @@ -220,267 +98,3 @@ foreign import ccall unsafe "__hscore_open" createFile :: FilePath -> FileMode -> IO Fd createFile name mode = openFd name WriteOnly (Just mode) defaultFileFlags{ trunc=True } - --- |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) - -foreign import ccall unsafe "HsBase.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"). --- --- GHC only: this function has the side effect of putting the 'Fd' --- into non-blocking mode (@O_NONBLOCK@) due to the way the standard --- IO library implements multithreaded I\/O. --- -fdToHandle :: Fd -> IO Handle - -#ifdef __GLASGOW_HASKELL__ -#if __GLASGOW_HASKELL__ >= 611 -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)) - -fdToHandle fd = FD.fdToHandle (fromIntegral fd) - -#else - -handleToFd h = withHandle "handleToFd" h $ \ h_ -> do - -- converting a Handle into an Fd effectively means - -- letting go of the Handle; it is put into a closed - -- state as a result. - let fd = haFD h_ - flushWriteBufferOnly h_ - unlockFile (fromIntegral fd) - -- setting the Handle's fd to (-1) as well as its 'type' - -- to closed, is enough to disable the finalizer that - -- eventually is run on the Handle. - return (h_{haFD= (-1),haType=ClosedHandle}, Fd (fromIntegral fd)) - -fdToHandle fd = GHC.Handle.fdToHandle (fromIntegral fd) -#endif -#endif - -#ifdef __HUGS__ -handleToFd h = do - fd <- Hugs.IO.handleToFd h - return (fromIntegral fd) - -fdToHandle fd = do - mode <- fdGetMode (fromIntegral fd) - Hugs.IO.openFd (fromIntegral fd) False mode True -#endif - --- ----------------------------------------------------------------------------- --- 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" (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" (c_fcntl_read fd getflag) - let r' | val = r .|. opt_val - | otherwise = r .&. (complement opt_val) - throwErrnoIfMinus1_ "setFdOption" - (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 - -foreign import ccall unsafe "HsBase.h fcntl_read" - c_fcntl_read :: CInt -> CInt -> IO CInt - -foreign import ccall unsafe "HsBase.h fcntl_write" - c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt - --- ----------------------------------------------------------------------------- --- 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" (c_fcntl_lock fd (#const F_GETLK) p_flock) - result <- bytes2ProcessIDAndLock p_flock - return (maybeResult result) - where - maybeResult (_, (Unlock, _, _, _)) = Nothing - maybeResult x = Just x - -type CFLock = () - -foreign import ccall unsafe "HsBase.h fcntl_lock" - c_fcntl_lock :: CInt -> CInt -> Ptr CFLock -> IO CInt - -allocaLock :: FileLock -> (Ptr 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 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" (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" - (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 diff --git a/System/Posix/IO/ByteString.hsc b/System/Posix/IO/ByteString.hsc new file mode 100644 index 0000000..518a2ec --- /dev/null +++ b/System/Posix/IO/ByteString.hsc @@ -0,0 +1,102 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -XRecordWildCards #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# 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 Foreign.C hiding ( + throwErrnoPath, + throwErrnoPathIf, + throwErrnoPathIf_, + throwErrnoPathIfNull, + throwErrnoPathIfMinus1, + throwErrnoPathIfMinus1_ ) + +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 + -> Maybe FileMode -- ^Just x => creates the file with the given modes, Nothing => the file must exist. + -> OpenFileFlags + -> IO Fd +openFd name how maybe_mode flags = do + withFilePath name $ \str -> do + throwErrnoPathIfMinus1Retry "openFd" name $ + open_ str how maybe_mode 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 (Just mode) defaultFileFlags{ trunc=True } diff --git a/System/Posix/IO/Common.hsc b/System/Posix/IO/Common.hsc new file mode 100644 index 0000000..e4a7671 --- /dev/null +++ b/System/Posix/IO/Common.hsc @@ -0,0 +1,465 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -XRecordWildCards #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# 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 System.Posix.Error +import qualified System.Posix.Internals as Base + +import Foreign +import Foreign.C +import Data.Bits + +#ifdef __GLASGOW_HASKELL__ +#if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.Handle +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) +#else +import GHC.IOBase +import GHC.Handle hiding (fdToHandle) +import qualified GHC.Handle +#endif +#endif + +#ifdef __HUGS__ +import Hugs.Prelude (IOException(..), IOErrorType(..)) +import qualified Hugs.IO (handleToFd, openFd) +#endif + +#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 + +-- |Correspond to some of the int flags from C's fcntl.h. +data OpenFileFlags = + OpenFileFlags { + append :: Bool, -- ^ O_APPEND + exclusive :: Bool, -- ^ O_EXCL + noctty :: Bool, -- ^ O_NOCTTY + nonBlock :: Bool, -- ^ O_NONBLOCK + trunc :: Bool -- ^ O_TRUNC + } + + +-- |Default values for the 'OpenFileFlags' type. False for each of +-- append, exclusive, noctty, nonBlock, and trunc. +defaultFileFlags :: OpenFileFlags +defaultFileFlags = + OpenFileFlags { + append = False, + exclusive = False, + noctty = False, + nonBlock = False, + trunc = False + } + + +-- |Open and optionally create this file. See 'System.Posix.Files' +-- for information on how to use the 'FileMode' type. +open_ :: CString + -> OpenMode + -> Maybe FileMode -- ^Just x => creates the file with the given modes, Nothing => the file must exist. + -> OpenFileFlags + -> IO Fd +open_ str how maybe_mode (OpenFileFlags appendFlag exclusiveFlag nocttyFlag + nonBlockFlag truncateFlag) = 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) + + (creat, mode_w) = case maybe_mode 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 ccall unsafe "__hscore_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) + +foreign import ccall unsafe "HsBase.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"). +-- +-- GHC only: this function has the side effect of putting the 'Fd' +-- into non-blocking mode (@O_NONBLOCK@) due to the way the standard +-- IO library implements multithreaded I\/O. +-- +fdToHandle :: Fd -> IO Handle + +#ifdef __GLASGOW_HASKELL__ +#if __GLASGOW_HASKELL__ >= 611 +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)) + +fdToHandle fd = FD.fdToHandle (fromIntegral fd) + +#else + +handleToFd h = withHandle "handleToFd" h $ \ h_ -> do + -- converting a Handle into an Fd effectively means + -- letting go of the Handle; it is put into a closed + -- state as a result. + let fd = haFD h_ + flushWriteBufferOnly h_ + unlockFile (fromIntegral fd) + -- setting the Handle's fd to (-1) as well as its 'type' + -- to closed, is enough to disable the finalizer that + -- eventually is run on the Handle. + return (h_{haFD= (-1),haType=ClosedHandle}, Fd (fromIntegral fd)) + +fdToHandle fd = GHC.Handle.fdToHandle (fromIntegral fd) +#endif +#endif + +#ifdef __HUGS__ +handleToFd h = do + fd <- Hugs.IO.handleToFd h + return (fromIntegral fd) + +fdToHandle fd = do + mode <- fdGetMode (fromIntegral fd) + Hugs.IO.openFd (fromIntegral fd) False mode True +#endif + +-- ----------------------------------------------------------------------------- +-- 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" (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" (c_fcntl_read fd getflag) + let r' | val = r .|. opt_val + | otherwise = r .&. (complement opt_val) + throwErrnoIfMinus1_ "setFdOption" + (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 + +foreign import ccall unsafe "HsBase.h fcntl_read" + c_fcntl_read :: CInt -> CInt -> IO CInt + +foreign import ccall unsafe "HsBase.h fcntl_write" + c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt + +-- ----------------------------------------------------------------------------- +-- 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" (c_fcntl_lock fd (#const F_GETLK) p_flock) + result <- bytes2ProcessIDAndLock p_flock + return (maybeResult result) + where + maybeResult (_, (Unlock, _, _, _)) = Nothing + maybeResult x = Just x + +type CFLock = () + +foreign import ccall unsafe "HsBase.h fcntl_lock" + c_fcntl_lock :: CInt -> CInt -> Ptr CFLock -> IO CInt + +allocaLock :: FileLock -> (Ptr 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 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" (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" + (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 diff --git a/System/Posix/Process.hsc b/System/Posix/Process.hsc index 57779ce..9b1d72f 100644 --- a/System/Posix/Process.hsc +++ b/System/Posix/Process.hsc @@ -70,23 +70,10 @@ module System.Posix.Process ( #include "HsUnix.h" -import Foreign.C.Error -import Foreign.C.String -import Foreign.C.Types -import Foreign.Marshal.Alloc ( alloca, allocaBytes ) -import Foreign.Marshal.Array ( withArray0 ) -import Foreign.Marshal.Utils ( withMany ) -import Foreign.Ptr ( Ptr, nullPtr ) -import Foreign.StablePtr ( StablePtr, newStablePtr, freeStablePtr ) -import Foreign.Storable ( Storable(..) ) -import System.Exit +import Foreign +import Foreign.C import System.Posix.Process.Internals -import System.Posix.Types -import Control.Monad - -#ifdef __GLASGOW_HASKELL__ -import GHC.TopHandler ( runIO ) -#endif +import System.Posix.Process.Common #if __GLASGOW_HASKELL__ > 611 import System.Posix.Internals ( withFilePath ) @@ -99,216 +86,6 @@ withFilePath = withCString {-# CFILES cbits/HsUnix.c #-} #endif --- ----------------------------------------------------------------------------- --- 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 - }) - -type CTms = () - -foreign import ccall unsafe "__hsunix_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 - -#ifdef __GLASGOW_HASKELL__ -{- | '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. - -'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. - -GHC note: 'forkProcess' is not currently supported when using multiple -processors (@+RTS -N@), although it is supported with @-threaded@ as -long as only one processor is being used. --} - -forkProcess :: IO () -> IO ProcessID -forkProcess action = do - stable <- newStablePtr (runIO action) - pid <- throwErrnoIfMinus1 "forkProcess" (forkProcessPrim stable) - freeStablePtr stable - return pid - -foreign import ccall "forkProcess" forkProcessPrim :: StablePtr (IO ()) -> IO CPid -#endif /* __GLASGOW_HASKELL__ */ - -- | @'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 @@ -356,108 +133,3 @@ foreign import ccall unsafe "execv" foreign import ccall unsafe "execve" c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt --- ----------------------------------------------------------------------------- --- 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, because this call might block -foreign import ccall safe "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, '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. -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 one 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. -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. -exitImmediately :: ExitCode -> IO () -exitImmediately exitcode = c_exit (exitcode2Int exitcode) - 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." #-} --- | @'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." #-} --- | @'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) - --- ----------------------------------------------------------------------------- diff --git a/System/Posix/Process/ByteString.hsc b/System/Posix/Process/ByteString.hsc new file mode 100644 index 0000000..e7b902e --- /dev/null +++ b/System/Posix/Process/ByteString.hsc @@ -0,0 +1,140 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# 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 +#ifdef __GLASGOW_HASKELL__ + forkProcess, +#endif + 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 + +#ifdef __HUGS__ +{-# CFILES cbits/HsUnix.c #-} +#endif + +-- | @'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 + diff --git a/System/Posix/Process/Common.hsc b/System/Posix/Process/Common.hsc new file mode 100644 index 0000000..1e7299f --- /dev/null +++ b/System/Posix/Process/Common.hsc @@ -0,0 +1,405 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- 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 +#ifdef __GLASGOW_HASKELL__ + forkProcess, +#endif + + -- ** 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 + +#ifdef __GLASGOW_HASKELL__ +import GHC.TopHandler ( runIO ) +#endif + +#ifdef __HUGS__ +{-# CFILES cbits/HsUnix.c #-} +#endif + +-- ----------------------------------------------------------------------------- +-- 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 + }) + +type CTms = () + +foreign import ccall unsafe "__hsunix_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 + +#ifdef __GLASGOW_HASKELL__ +{- | '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. + +'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. + +GHC note: 'forkProcess' is not currently supported when using multiple +processors (@+RTS -N@), although it is supported with @-threaded@ as +long as only one processor is being used. +-} + +forkProcess :: IO () -> IO ProcessID +forkProcess action = do + stable <- newStablePtr (runIO action) + pid <- throwErrnoIfMinus1 "forkProcess" (forkProcessPrim stable) + freeStablePtr stable + return pid + +foreign import ccall "forkProcess" forkProcessPrim :: StablePtr (IO ()) -> IO CPid +#endif /* __GLASGOW_HASKELL__ */ + +-- ----------------------------------------------------------------------------- +-- 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, because this call might block +foreign import ccall safe "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, '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. +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 one 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. +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. +exitImmediately :: ExitCode -> IO () +exitImmediately exitcode = c_exit (exitcode2Int exitcode) + 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." #-} +-- | @'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." #-} +-- | @'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) + +-- ----------------------------------------------------------------------------- diff --git a/System/Posix/Temp/ByteString.hsc b/System/Posix/Temp/ByteString.hsc new file mode 100644 index 0000000..c5f8906 --- /dev/null +++ b/System/Posix/Temp/ByteString.hsc @@ -0,0 +1,82 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Temp.ByteString +-- Copyright : (c) Volker Stolz <vs@foldr.org> +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : vs@foldr.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- POSIX environment support +-- +----------------------------------------------------------------------------- + +module System.Posix.Temp.ByteString ( + + mkstemp + +{- Not ported (yet?): + tmpfile: can we handle FILE*? + tmpnam: ISO C, should go in base? + tempname: dito +-} + +) where + +#include "HsUnix.h" + +import System.IO (Handle) +import System.Posix.IO +import System.Posix.Types + +import Foreign.C hiding ( + throwErrnoPath, + throwErrnoPathIf, + throwErrnoPathIf_, + throwErrnoPathIfNull, + throwErrnoPathIfMinus1, + throwErrnoPathIfMinus1_ ) + +import System.Posix.ByteString.FilePath + +import Data.ByteString (ByteString) + + +-- |'mkstemp' - make a unique filename and open it for +-- reading\/writing (only safe on GHC & Hugs). +-- The returned 'RawFilePath' is the (possibly relative) path of +-- the created file, which is padded with 6 random characters. +mkstemp :: ByteString -> IO (RawFilePath, Handle) +mkstemp template = do +#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) + withFilePath template $ \ ptr -> do + fd <- throwErrnoIfMinus1 "mkstemp" (c_mkstemp ptr) + name <- peekFilePath ptr + h <- fdToHandle (Fd fd) + return (name, h) +#else + name <- mktemp (template ++ "XXXXXX") + h <- openFile name ReadWriteMode + return (name, h) + +-- |'mktemp' - make a unique file name +-- This function should be considered deprecated + +mktemp :: ByteString -> IO RawFilePath +mktemp template = do + withFilePath template $ \ ptr -> do + ptr <- throwErrnoIfNull "mktemp" (c_mktemp ptr) + peekFilePath ptr + +foreign import ccall unsafe "mktemp" + c_mktemp :: CString -> IO CString +#endif + +foreign import ccall unsafe "HsUnix.h __hscore_mkstemp" + c_mkstemp :: CString -> IO CInt + diff --git a/System/Posix/Terminal.hsc b/System/Posix/Terminal.hsc index c861a3f..0a2866a 100644 --- a/System/Posix/Terminal.hsc +++ b/System/Posix/Terminal.hsc @@ -73,439 +73,31 @@ module System.Posix.Terminal ( #include "HsUnix.h" -import Data.Bits -import Data.Char -import Foreign.C.Error ( errnoToIOError, throwErrnoIfMinus1, - throwErrnoIfMinus1_, throwErrnoIfNull ) -#ifndef HAVE_PTSNAME -import Foreign.C.Error ( eNOSYS ) -#endif -import Foreign.C.String ( CString, peekCString, withCString ) -import Foreign.C.Types -import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, mallocForeignPtrBytes ) -import Foreign.Marshal.Alloc ( alloca ) -import Foreign.Marshal.Utils ( copyBytes ) -import Foreign.Ptr ( Ptr, nullPtr, plusPtr ) -import Foreign.Storable ( Storable(..) ) -import System.IO.Error ( ioError ) -import System.IO.Unsafe ( unsafePerformIO ) -import System.Posix.IO ( OpenFileFlags(..), OpenMode(..), defaultFileFlags, - openFd ) +import Foreign +import Foreign.C +import System.Posix.Terminal.Common import System.Posix.Types --- ----------------------------------------------------------------------------- --- Terminal attributes - -type CTermios = () -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 - | MapCRtoLF -- ICRNL - | IgnoreBreak -- IGNBRK - | IgnoreCR -- IGNCR - | IgnoreParityErrors -- IGNPAR - | MapLFtoCR -- INLCR - | CheckParity -- INPCK - | StripHighBit -- ISTRIP - | StartStopInput -- IXOFF - | StartStopOutput -- IXON - | MarkParityErrors -- PARMRK - - -- output flags - | ProcessOutput -- OPOST - -- ToDo: ONLCR, OCRNL, ONOCR, ONLRET, OFILL, - -- NLDLY(NL0,NL1), CRDLY(CR0,CR1,CR2,CR2) - -- TABDLY(TAB0,TAB1,TAB2,TAB3) - -- BSDLY(BS0,BS1), VTDLY(VT0,VT1), FFDLY(FF0,FF1) - - -- control flags - | LocalMode -- CLOCAL - | ReadEnable -- CREAD - | TwoStopBits -- CSTOPB - | HangupOnClose -- HUPCL - | EnableParity -- PARENB - | OddParity -- PARODD - - -- local modes - | EnableEcho -- ECHO - | EchoErase -- ECHOE - | EchoKill -- ECHOK - | EchoLF -- ECHONL - | ProcessInput -- ICANON - | ExtendedFunctions -- IEXTEN - | KeyboardInterrupts -- ISIG - | NoFlushOnInterrupt -- NOFLSH - | BackgroundWriteInterrupt -- TOSTOP - -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 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 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 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 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 StartStopInput = testInputFlag (#const IXOFF) -terminalMode StartStopOutput = testInputFlag (#const IXON) -terminalMode MarkParityErrors = testInputFlag (#const PARMRK) -terminalMode ProcessOutput = testOutputFlag (#const OPOST) -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 - = B0 - | B50 - | B75 - | B110 - | B134 - | B150 - | B200 - | B300 - | B600 - | B1200 - | B1800 - | B2400 - | B4800 - | B9600 - | B19200 - | B38400 - | B57600 - | B115200 - -inputSpeed :: TerminalAttributes -> BaudRate -inputSpeed termios = unsafePerformIO $ do - withTerminalAttributes termios $ \p -> do - w <- c_cfgetispeed p - return (word2Baud w) - -foreign import ccall unsafe "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 ccall unsafe "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 ccall unsafe "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 ccall unsafe "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 ccall unsafe "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 ccall unsafe "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 ccall unsafe "tcsendbreak" - c_tcsendbreak :: CInt -> CInt -> IO CInt - --- | @drainOutput fd@ calls @tcdrain@ to block until all output --- written to @Fd@ @fd@ has been transmitted. -drainOutput :: Fd -> IO () -drainOutput (Fd fd) = throwErrnoIfMinus1_ "drainOutput" (c_tcdrain fd) - -foreign import ccall unsafe "tcdrain" - c_tcdrain :: CInt -> IO CInt - - -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 ccall unsafe "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 ccall unsafe "tcflow" - c_tcflow :: CInt -> CInt -> IO CInt +#if __GLASGOW_HASKELL__ > 700 +import System.Posix.Internals (withFilePath, peekFilePath) +#elif __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals (withFilePath) --- | @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) +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString -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 +peekFilePathLen :: CStringLen -> IO FilePath +peekFilePathLen = peekCStringLen +#else +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString --- | @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 +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString -foreign import ccall unsafe "isatty" - c_isatty :: CInt -> IO CInt +peekFilePathLen :: CStringLen -> IO FilePath +peekFilePathLen = peekCStringLen +#endif -- | @getTerminalName fd@ calls @ttyname@ to obtain a name associated -- with the terminal for @Fd@ @fd@. If @fd@ is associated @@ -514,7 +106,7 @@ foreign import ccall unsafe "isatty" getTerminalName :: Fd -> IO FilePath getTerminalName (Fd fd) = do s <- throwErrnoIfNull "getTerminalName" (c_ttyname fd) - peekCString s + peekFilePath s foreign import ccall unsafe "ttyname" c_ttyname :: CInt -> IO CString @@ -527,7 +119,7 @@ foreign import ccall unsafe "ttyname" getControllingTerminalName :: IO FilePath getControllingTerminalName = do s <- throwErrnoIfNull "getControllingTerminalName" (c_ctermid nullPtr) - peekCString s + peekFilePath s foreign import ccall unsafe "ctermid" c_ctermid :: CString -> IO CString @@ -540,7 +132,7 @@ getSlaveTerminalName :: Fd -> IO FilePath #ifdef HAVE_PTSNAME getSlaveTerminalName (Fd fd) = do s <- throwErrnoIfNull "getSlaveTerminalName" (c_ptsname fd) - peekCString s + peekFilePath s foreign import ccall unsafe "__hsunix_ptsname" c_ptsname :: CInt -> IO CString @@ -549,261 +141,3 @@ getSlaveTerminalName _ = ioError (errnoToIOError "getSlaveTerminalName" eNOSYS Nothing Nothing) #endif --- | @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 -foreign import ccall unsafe "__hsunix_grantpt" - c_grantpt :: CInt -> IO CInt - -foreign import ccall unsafe "__hsunix_unlockpt" - c_unlockpt :: CInt -> IO CInt -#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 */ - --- ----------------------------------------------------------------------------- --- 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) -baud2Word B57600 = (#const B57600) -baud2Word B115200 = (#const B115200) - --- And convert a word back to a baud rate --- We really need some cpp macros here. - -word2Baud :: CSpeed -> BaudRate -word2Baud x = - if x == (#const B0) then B0 - else if x == (#const B50) then B50 - else if x == (#const B75) then B75 - else if x == (#const B110) then B110 - else if x == (#const B134) then B134 - else if x == (#const B150) then B150 - else if x == (#const B200) then B200 - else if x == (#const B300) then B300 - else if x == (#const B600) then B600 - else if x == (#const B1200) then B1200 - else if x == (#const B1800) then B1800 - else if x == (#const B2400) then B2400 - else if x == (#const B4800) then B4800 - else if x == (#const B9600) then B9600 - else if x == (#const B19200) then B19200 - else if x == (#const B38400) then B38400 - else if x == (#const B57600) then B57600 - else if x == (#const B115200) then B115200 - else 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 diff --git a/System/Posix/Terminal/ByteString.hsc b/System/Posix/Terminal/ByteString.hsc new file mode 100644 index 0000000..b3ca9a9 --- /dev/null +++ b/System/Posix/Terminal/ByteString.hsc @@ -0,0 +1,132 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# 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 + +import Foreign.C hiding ( + throwErrnoPath, + throwErrnoPathIf, + throwErrnoPathIf_, + throwErrnoPathIfNull, + throwErrnoPathIfMinus1, + throwErrnoPathIfMinus1_ ) + +import System.Posix.ByteString.FilePath + + +-- | @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. +getControllingTerminalName :: IO RawFilePath +getControllingTerminalName = do + s <- throwErrnoIfNull "getControllingTerminalName" (c_ctermid nullPtr) + peekFilePath s + +foreign import ccall unsafe "ctermid" + c_ctermid :: CString -> IO CString + +-- | @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 + +foreign import ccall unsafe "__hsunix_ptsname" + c_ptsname :: CInt -> IO CString +#else +getSlaveTerminalName _ = + ioError (errnoToIOError "getSlaveTerminalName" eNOSYS Nothing Nothing) +#endif + diff --git a/System/Posix/Terminal/Common.hsc b/System/Posix/Terminal/Common.hsc new file mode 100644 index 0000000..39a2e30 --- /dev/null +++ b/System/Posix/Terminal/Common.hsc @@ -0,0 +1,764 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- 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 +-- +----------------------------------------------------------------------------- + +module System.Posix.Terminal.Common ( + -- * 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, + + -- ** Pseudoterminal operations + openPseudoTerminal, + ) where + +#include "HsUnix.h" + +import Data.Bits +import Data.Char +import Foreign.C.Error ( errnoToIOError, throwErrnoIfMinus1, + throwErrnoIfMinus1_, throwErrnoIfNull ) +#ifndef HAVE_PTSNAME +import Foreign.C.Error ( eNOSYS ) +#endif +import Foreign.C.String ( CString, peekCString, withCString ) +import Foreign.C.Types +import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, mallocForeignPtrBytes ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Utils ( copyBytes ) +import Foreign.Ptr ( Ptr, nullPtr, plusPtr ) +import Foreign.Storable ( Storable(..) ) +import System.IO.Error ( ioError ) +import System.IO.Unsafe ( unsafePerformIO ) +import System.Posix.IO ( OpenFileFlags(..), OpenMode(..), defaultFileFlags, + openFd ) +import System.Posix.Types + +-- ----------------------------------------------------------------------------- +-- Terminal attributes + +type CTermios = () +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 + | MapCRtoLF -- ICRNL + | IgnoreBreak -- IGNBRK + | IgnoreCR -- IGNCR + | IgnoreParityErrors -- IGNPAR + | MapLFtoCR -- INLCR + | CheckParity -- INPCK + | StripHighBit -- ISTRIP + | StartStopInput -- IXOFF + | StartStopOutput -- IXON + | MarkParityErrors -- PARMRK + + -- output flags + | ProcessOutput -- OPOST + -- ToDo: ONLCR, OCRNL, ONOCR, ONLRET, OFILL, + -- NLDLY(NL0,NL1), CRDLY(CR0,CR1,CR2,CR2) + -- TABDLY(TAB0,TAB1,TAB2,TAB3) + -- BSDLY(BS0,BS1), VTDLY(VT0,VT1), FFDLY(FF0,FF1) + + -- control flags + | LocalMode -- CLOCAL + | ReadEnable -- CREAD + | TwoStopBits -- CSTOPB + | HangupOnClose -- HUPCL + | EnableParity -- PARENB + | OddParity -- PARODD + + -- local modes + | EnableEcho -- ECHO + | EchoErase -- ECHOE + | EchoKill -- ECHOK + | EchoLF -- ECHONL + | ProcessInput -- ICANON + | ExtendedFunctions -- IEXTEN + | KeyboardInterrupts -- ISIG + | NoFlushOnInterrupt -- NOFLSH + | BackgroundWriteInterrupt -- TOSTOP + +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 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 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 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 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 StartStopInput = testInputFlag (#const IXOFF) +terminalMode StartStopOutput = testInputFlag (#const IXON) +terminalMode MarkParityErrors = testInputFlag (#const PARMRK) +terminalMode ProcessOutput = testOutputFlag (#const OPOST) +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 + = B0 + | B50 + | B75 + | B110 + | B134 + | B150 + | B200 + | B300 + | B600 + | B1200 + | B1800 + | B2400 + | B4800 + | B9600 + | B19200 + | B38400 + | B57600 + | B115200 + +inputSpeed :: TerminalAttributes -> BaudRate +inputSpeed termios = unsafePerformIO $ do + withTerminalAttributes termios $ \p -> do + w <- c_cfgetispeed p + return (word2Baud w) + +foreign import ccall unsafe "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 ccall unsafe "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 ccall unsafe "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 ccall unsafe "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 ccall unsafe "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 ccall unsafe "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 ccall unsafe "tcsendbreak" + c_tcsendbreak :: CInt -> CInt -> IO CInt + +-- | @drainOutput fd@ calls @tcdrain@ to block until all output +-- written to @Fd@ @fd@ has been transmitted. +drainOutput :: Fd -> IO () +drainOutput (Fd fd) = throwErrnoIfMinus1_ "drainOutput" (c_tcdrain fd) + +foreign import ccall unsafe "tcdrain" + c_tcdrain :: CInt -> IO CInt + + +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 ccall unsafe "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 ccall unsafe "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 + +-- | @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 +foreign import ccall unsafe "__hsunix_grantpt" + c_grantpt :: CInt -> IO CInt + +foreign import ccall unsafe "__hsunix_unlockpt" + c_unlockpt :: CInt -> IO CInt +#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 */ + +-- ----------------------------------------------------------------------------- +-- 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) +baud2Word B57600 = (#const B57600) +baud2Word B115200 = (#const B115200) + +-- And convert a word back to a baud rate +-- We really need some cpp macros here. + +word2Baud :: CSpeed -> BaudRate +word2Baud x = + if x == (#const B0) then B0 + else if x == (#const B50) then B50 + else if x == (#const B75) then B75 + else if x == (#const B110) then B110 + else if x == (#const B134) then B134 + else if x == (#const B150) then B150 + else if x == (#const B200) then B200 + else if x == (#const B300) then B300 + else if x == (#const B600) then B600 + else if x == (#const B1200) then B1200 + else if x == (#const B1800) then B1800 + else if x == (#const B2400) then B2400 + else if x == (#const B4800) then B4800 + else if x == (#const B9600) then B9600 + else if x == (#const B19200) then B19200 + else if x == (#const B38400) then B38400 + else if x == (#const B57600) then B57600 + else if x == (#const B115200) then B115200 + else 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 diff --git a/tests/all.T b/tests/all.T index 4b888be..8f8a152 100644 --- a/tests/all.T +++ b/tests/all.T @@ -26,6 +26,7 @@ if config.platform == 'i386-unknown-freebsd': test('queryfdoption01', compose(omit_ways(['ghci']), compose(only_compiler_types(['ghc']), conf)), compile_and_run, ['-package unix']) test('getEnvironment01', conf, compile_and_run, ['-package unix']) +test('getEnvironment02', conf, compile_and_run, ['-package unix']) test('getGroupEntryForName', compose(conf, exit_code(1)), compile_and_run, ['-package unix']) test('getUserEntryForName', compose(conf, exit_code(1)), compile_and_run, @@ -46,6 +47,11 @@ test('fileStatus', compile_and_run, ['-package unix']) +test('fileStatusByteString', + extra_clean(['dir', 'regular', 'link-dir', 'link-regular']), + compile_and_run, + ['-package unix']) + test('1185', [ expect_fail_for(['threaded2']) ], compile_and_run, ['-package unix']) diff --git a/tests/fileStatus.hs b/tests/fileStatus.hs index a393d72..e1d1661 100644 --- a/tests/fileStatus.hs +++ b/tests/fileStatus.hs @@ -14,9 +14,14 @@ main = do testSymlink fs ds cleanup +regular = "regular" +dir = "dir" +link_regular = "link-regular" +link_dir = "link-dir" + testRegular = do - createFile "regular" ownerReadMode - (fs, _) <- getStatus "regular" + createFile regular ownerReadMode + (fs, _) <- getStatus regular let expected = (False,False,False,True,False,False,False) actual = snd (statusElements fs) when (actual /= expected) $ @@ -24,8 +29,8 @@ testRegular = do return fs testDir = do - createDirectory "dir" ownerReadMode - (ds, _) <- getStatus "dir" + createDirectory dir ownerReadMode + (ds, _) <- getStatus dir let expected = (False,False,False,False,True,False,False) actual = snd (statusElements ds) when (actual /= expected) $ @@ -33,10 +38,10 @@ testDir = do return ds testSymlink fs ds = do - createSymbolicLink "regular" "link-regular" - createSymbolicLink "dir" "link-dir" - (fs', ls) <- getStatus "link-regular" - (ds', lds) <- getStatus "link-dir" + 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) @@ -55,9 +60,9 @@ testSymlink fs ds = do fail "status for a directory does not match when it's accessed via a symlink" cleanup = do - ignoreIOExceptions $ removeDirectory "dir" + ignoreIOExceptions $ removeDirectory dir mapM_ (ignoreIOExceptions . removeLink) - ["regular", "link-regular", "link-dir"] + [regular, link_regular, link_dir] ignoreIOExceptions io = io `E.catch` ((\_ -> return ()) :: IOException -> IO ()) diff --git a/tests/fileStatusByteString.hs b/tests/fileStatusByteString.hs new file mode 100644 index 0000000..35d52d8 --- /dev/null +++ b/tests/fileStatusByteString.hs @@ -0,0 +1,105 @@ +{-# 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 Nothing 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 17-element tuples! +statusElements fs = (,) + (deviceID fs + ,fileMode fs + ,linkCount fs + ,fileOwner fs + ,fileGroup fs + ,specialDeviceID fs + ,fileSize fs + ,accessTime fs + ,modificationTime fs + ,statusChangeTime fs + ) + (isBlockDevice fs + ,isCharacterDevice fs + ,isNamedPipe fs + ,isRegularFile fs + ,isDirectory fs + ,isSymbolicLink fs + ,isSocket fs + ) diff --git a/tests/getEnvironment02.hs b/tests/getEnvironment02.hs new file mode 100644 index 0000000..be920df --- /dev/null +++ b/tests/getEnvironment02.hs @@ -0,0 +1,8 @@ + +-- test for trac #781 (GHCi on x86_64, cannot link to static data in +-- shared libs) + +import System.Posix.Env.ByteString + +main = getEnvironment >>= (print . (0 <=) . length) + diff --git a/tests/getEnvironment02.stdout b/tests/getEnvironment02.stdout new file mode 100644 index 0000000..0ca9514 --- /dev/null +++ b/tests/getEnvironment02.stdout @@ -0,0 +1 @@ +True @@ -27,19 +27,10 @@ Cabal-Version: >= 1.6 Library exposed-modules: System.Posix - System.Posix.DynamicLinker.Module - System.Posix.DynamicLinker.Prim - System.Posix.Directory - System.Posix.DynamicLinker - System.Posix.Env + System.Posix.ByteString + System.Posix.Error - System.Posix.Files - System.Posix.IO - System.Posix.Process - System.Posix.Process.Internals System.Posix.Resource - System.Posix.Temp - System.Posix.Terminal System.Posix.Time System.Posix.Unistd System.Posix.User @@ -47,7 +38,47 @@ Library System.Posix.Signals.Exts System.Posix.Semaphore System.Posix.SharedMem - build-depends: base >= 4.2 && < 4.5 + + System.Posix.ByteString.FilePath + + System.Posix.Directory + System.Posix.Directory.ByteString + + System.Posix.DynamicLinker.Module + System.Posix.DynamicLinker.Module.ByteString + System.Posix.DynamicLinker.Prim + System.Posix.DynamicLinker.Common + System.Posix.DynamicLinker.ByteString + System.Posix.DynamicLinker + + System.Posix.Files + System.Posix.Files.ByteString + + System.Posix.IO + System.Posix.IO.ByteString + + System.Posix.Env + System.Posix.Env.ByteString + + System.Posix.Process + System.Posix.Process.Internals + System.Posix.Process.ByteString + + System.Posix.Temp + System.Posix.Temp.ByteString + + System.Posix.Terminal + System.Posix.Terminal.ByteString + + other-modules: + System.Posix.Directory.Common + System.Posix.Files.Common + System.Posix.IO.Common + System.Posix.Process.Common + System.Posix.Terminal.Common + + build-depends: base >= 4.2 && < 4.5, + bytestring >= 0.9.2.0 && < 0.10 extensions: CPP, ForeignFunctionInterface, EmptyDataDecls if impl(ghc >= 7.1) extensions: NondecreasingIndentation |