├── prologue.txt ├── unix.buildinfo.in ├── cabal.project ├── Setup.hs ├── cabal.project.wasm32-wasi ├── System ├── Posix │ ├── Directory │ │ ├── Fd.hsc │ │ ├── Internals.hsc │ │ ├── ByteString.hsc │ │ └── PosixPath.hsc │ ├── Env │ │ ├── Internal.hsc │ │ └── ByteString.hsc │ ├── Signals │ │ └── Exts.hsc │ ├── Time.hs │ ├── Error.hs │ ├── DynamicLinker.hsc │ ├── DynamicLinker │ │ ├── ByteString.hsc │ │ ├── Common.hsc │ │ ├── Module │ │ │ └── ByteString.hsc │ │ ├── Module.hsc │ │ └── Prim.hsc │ ├── ByteString.hs │ ├── PosixString.hs │ ├── User │ │ └── Common.hsc │ ├── Process │ │ ├── Internals.hsc │ │ ├── ByteString.hsc │ │ └── PosixString.hsc │ ├── SharedMem.hsc │ ├── IO │ │ ├── PosixString.hsc │ │ └── ByteString.hsc │ ├── Process.hsc │ ├── Temp │ │ ├── ByteString.hsc │ │ └── PosixString.hsc │ ├── Directory.hsc │ ├── Temp.hsc │ ├── IO.hsc │ ├── Env.hsc │ ├── PosixPath │ │ └── FilePath.hsc │ ├── Terminal.hsc │ ├── Fcntl.hsc │ ├── ByteString │ │ └── FilePath.hsc │ └── Terminal │ │ └── ByteString.hsc └── Posix.hs ├── tests ├── Semaphore001.hs ├── T8108.hs ├── Semaphore002.hs ├── Terminal.hs ├── Posix014.hs ├── ResourceLimit.hs ├── ForkProcess01.hs ├── Signals002.hs ├── Posix009.hs ├── SemaphoreInterrupt.hs ├── Signals004.hs ├── PutEnv001.hs ├── FdReadBuf001.hs ├── DirEnt.hsc ├── ReadDirStream.hs ├── Posix004.hs ├── T13660.hs ├── Signals001.hs ├── FileStatusByteString.hs ├── FileStatus.hs └── FileExtendedStatus.hs ├── cabal.project.js ├── include ├── execvpe.h └── HsUnix.h ├── .gitignore ├── README.md ├── jsbits └── time.js ├── .github ├── ISSUE_TEMPLATE │ ├── feature_request.md │ └── bug_report.md └── workflows │ ├── ci-js.yml │ ├── ci-wasm32-wasi.yml │ └── ci.yml ├── test-wasm32-wasi.mjs ├── LICENSE ├── .cirrus.yml ├── aclocal.m4 └── cbits ├── HsUnix.c └── execvpe.c /prologue.txt: -------------------------------------------------------------------------------- 1 | POSIX functionality. -------------------------------------------------------------------------------- /unix.buildinfo.in: -------------------------------------------------------------------------------- 1 | extra-libraries: @EXTRA_LIBS@ 2 | install-includes: HsUnixConfig.h 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | tests: True 4 | 5 | constraints: 6 | tasty -unix, optparse-applicative -process 7 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Distribution.Simple 4 | 5 | main :: IO () 6 | main = defaultMainWithHooks autoconfUserHooks 7 | -------------------------------------------------------------------------------- /cabal.project.wasm32-wasi: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | package unix 4 | ghc-options: -Wno-unused-imports 5 | 6 | write-ghc-environment-files: always 7 | 8 | allow-newer: all:base 9 | -------------------------------------------------------------------------------- /System/Posix/Directory/Fd.hsc: -------------------------------------------------------------------------------- 1 | #include "HsUnix.h" 2 | 3 | module System.Posix.Directory.Fd ( 4 | unsafeOpenDirStreamFd 5 | ) where 6 | 7 | import System.Posix.Directory.Common 8 | -------------------------------------------------------------------------------- /tests/Semaphore001.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import System.Posix 4 | 5 | main :: IO () 6 | main = do 7 | sem <- semOpen "/test-001" OpenSemFlags {semCreate = True, semExclusive = False} stdFileMode 1 8 | semThreadWait sem 9 | semPost sem 10 | -------------------------------------------------------------------------------- /tests/T8108.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent 4 | import Control.Monad 5 | import System.Posix 6 | 7 | main :: IO () 8 | main = do 9 | void $ forkIO $ forever $ getGroupEntryForID 0 10 | void $ forkIO $ forever $ getGroupEntryForID 0 11 | threadDelay 3000000 12 | -------------------------------------------------------------------------------- /cabal.project.js: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | with-compiler: javascript-unknown-ghcjs-ghc 4 | with-hc-pkg: javascript-unknown-ghcjs-ghc-pkg 5 | 6 | package unix 7 | ghc-options: -Wno-unused-imports 8 | 9 | write-ghc-environment-files: always 10 | 11 | allow-newer: all:base 12 | 13 | tests: True 14 | 15 | constraints: 16 | random < 1.2, 17 | tasty -unix, optparse-applicative -process, 18 | unix -os-string 19 | -------------------------------------------------------------------------------- /tests/Semaphore002.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Control.Concurrent 4 | import System.Posix 5 | 6 | main :: IO () 7 | main = do 8 | sem <- semOpen "/test-002" OpenSemFlags {semCreate = True, semExclusive = False} stdFileMode 0 9 | _ <- forkIO $ do 10 | threadDelay (1000*1000) 11 | semPost sem 12 | 13 | -- This should succeed after 1 second. 14 | semThreadWait sem 15 | semPost sem 16 | -------------------------------------------------------------------------------- /tests/Terminal.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.Posix 4 | import Test.Tasty.HUnit 5 | 6 | main :: IO () 7 | main = do 8 | (master, slave) <- openPseudoTerminal 9 | orig <- getTerminalAttributes slave 10 | let want = withInputSpeed orig B19200 11 | setTerminalAttributes slave want Immediately 12 | post <- getTerminalAttributes slave 13 | closeFd slave 14 | closeFd master 15 | inputSpeed post @?= B19200 16 | -------------------------------------------------------------------------------- /include/execvpe.h: -------------------------------------------------------------------------------- 1 | /* ---------------------------------------------------------------------------- 2 | (c) The University of Glasgow 2004 3 | 4 | Interface for code in cbits/execvpe.c 5 | ------------------------------------------------------------------------- */ 6 | 7 | #ifndef HSUNIX_EXECVPE_H 8 | #define HSUNIX_EXECVPE_H 9 | 10 | extern int 11 | __hsunix_execvpe(const char *name, char *const argv[], char *const envp[]); 12 | 13 | #endif 14 | -------------------------------------------------------------------------------- /tests/Posix014.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-deprecations #-} 2 | -- !! Basic pipe usage 3 | module Main (main) where 4 | 5 | import Control.Monad 6 | import System.Posix 7 | 8 | main :: IO () 9 | main = do 10 | let str = "Hi, there - forked child calling" 11 | (rd, wd) <- createPipe 12 | _ <- forkProcess $ void $ fdWrite wd str 13 | (str', _) <- fdRead rd (fromIntegral (length str)) 14 | unless (str == str') $ 15 | error "should have received an identical string" 16 | -------------------------------------------------------------------------------- /tests/ResourceLimit.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.Posix 4 | import Test.Tasty.HUnit 5 | 6 | main :: IO () 7 | main = do 8 | let soft = 5 9 | hard = 10 10 | setResourceLimit ResourceCPUTime 11 | (ResourceLimits (ResourceLimit soft) (ResourceLimit hard)) 12 | r <- getResourceLimit ResourceCPUTime 13 | soft @?= case softLimit r of 14 | ResourceLimit l -> l 15 | _ -> 0 16 | hard @?= case hardLimit r of 17 | ResourceLimit l -> l 18 | _ -> 0 19 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Specific generated files 2 | GNUmakefile 3 | autom4te.cache/ 4 | .cabal-sandbox/ 5 | cabal.project.local 6 | cabal.project.local~ 7 | cabal.sandbox.config 8 | config.log 9 | config.status 10 | config.sub 11 | configure 12 | dist/ 13 | dist-install/ 14 | dist-newstyle/ 15 | .ghc.environment.* 16 | ghc.mk 17 | include/HsUnixConfig.h 18 | include/HsUnixConfig.h.in 19 | .stack-work/ 20 | stack*.yaml.lock 21 | unix.buildinfo 22 | tests/.hpc.* 23 | tests/*.eventlog 24 | tests/*.genscript 25 | tests/*.o 26 | tests/*.hi 27 | tests/*.normalised 28 | *~ 29 | .vscode 30 | -------------------------------------------------------------------------------- /tests/ForkProcess01.hs: -------------------------------------------------------------------------------- 1 | -- Test that we can call exitFailure in a forked process, and have it 2 | -- communicated properly to the parent. 3 | 4 | module Main where 5 | 6 | import Control.Monad 7 | import System.Exit 8 | import System.Posix.Process 9 | 10 | main :: IO () 11 | main = do 12 | let exitCode = ExitFailure 72 13 | expected = Just (Exited exitCode) 14 | p <- forkProcess $ exitWith exitCode 15 | actual <- getProcessStatus True False p 16 | when (actual /= expected) $ 17 | error $ "mismatch: expected = " ++ show expected ++ ", actual = " ++ show actual 18 | -------------------------------------------------------------------------------- /tests/Signals002.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent 4 | import Control.Monad 5 | import System.Posix 6 | 7 | -- !!! test blockSignals, raiseSignal, unblockSignals, getPendingSignals 8 | 9 | main :: IO () 10 | main = do 11 | blockSignals ( userDefinedSignal1 `addSignal` emptySignalSet ) 12 | raiseSignal userDefinedSignal1 13 | set <- getPendingSignals 14 | unless (userDefinedSignal1 `inSignalSet` set) $ 15 | fail "signal is missing from the set" 16 | m <- newEmptyMVar 17 | _ <- installHandler userDefinedSignal1 18 | (Catch (putStrLn "hello" >> putMVar m ())) Nothing 19 | awaitSignal (Just emptySignalSet) 20 | takeMVar m 21 | -------------------------------------------------------------------------------- /tests/Posix009.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-deprecations #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad 6 | import System.Posix.Signals 7 | import System.Posix.Unistd 8 | 9 | main :: IO () 10 | main = do 11 | putStrLn "Blocking real time alarms." 12 | blockSignals (addSignal realTimeAlarm reservedSignals) 13 | putStrLn "Scheduling an alarm in 2 seconds..." 14 | _ <- scheduleAlarm 2 15 | putStrLn "Sleeping 5 seconds." 16 | _ <- sleep 5 17 | putStrLn "Woken up" 18 | ints <- getPendingSignals 19 | putStrLn "Checking pending interrupts for RealTimeAlarm" 20 | unless (inSignalSet realTimeAlarm ints) $ 21 | error "should have a pending real time alarm" 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | The `unix` Package [![Hackage](https://img.shields.io/hackage/v/unix.svg)](https://hackage.haskell.org/package/unix) [![GitHub Build Status](https://github.com/haskell/unix/workflows/ci/badge.svg)](https://github.com/haskell/unix/actions?query=workflow%3Aci) 2 | ================== 3 | 4 | See [`unix` on Hackage](http://hackage.haskell.org/package/unix) for 5 | more information. 6 | 7 | Installing from Git 8 | ------------------- 9 | 10 | To build this package using Cabal directly from Git, you must run 11 | `autoreconf -i` before the usual Cabal build steps (`cabal 12 | {configure,build,install}`). The program `autoreconf` is part of 13 | [GNU autoconf](http://www.gnu.org/software/autoconf/). There is no 14 | need to run the `configure` script: `cabal configure` will do this for 15 | you. 16 | -------------------------------------------------------------------------------- /jsbits/time.js: -------------------------------------------------------------------------------- 1 | function h$js_futimes(fd,atime,mtime) { 2 | if (!h$isNode()) { 3 | throw "h$js_futimes unsupported"; 4 | } 5 | try { 6 | h$fs.futimesSync(fd, atime, mtime); 7 | } catch(e) { 8 | h$setErrno(e); 9 | return -1; 10 | } 11 | return 0; 12 | } 13 | 14 | function h$js_utimes(path,path_offset,atime,mtime) { 15 | if (!h$isNode()) { 16 | throw "h$js_utimes unsupported"; 17 | } 18 | try { 19 | const d = h$decodeUtf8z(path, path_offset); 20 | h$fs.utimesSync(d, atime, mtime); 21 | } catch(e) { 22 | h$setErrno(e); 23 | return -1; 24 | } 25 | return 0; 26 | } 27 | 28 | function h$js_lutimes(path,path_offset,atime,mtime) { 29 | if (!h$isNode()) { 30 | throw "h$js_lutimes unsupported"; 31 | } 32 | try { 33 | const d = h$decodeUtf8z(path, path_offset); 34 | h$fs.lutimesSync(d, atime, mtime); 35 | } catch(e) { 36 | h$setErrno(e); 37 | return -1; 38 | } 39 | return 0; 40 | } 41 | 42 | -------------------------------------------------------------------------------- /tests/SemaphoreInterrupt.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Control.Concurrent 4 | import Control.Monad 5 | import Data.IORef 6 | import System.Posix 7 | 8 | main :: IO () 9 | main = do 10 | 11 | sem <- semOpen "/test-interrupt" OpenSemFlags {semCreate = True, semExclusive = False} stdFileMode 0 12 | ref <- newIORef False 13 | _ <- forkIO $ do 14 | res <- semWaitInterruptible sem 15 | writeIORef ref res 16 | threadDelay 100000 -- 100 ms 17 | semPost sem 18 | threadDelay 100000 -- 100 ms 19 | succ1 <- readIORef ref 20 | unless succ1 $ 21 | error "SemaphoreInterrupt: semWaitInterruptible failed" 22 | 23 | writeIORef ref False 24 | tid <- forkIO $ do 25 | res <- semWaitInterruptible sem 26 | writeIORef ref res 27 | threadDelay 100000 -- 100 ms 28 | killThread tid 29 | threadDelay 100000 -- 100 ms 30 | succ2 <- readIORef ref 31 | when succ2 $ 32 | error "SemaphoreInterrupt: semWaitInterruptible not interrupted" 33 | -------------------------------------------------------------------------------- /tests/Signals004.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | 3 | module Main where 4 | 5 | import Control.Concurrent 6 | import System.Posix 7 | import Control.Monad 8 | 9 | -- signal stress test: threads installing signal handlers while 10 | -- signals are being constantly thrown and caught. 11 | 12 | installers = 50 13 | -- too many signals overflows the IO manager's pipe buffer, this seems 14 | -- to be the most we can get away with: 15 | sigs = 400 16 | 17 | main = do 18 | c <- newChan 19 | m <- newEmptyMVar 20 | _ <- installHandler sigUSR1 (handler c) Nothing 21 | replicateM_ installers (forkIO $ do replicateM_ 1000 (install c); putMVar m ()) 22 | replicateM_ sigs (forkIO $ raiseSignal sigUSR1) 23 | replicateM_ installers (takeMVar m) 24 | replicateM_ sigs (readChan c) 25 | 26 | handler c = Catch (writeChan c ()) 27 | 28 | install c = do 29 | old <- installHandler sigUSR1 (handler c) Nothing 30 | installHandler sigUSR1 old Nothing 31 | -------------------------------------------------------------------------------- /tests/PutEnv001.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# OPTIONS_GHC -O0 -Wno-name-shadowing #-} 3 | 4 | module Main (main) where 5 | 6 | import Data.String ( fromString ) 7 | import System.Mem 8 | import System.Posix.Env.ByteString 9 | import Test.Tasty 10 | import Test.Tasty.HUnit 11 | 12 | -- test regression of incorrect 'free': https://github.com/haskell/unix/issues/68#issue-170072591 13 | main :: IO () 14 | main = do 15 | putEnv "foo=bar" 16 | defaultMain $ testGroup "All" [ test ] 17 | 18 | test :: TestTree 19 | test = testCase "putEnv" $ do 20 | performMinorGC 21 | env <- System.Posix.Env.ByteString.getEnv (fromString "foo") 22 | performMinorGC 23 | print env 24 | env <- System.Posix.Env.ByteString.getEnv (fromString "foo") 25 | performMinorGC 26 | print env 27 | env <- System.Posix.Env.ByteString.getEnv (fromString "foo") 28 | performMinorGC 29 | print env 30 | env <- System.Posix.Env.ByteString.getEnv (fromString "foo") 31 | print env 32 | env @?= Just (fromString "bar") 33 | -------------------------------------------------------------------------------- /tests/FdReadBuf001.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.Posix 4 | import Control.Monad 5 | import Foreign hiding (void) 6 | import Control.Concurrent 7 | import Data.Char 8 | import System.Exit 9 | 10 | main :: IO () 11 | main = do 12 | let size = 10000 13 | block = 512 14 | (rd,wr) <- createPipe 15 | let bytes = take size (map (fromIntegral.ord) (cycle ['a'..'z'])) 16 | void $ forkIO $ allocaBytes size $ \p -> do 17 | pokeArray p bytes 18 | r <- fdWriteBuf wr p (fromIntegral size) 19 | when (fromIntegral r /= size) $ error "fdWriteBuf failed" 20 | allocaBytes block $ \p -> do 21 | let loop text = do 22 | r <- fdReadBuf rd p (fromIntegral block) 23 | let (chunk,rest) = splitAt (fromIntegral r) text 24 | chars <- peekArray (fromIntegral r) p 25 | when (chars /= chunk) $ error $ "mismatch: expected="++show chunk++", found="++show chars 26 | when (null rest) $ exitWith ExitSuccess 27 | loop rest 28 | loop bytes 29 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/feature_request.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Feature request 3 | about: Suggest an enhancement to the package 4 | title: '' 5 | labels: 'status: needs triage, type: enhancement' 6 | assignees: '' 7 | 8 | --- 9 | 10 | **Is your feature request related to a problem? Please describe.** 11 | 12 | 13 | 14 | **Describe the solution you'd like** 15 | 16 | 17 | 18 | **Describe alternatives you've considered** 19 | 20 | 21 | 22 | **Additional context** 23 | 24 | 25 | 26 | **API breaking changes** 27 | 28 | 29 | 30 | **Posix compliance** 31 | 32 | 33 | -------------------------------------------------------------------------------- /System/Posix/Env/Internal.hsc: -------------------------------------------------------------------------------- 1 | module System.Posix.Env.Internal where 2 | 3 | #include "HsUnix.h" 4 | 5 | import Foreign 6 | import Foreign.C 7 | 8 | getEnvironmentPrim :: IO [Ptr CChar] 9 | getEnvironmentPrim = do 10 | c_environ <- getCEnviron 11 | if c_environ == nullPtr 12 | then return [] 13 | else do 14 | peekArray0 nullPtr c_environ 15 | 16 | getCEnviron :: IO (Ptr CString) 17 | #if HAVE__NSGETENVIRON 18 | -- You should not access @char **environ@ directly on Darwin in a bundle/shared library. 19 | -- See #2458 and http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html 20 | getCEnviron = nsGetEnviron >>= peek 21 | 22 | foreign import ccall unsafe "_NSGetEnviron" 23 | nsGetEnviron :: IO (Ptr (Ptr CString)) 24 | #else 25 | getCEnviron = _getCEnviron 26 | 27 | -- N.B. we cannot import `environ` directly in Haskell as it may be a weak symbol 28 | -- which requires special treatment by the compiler, which GHC is not equipped to 29 | -- provide. See GHC #24011. 30 | foreign import ccall unsafe "__hsunix_get_environ" 31 | _getCEnviron :: IO (Ptr CString) 32 | #endif 33 | -------------------------------------------------------------------------------- /test-wasm32-wasi.mjs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env node 2 | 3 | import child_process from "child_process"; 4 | import fs from "fs"; 5 | import util from "util"; 6 | 7 | const my_execFile = util.promisify(child_process.execFile); 8 | let warns_count = 0; 9 | for (const f of await fs.promises.readdir("tests")) { 10 | // odd linker errors 11 | if (f.startsWith('Semaphore')) continue; 12 | // Find self-contained test cases (aka doesn't rely on tasty) 13 | if (!f.endsWith(".hs")) continue; 14 | const s = await fs.promises.readFile(`tests/${f}`, "utf-8"); 15 | if (s.indexOf("Test.Tasty") !== -1) continue; 16 | 17 | // Compile the test case 18 | console.log(`\n${f}`); 19 | const r = await my_execFile("wasm32-wasi-ghc", [ 20 | `tests/${f}`, 21 | "-Wno-deprecations", 22 | "-optl-Wl,--warn-unresolved-symbols", 23 | ]); 24 | 25 | // Check for wasm-ld warnings that involves the archive generated by 26 | // cabal build 27 | const warns = r.stderr 28 | .split("\n") 29 | .filter((l) => l.indexOf("dist-newstyle") !== -1); 30 | warns_count += warns.length; 31 | console.log(warns); 32 | } 33 | 34 | // Use exit code to indicate failure 35 | process.exit(warns_count === 0 ? 0 : 1); 36 | -------------------------------------------------------------------------------- /System/Posix/Signals/Exts.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Safe #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : System.Posix.Signals.Exts 7 | -- Copyright : (c) The University of Glasgow 2002 8 | -- License : BSD-style (see the file libraries/base/LICENSE) 9 | -- 10 | -- Maintainer : libraries@haskell.org 11 | -- Stability : provisional 12 | -- Portability : non-portable (requires POSIX, includes Linuxisms/BSDisms) 13 | -- 14 | -- non-POSIX signal support commonly available 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | #include "HsUnixConfig.h" 19 | ##include "HsUnixConfig.h" 20 | 21 | #ifdef HAVE_SIGNAL_H 22 | #include 23 | #endif 24 | 25 | module System.Posix.Signals.Exts ( 26 | module System.Posix.Signals 27 | , sigINFO 28 | , sigWINCH 29 | , infoEvent 30 | , windowChange 31 | ) where 32 | 33 | import Foreign.C 34 | import System.Posix.Signals 35 | 36 | sigINFO :: CInt 37 | sigINFO = CONST_SIGINFO 38 | 39 | sigWINCH :: CInt 40 | sigWINCH = CONST_SIGWINCH 41 | 42 | 43 | infoEvent :: Signal 44 | infoEvent = sigINFO 45 | 46 | windowChange :: Signal 47 | windowChange = sigWINCH 48 | -------------------------------------------------------------------------------- /System/Posix/Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | {-# LANGUAGE Safe #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : System.Posix.Time 6 | -- Copyright : (c) The University of Glasgow 2002 7 | -- License : BSD-style (see the file libraries/base/LICENSE) 8 | -- 9 | -- Maintainer : libraries@haskell.org 10 | -- Stability : provisional 11 | -- Portability : non-portable (requires POSIX) 12 | -- 13 | -- POSIX Time support 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module System.Posix.Time ( 18 | epochTime, 19 | -- ToDo: lots more from sys/time.h 20 | -- how much already supported by System.Time? 21 | ) where 22 | 23 | import System.Posix.Types 24 | import Foreign 25 | import Foreign.C 26 | 27 | -- ----------------------------------------------------------------------------- 28 | -- epochTime 29 | 30 | -- | @epochTime@ calls @time@ to obtain the number of 31 | -- seconds that have elapsed since the epoch (Jan 01 00:00:00 GMT 1970). 32 | epochTime :: IO EpochTime 33 | epochTime = throwErrnoIfMinus1 "epochTime" (c_time nullPtr) 34 | 35 | foreign import capi unsafe "HsUnix.h time" 36 | c_time :: Ptr CTime -> IO CTime 37 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/bug_report.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Bug report 3 | about: Create a report to help us improve 4 | title: '' 5 | labels: 'status: needs triage, type: bug' 6 | assignees: '' 7 | 8 | --- 9 | 10 | 14 | 15 | ### Your environment 16 | 17 | Which OS do you use: 18 | 19 | Describe your project (alternative: link to the project): 20 | 21 | 22 | ### Steps to reproduce 23 | 24 | 25 | ### Expected behaviour 26 | 27 | 28 | ### Actual behaviour 29 | 30 | 31 | ### Include debug information 32 | 33 | 34 | 35 | ### API breaking changes 36 | 37 | 38 | 39 | ### Posix compliance 40 | 41 | 42 | -------------------------------------------------------------------------------- /tests/DirEnt.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | #include "HsUnixConfig.h" 4 | 5 | module Main (main) where 6 | #if !defined(HAVE_STRUCT_DIRENT_D_TYPE) 7 | main :: IO () 8 | main = do 9 | putStrLn "Skipping DirEnt test, since the system doesn't support d_type" 10 | #else 11 | 12 | import Control.Exception (bracket, finally) 13 | import Foreign.C.String (peekCString) 14 | import System.Exit 15 | import System.Posix.Directory 16 | import System.Posix.Directory.Internals 17 | 18 | peekDirEnt :: DirEnt -> IO (String, DirType) 19 | peekDirEnt dirEnt = do 20 | dName <- dirEntName dirEnt >>= peekCString 21 | dType <- dirEntType dirEnt 22 | return (dName, dType) 23 | 24 | testDirTypeOfDot :: DirStream -> IO () 25 | testDirTypeOfDot dirStream = go where 26 | go = readDirStreamWith peekDirEnt dirStream >>= \case 27 | Just (".", DirectoryType) -> do 28 | putStrLn "Got DirectoryType for . dir" 29 | exitSuccess 30 | Just (".", dType) -> die $ "Got " ++ show dType ++ " for . dir!" 31 | Just _ -> go 32 | Nothing -> die "Read cwd in Haskell and didn't find . dir!" 33 | 34 | main :: IO () 35 | main = do 36 | putStrLn "Running Haskell test of dirEntType" 37 | bracket (openDirStream ".") closeDirStream testDirTypeOfDot 38 | #endif 39 | -------------------------------------------------------------------------------- /.github/workflows/ci-js.yml: -------------------------------------------------------------------------------- 1 | name: ci-js 2 | 3 | on: 4 | - push 5 | - pull_request 6 | 7 | jobs: 8 | build: 9 | runs-on: ubuntu-22.04 10 | env: 11 | GHC: 9.12.1 12 | EMSDK: 3.1.74 13 | steps: 14 | - name: Install GHCup 15 | id: ghcup 16 | uses: haskell/ghcup-setup@v1 17 | with: 18 | cabal: latest-prerelease 19 | config: | 20 | url-source: 21 | - GHCupURL 22 | - cross 23 | - prereleases 24 | 25 | - uses: actions/checkout@v4 26 | 27 | - name: setup GHCJS 28 | run: | 29 | set -eux 30 | git clone https://github.com/emscripten-core/emsdk.git 31 | cd emsdk 32 | git checkout ${{ env.EMSDK }} 33 | ./emsdk install ${{ env.EMSDK }} 34 | ./emsdk activate ${{ env.EMSDK }} 35 | source ./emsdk_env.sh 36 | emconfigure ghcup install ghc --set javascript-unknown-ghcjs-${{ env.GHC }} 37 | 38 | - name: test 39 | run: | 40 | set -eux 41 | 42 | source ./emsdk/emsdk_env.sh 43 | autoreconf -i 44 | cabal update 45 | 46 | cabal --project-file=cabal.project.js build --with-hsc2hs=javascript-unknown-ghcjs-hsc2hs 47 | $(cabal --project-file=cabal.project.js list-bin T13660) 48 | $(cabal --project-file=cabal.project.js list-bin unix-tests) 49 | 50 | -------------------------------------------------------------------------------- /.github/workflows/ci-wasm32-wasi.yml: -------------------------------------------------------------------------------- 1 | name: ci-wasm32-wasi 2 | 3 | on: 4 | - push 5 | - pull_request 6 | 7 | jobs: 8 | build: 9 | runs-on: ubuntu-22.04 10 | env: 11 | GHC: 9.10.1.20241021 12 | steps: 13 | - name: Install GHCup 14 | id: ghcup 15 | uses: haskell/ghcup-setup@v1 16 | with: 17 | cabal: latest-prerelease 18 | config: | 19 | url-source: 20 | - GHCupURL 21 | - cross 22 | - prereleases 23 | 24 | - name: setup-ghc-wasm32-wasi 25 | run: | 26 | set -eux 27 | pushd $(mktemp -d) 28 | git clone https://gitlab.haskell.org/ghc/ghc-wasm-meta.git 29 | cd ghc-wasm-meta/ 30 | export SKIP_GHC=yes 31 | ./setup.sh 32 | popd 33 | source ~/.ghc-wasm/env 34 | ghc=$(ghcup -s cross list -r -t ghc -o | grep wasm | tail -1 | awk '{ print $2 }') 35 | ghcup install ghc --set ${ghc} -- --host=x86_64-linux --with-intree-gmp --with-system-libffi 36 | 37 | - uses: actions/checkout@v4 38 | 39 | - name: test 40 | run: | 41 | set -eux 42 | 43 | source ~/.ghc-wasm/env 44 | cabal update 45 | 46 | cp ~/.ghc-wasm/wasi-sdk/share/misc/config.* . 47 | autoreconf -i 48 | 49 | cabal --project-file=cabal.project.wasm32-wasi build -w wasm32-wasi-ghc --with-ghc-pkg=wasm32-wasi-ghc-pkg --with-hsc2hs=wasm32-wasi-hsc2hs --with-gcc=wasm32-wasi-clang 50 | 51 | ./test-wasm32-wasi.mjs 52 | -------------------------------------------------------------------------------- /System/Posix/Directory/Internals.hsc: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : System.Posix.Directory.Internals 4 | -- Copyright : (c) The University of Glasgow 2022 5 | -- License : BSD-style (see the file libraries/base/LICENSE) 6 | -- 7 | -- Maintainer : libraries@haskell.org 8 | -- Stability : provisional 9 | -- Portability : non-portable (requires POSIX) 10 | -- 11 | -- POSIX directory support (internal module, no PVP guarantees) 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module System.Posix.Directory.Internals ( 16 | DirStream(..), 17 | CDir, 18 | CDirent, 19 | DirStreamOffset(..), 20 | 21 | DirStreamWithPath(..), 22 | fromDirStreamWithPath, 23 | toDirStreamWithPath, 24 | DirEnt(..), 25 | dirEntName, 26 | dirEntType, 27 | DirType( DirType 28 | , UnknownType 29 | , NamedPipeType 30 | , CharacterDeviceType 31 | , DirectoryType 32 | , BlockDeviceType 33 | , RegularFileType 34 | , SymbolicLinkType 35 | , SocketType 36 | , WhiteoutType 37 | ), 38 | isUnknownType, 39 | isNamedPipeType, 40 | isCharacterDeviceType, 41 | isDirectoryType, 42 | isBlockDeviceType, 43 | isRegularFileType, 44 | isSymbolicLinkType, 45 | isSocketType, 46 | isWhiteoutType, 47 | getRealDirType, 48 | readDirStreamWith, 49 | readDirStreamWithPtr, 50 | ) where 51 | 52 | import System.Posix.Directory.Common 53 | -------------------------------------------------------------------------------- /tests/ReadDirStream.hs: -------------------------------------------------------------------------------- 1 | module ReadDirStream 2 | ( emptyDirStream 3 | , nonEmptyDirStream 4 | ) where 5 | 6 | import System.Posix.Files 7 | import System.Posix.Directory 8 | import System.Posix.IO 9 | import Control.Exception as E 10 | import Test.Tasty.HUnit 11 | 12 | emptyDirStream :: IO () 13 | emptyDirStream = do 14 | cleanup 15 | createDirectory dir ownerReadMode 16 | dir_p <- openDirStream dir 17 | entries <- readDirStreamEntries dir_p 18 | closeDirStream dir_p 19 | cleanup 20 | entries @?= [] 21 | where 22 | dir = "emptyDirStream" 23 | 24 | cleanup = do 25 | ignoreIOExceptions $ removeDirectory dir 26 | 27 | nonEmptyDirStream :: IO () 28 | nonEmptyDirStream = do 29 | cleanup 30 | createDirectory dir ownerModes 31 | _ <- createFile (dir ++ "/file") ownerReadMode 32 | dir_p <- openDirStream dir 33 | entries <- readDirStreamEntries dir_p 34 | closeDirStream dir_p 35 | cleanup 36 | entries @?= ["file"] 37 | where 38 | dir = "nonEmptyDirStream" 39 | 40 | cleanup = do 41 | ignoreIOExceptions $ removeLink $ dir ++ "/file" 42 | ignoreIOExceptions $ removeDirectory dir 43 | 44 | readDirStreamEntries :: DirStream -> IO [FilePath] 45 | readDirStreamEntries dir_p = do 46 | ment <- readDirStreamMaybe dir_p 47 | case ment of 48 | Nothing -> return [] 49 | Just "." -> readDirStreamEntries dir_p 50 | Just ".." -> readDirStreamEntries dir_p 51 | Just ent -> (ent :) <$> readDirStreamEntries dir_p 52 | 53 | ignoreIOExceptions :: IO () -> IO () 54 | ignoreIOExceptions io = io `E.catch` 55 | ((\_ -> return ()) :: E.IOException -> IO ()) 56 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The Glasgow Haskell Compiler License 2 | 3 | Copyright 2004, The University Court of the University of Glasgow. 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | - Redistributions of source code must retain the above copyright notice, 10 | this list of conditions and the following disclaimer. 11 | 12 | - Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | - Neither name of the University nor the names of its contributors may be 17 | used to endorse or promote products derived from this software without 18 | specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF 21 | GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 22 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 23 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE 25 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 27 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH 31 | DAMAGE. 32 | -------------------------------------------------------------------------------- /.cirrus.yml: -------------------------------------------------------------------------------- 1 | # task: 2 | # name: FreeBSD 3 | # freebsd_instance: 4 | # image_family: freebsd-13-2 5 | # install_script: pkg install -y ghc hs-cabal-install git autoconf 6 | # script: 7 | # - cabal update 8 | # - autoreconf -i 9 | # - cabal test --test-show-details=direct 10 | 11 | task: 12 | name: OpenBSD 13 | compute_engine_instance: 14 | image_project: pg-ci-images 15 | # See https://github.com/anarazel/pg-vm-images/blob/main/packer/openbsd.pkrvars.hcl 16 | image: family/pg-ci-openbsd-vanilla 17 | platform: openbsd 18 | install_script: pkg_add ghc cabal-install git autoconf-2.71 19 | script: 20 | - export AUTOCONF_VERSION=2.71 21 | - export CABAL_DIR=/tmp/.cabal 22 | - ghc --version 23 | - cabal --version 24 | - cabal update 25 | - autoreconf -i 26 | - cabal test --test-show-details=direct 27 | 28 | task: 29 | name: NetBSD 30 | compute_engine_instance: 31 | image_project: pg-ci-images 32 | # See https://github.com/anarazel/pg-vm-images/blob/main/packer/netbsd.pkrvars.hcl 33 | image: family/pg-ci-netbsd-vanilla 34 | platform: netbsd 35 | install_script: 36 | # Folders should be updated in line with 37 | # http://cdn.netbsd.org/pub/pkgsrc/packages/NetBSD/x86_64/ 38 | - export PKG_PATH="http://cdn.NetBSD.org/pub/pkgsrc/packages/NetBSD/$(uname -p)/$(uname -r|cut -f '1 2' -d.)/All/;http://cdn.netbsd.org/pub/pkgsrc/packages/NetBSD/x86_64/9.0_2023Q1/All/" 39 | - pkg_add ghc cabal-install git autoconf 40 | script: 41 | - export CABAL_DIR=/tmp/.cabal 42 | - ghc --version 43 | - cabal --version 44 | - cabal update 45 | - autoreconf -i 46 | # Select a build plan which does not involve 'text' 47 | - cabal test --test-show-details=direct --constraint 'text < 0' 48 | -------------------------------------------------------------------------------- /tests/Posix004.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.Exit 4 | import System.Posix.Process 5 | import System.Posix.Signals 6 | 7 | main :: IO () 8 | main = do 9 | test1 10 | test2 11 | test3 12 | test4 13 | 14 | test1 :: IO () 15 | test1 = do 16 | -- Force SIGFPE exceptions to not be ignored. Under some 17 | -- circumstances this test will be run with SIGFPE 18 | -- ignored, see #7399 19 | _ <- installHandler sigFPE Default Nothing 20 | _ <- forkProcess $ raiseSignal floatingPointException 21 | Just (_, tc) <- getAnyProcessStatus True False 22 | case tc of 23 | Terminated sig _ | sig == floatingPointException -> return () 24 | _ -> error "unexpected termination cause" 25 | 26 | test2 :: IO () 27 | test2 = do 28 | _ <- forkProcess $ exitImmediately (ExitFailure 42) 29 | Just (_, tc) <- getAnyProcessStatus True False 30 | case tc of 31 | Exited (ExitFailure 42) -> return () 32 | _ -> error "unexpected termination cause (2)" 33 | 34 | test3 :: IO () 35 | test3 = do 36 | _ <- forkProcess $ exitImmediately ExitSuccess 37 | Just (_, tc) <- getAnyProcessStatus True False 38 | case tc of 39 | Exited ExitSuccess -> return () 40 | _ -> error "unexpected termination cause (3)" 41 | 42 | test4 :: IO () 43 | test4 = do 44 | _ <- forkProcess $ raiseSignal softwareStop 45 | Just (pid, tc) <- getAnyProcessStatus True True 46 | case tc of 47 | Stopped sig | sig == softwareStop -> do 48 | signalProcess killProcess pid 49 | Just (_, tc') <- getAnyProcessStatus True True 50 | case tc' of 51 | Terminated sig' _ | sig' == killProcess -> return () 52 | _ -> error "unexpected termination cause (5)" 53 | _ -> error "unexpected termination cause (4)" 54 | 55 | -------------------------------------------------------------------------------- /System/Posix/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : System.Posix.Error 5 | -- Copyright : (c) The University of Glasgow 2002 6 | -- License : BSD-style (see the file libraries/base/LICENSE) 7 | -- 8 | -- Maintainer : libraries@haskell.org 9 | -- Stability : provisional 10 | -- Portability : non-portable (requires POSIX) 11 | -- 12 | -- POSIX error support 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module System.Posix.Error ( 17 | throwErrnoPath, 18 | throwErrnoPathIf, 19 | throwErrnoPathIf_, 20 | throwErrnoPathIfRetry, 21 | throwErrnoPathIfNull, 22 | throwErrnoPathIfNullRetry, 23 | throwErrnoPathIfMinus1, 24 | throwErrnoPathIfMinus1_, 25 | throwErrnoPathIfMinus1Retry, 26 | throwErrnoPathIfMinus1Retry_ 27 | ) where 28 | 29 | import Foreign hiding (void) 30 | import Foreign.C 31 | import Control.Monad 32 | 33 | throwErrnoPathIfMinus1Retry :: (Eq a, Num a) 34 | => String -> FilePath -> IO a -> IO a 35 | throwErrnoPathIfMinus1Retry loc path f = 36 | throwErrnoPathIfRetry (== -1) loc path f 37 | 38 | throwErrnoPathIfMinus1Retry_ :: (Eq a, Num a) 39 | => String -> FilePath -> IO a -> IO () 40 | throwErrnoPathIfMinus1Retry_ loc path f = 41 | void $ throwErrnoPathIfRetry (== -1) loc path f 42 | 43 | throwErrnoPathIfNullRetry :: String -> FilePath -> IO (Ptr a) -> IO (Ptr a) 44 | throwErrnoPathIfNullRetry loc path f = 45 | throwErrnoPathIfRetry (== nullPtr) loc path f 46 | 47 | throwErrnoPathIfRetry :: (a -> Bool) -> String -> FilePath -> IO a -> IO a 48 | throwErrnoPathIfRetry pr loc path f = 49 | do 50 | res <- f 51 | if pr res 52 | then do 53 | err <- getErrno 54 | if err == eINTR 55 | then throwErrnoPathIfRetry pr loc path f 56 | else throwErrnoPath loc path 57 | else return res 58 | 59 | -------------------------------------------------------------------------------- /System/Posix/DynamicLinker.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : System.Posix.DynamicLinker 5 | -- Copyright : (c) Volker Stolz 2003 6 | -- License : BSD-style (see the file libraries/base/LICENSE) 7 | -- 8 | -- Maintainer : vs@foldr.org 9 | -- Stability : provisional 10 | -- Portability : non-portable (requires POSIX) 11 | -- 12 | -- Dynamic linker support through dlopen() 13 | ----------------------------------------------------------------------------- 14 | 15 | module System.Posix.DynamicLinker ( 16 | 17 | module System.Posix.DynamicLinker.Prim, 18 | dlopen, 19 | dlsym, 20 | dlerror, 21 | dlclose, 22 | withDL, withDL_, 23 | undl, 24 | ) 25 | 26 | -- Usage: 27 | -- ****** 28 | -- 29 | -- Let's assume you want to open a local shared library \'foo\' (.\/libfoo.so) 30 | -- offering a function 31 | -- @char \* mogrify (char\*,int)@ 32 | -- and invoke @str = mogrify("test",1)@: 33 | -- 34 | -- 35 | -- type Fun = CString -> Int -> IO CString 36 | -- foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun 37 | -- 38 | -- withDL "libfoo.so" [RTLD_NOW] \$ \\ mod -> do 39 | -- funptr <- dlsym mod "mogrify" 40 | -- let fun = fun__ funptr 41 | -- withCString "test" \$ \\ str -> do 42 | -- strptr <- fun str 1 43 | -- strstr <- peekCString strptr 44 | -- ... 45 | -- 46 | 47 | where 48 | 49 | import System.Posix.DynamicLinker.Common 50 | import System.Posix.DynamicLinker.Prim 51 | 52 | #include "HsUnix.h" 53 | 54 | import Control.Exception ( bracket ) 55 | import Foreign 56 | import System.Posix.Internals ( withFilePath ) 57 | 58 | dlopen :: FilePath -> [RTLDFlags] -> IO DL 59 | dlopen path flags = withFilePath path $ \p -> DLHandle <$> 60 | throwDLErrorIf "dlopen" (== nullPtr) (c_dlopen p (packRTLDFlags flags)) 61 | 62 | withDL :: FilePath -> [RTLDFlags] -> (DL -> IO a) -> IO a 63 | withDL file flags f = bracket (dlopen file flags) (dlclose) f 64 | 65 | withDL_ :: FilePath -> [RTLDFlags] -> (DL -> IO a) -> IO () 66 | withDL_ file flags f = withDL file flags f >> return () 67 | -------------------------------------------------------------------------------- /aclocal.m4: -------------------------------------------------------------------------------- 1 | # FP_COMPUTE_INT(EXPRESSION, VARIABLE, INCLUDES, IF-FAILS) 2 | # -------------------------------------------------------- 3 | # Assign VARIABLE the value of the compile-time EXPRESSION using INCLUDES for 4 | # compilation. Execute IF-FAILS when unable to determine the value. Works for 5 | # cross-compilation, too. 6 | # 7 | # Implementation note: We are lazy and use an internal autoconf macro, but it 8 | # is supported in autoconf versions 2.50 up to the actual 2.57, so there is 9 | # little risk. 10 | AC_DEFUN([FP_COMPUTE_INT], 11 | [AC_COMPUTE_INT([$2],[$1],[$3],[$4])[]dnl 12 | ])# FP_COMPUTE_INT 13 | 14 | 15 | # FP_CHECK_CONST(EXPRESSION, [INCLUDES = DEFAULT-INCLUDES], [VALUE-IF-FAIL = -1]) 16 | # ------------------------------------------------------------------------------- 17 | # Defines CONST_EXPRESSION to the value of the compile-time EXPRESSION, using 18 | # INCLUDES. If the value cannot be determined, use VALUE-IF-FAIL. 19 | AC_DEFUN([FP_CHECK_CONST], 20 | [AS_VAR_PUSHDEF([fp_Cache], [fp_cv_const_$1])[]dnl 21 | AC_CACHE_CHECK([value of $1], fp_Cache, 22 | [FP_COMPUTE_INT([$1], fp_check_const_result, [AC_INCLUDES_DEFAULT([$2])], 23 | [fp_check_const_result=m4_default([$3], ['-1'])]) 24 | AS_VAR_SET(fp_Cache, [$fp_check_const_result])])[]dnl 25 | AC_DEFINE_UNQUOTED(AS_TR_CPP([CONST_$1]), AS_VAR_GET(fp_Cache), [The value of $1.])[]dnl 26 | AS_VAR_POPDEF([fp_Cache])[]dnl 27 | ])# FP_CHECK_CONST 28 | 29 | 30 | # FP_CHECK_CONSTS_TEMPLATE(EXPRESSION...) 31 | # --------------------------------------- 32 | # autoheader helper for FP_CHECK_CONSTS 33 | m4_define([FP_CHECK_CONSTS_TEMPLATE], 34 | [m4_foreach_w([fp_Const],[$1],[AH_TEMPLATE(AS_TR_CPP(CONST_[]fp_Const), 35 | [The value of ]fp_Const[.])])[]dnl 36 | ])# FP_CHECK_CONSTS_TEMPLATE 37 | 38 | 39 | # FP_CHECK_CONSTS(EXPRESSION..., [INCLUDES = DEFAULT-INCLUDES], [VALUE-IF-FAIL = -1]) 40 | # ----------------------------------------------------------------------------------- 41 | # List version of FP_CHECK_CONST 42 | AC_DEFUN([FP_CHECK_CONSTS], 43 | [FP_CHECK_CONSTS_TEMPLATE([$1])dnl 44 | for fp_const_name in $1 45 | do 46 | FP_CHECK_CONST([$fp_const_name], [$2], [$3]) 47 | done 48 | ])# FP_CHECK_CONSTS 49 | -------------------------------------------------------------------------------- /System/Posix/DynamicLinker/ByteString.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : System.Posix.DynamicLinker.ByteString 6 | -- Copyright : (c) Volker Stolz 2003 7 | -- License : BSD-style (see the file libraries/base/LICENSE) 8 | -- 9 | -- Maintainer : vs@foldr.org 10 | -- Stability : provisional 11 | -- Portability : non-portable (requires POSIX) 12 | -- 13 | -- Dynamic linker support through dlopen() 14 | ----------------------------------------------------------------------------- 15 | 16 | module System.Posix.DynamicLinker.ByteString ( 17 | 18 | module System.Posix.DynamicLinker.Prim, 19 | dlopen, 20 | dlsym, 21 | dlerror, 22 | dlclose, 23 | withDL, withDL_, 24 | undl, 25 | ) 26 | 27 | -- Usage: 28 | -- ****** 29 | -- 30 | -- Let's assume you want to open a local shared library \'foo\' (.\/libfoo.so) 31 | -- offering a function 32 | -- @char \* mogrify (char\*,int)@ 33 | -- and invoke @str = mogrify("test",1)@: 34 | -- 35 | -- 36 | -- type Fun = CString -> Int -> IO CString 37 | -- foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun 38 | -- 39 | -- withDL "libfoo.so" [RTLD_NOW] \$ \\ mod -> do 40 | -- funptr <- dlsym mod "mogrify" 41 | -- let fun = fun__ funptr 42 | -- withCString "test" \$ \\ str -> do 43 | -- strptr <- fun str 1 44 | -- strstr <- peekCString strptr 45 | -- ... 46 | -- 47 | 48 | where 49 | 50 | import System.Posix.DynamicLinker.Common 51 | import System.Posix.DynamicLinker.Prim 52 | 53 | #include "HsUnix.h" 54 | 55 | import Control.Exception ( bracket ) 56 | import Foreign 57 | import System.Posix.ByteString.FilePath 58 | 59 | dlopen :: RawFilePath -> [RTLDFlags] -> IO DL 60 | dlopen path flags = withFilePath path $ \p -> DLHandle <$> 61 | throwDLErrorIf "dlopen" (== nullPtr) (c_dlopen p (packRTLDFlags flags)) 62 | 63 | withDL :: RawFilePath -> [RTLDFlags] -> (DL -> IO a) -> IO a 64 | withDL file flags f = bracket (dlopen file flags) (dlclose) f 65 | 66 | withDL_ :: RawFilePath -> [RTLDFlags] -> (DL -> IO a) -> IO () 67 | withDL_ file flags f = withDL file flags f >> return () 68 | -------------------------------------------------------------------------------- /System/Posix/DynamicLinker/Common.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : System.Posix.DynamicLinker.Common 5 | -- Copyright : (c) Volker Stolz 2003 6 | -- License : BSD-style (see the file libraries/base/LICENSE) 7 | -- 8 | -- Maintainer : vs@foldr.org 9 | -- Stability : provisional 10 | -- Portability : non-portable (requires POSIX) 11 | -- 12 | -- Dynamic linker support through dlopen() 13 | ----------------------------------------------------------------------------- 14 | 15 | module System.Posix.DynamicLinker.Common ( 16 | 17 | module System.Posix.DynamicLinker.Prim, 18 | dlsym, 19 | dlerror, 20 | dlclose, 21 | undl, 22 | throwDLErrorIf, 23 | Module(..) 24 | ) 25 | 26 | -- Usage: 27 | -- ****** 28 | -- 29 | -- Let's assume you want to open a local shared library \'foo\' (.\/libfoo.so) 30 | -- offering a function 31 | -- @char \* mogrify (char\*,int)@ 32 | -- and invoke @str = mogrify("test",1)@: 33 | -- 34 | -- 35 | -- type Fun = CString -> Int -> IO CString 36 | -- foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun 37 | -- 38 | -- withDL "libfoo.so" [RTLD_NOW] \$ \\ mod -> do 39 | -- funptr <- dlsym mod "mogrify" 40 | -- let fun = fun__ funptr 41 | -- withCString "test" \$ \\ str -> do 42 | -- strptr <- fun str 1 43 | -- strstr <- peekCString strptr 44 | -- ... 45 | -- 46 | 47 | where 48 | 49 | #include "HsUnix.h" 50 | 51 | import System.Posix.DynamicLinker.Prim 52 | import Foreign 53 | import Foreign.C 54 | 55 | dlclose :: DL -> IO () 56 | dlclose (DLHandle h) = throwDLErrorIf_ "dlclose" (/= 0) $ c_dlclose h 57 | dlclose h = error $ "dlclose: invalid argument" ++ (show h) 58 | 59 | dlerror :: IO String 60 | dlerror = c_dlerror >>= peekCString 61 | 62 | -- |'dlsym' returns the address binding of the symbol described in @symbol@, 63 | -- as it occurs in the shared object identified by @source@. 64 | 65 | dlsym :: DL -> String -> IO (FunPtr a) 66 | dlsym source symbol = do 67 | withCAString symbol $ \ s -> do 68 | throwDLErrorIf "dlsym" (== nullFunPtr) $ c_dlsym (packDL source) s 69 | 70 | -- |'undl' obtains the raw handle. You mustn't do something like 71 | -- @withDL mod flags $ liftM undl >>= \ p -> use p@ 72 | 73 | undl :: DL -> Ptr () 74 | undl = packDL 75 | 76 | throwDLErrorIf :: String -> (a -> Bool) -> IO a -> IO a 77 | throwDLErrorIf s p f = do 78 | r <- f 79 | if (p r) 80 | then dlerror >>= \ err -> ioError (userError ( s ++ ": " ++ err)) 81 | else return r 82 | 83 | throwDLErrorIf_ :: String -> (a -> Bool) -> IO a -> IO () 84 | throwDLErrorIf_ s p f = throwDLErrorIf s p f >> return () 85 | 86 | -- abstract handle for dynamically loaded module (EXPORTED) 87 | -- 88 | newtype Module = Module (Ptr ()) 89 | -------------------------------------------------------------------------------- /tests/T13660.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE PackageImports #-} 4 | 5 | module Main where 6 | 7 | import Data.Maybe 8 | #if !MIN_VERSION_base(4, 11, 0) 9 | import Data.Monoid ((<>)) 10 | #endif 11 | import GHC.IO.Exception 12 | import System.IO.Error 13 | import System.OsPath.Posix 14 | import System.OsString.Internal.Types (PosixString(..)) 15 | import System.Posix.IO (defaultFileFlags, OpenFileFlags(..), OpenMode(..)) 16 | import System.Posix.ByteString.FilePath 17 | 18 | import qualified Data.ByteString.Char8 as C 19 | #if MIN_VERSION_filepath(1, 5, 0) 20 | import qualified "os-string" System.OsString.Data.ByteString.Short as SBS 21 | #else 22 | import qualified "filepath" System.OsPath.Data.ByteString.Short as SBS 23 | #endif 24 | import qualified System.Posix.Env.PosixString as PS 25 | import qualified System.Posix.IO.PosixString as PS 26 | import qualified System.Posix.IO.ByteString as BS 27 | import qualified System.Posix.Env.ByteString as BS 28 | 29 | 30 | main :: IO () 31 | main = do 32 | tmp <- getTemporaryDirectory 33 | let fp = tmp <> fromStr' "/hello\0world" 34 | res <- tryIOError $ PS.openFd fp WriteOnly df 35 | 36 | tmp' <- getTemporaryDirectory' 37 | let fp' = tmp' <> "/hello\0world" 38 | res' <- tryIOError $ BS.openFd fp' WriteOnly df 39 | 40 | case (res, res') of 41 | (Left e, Left e') 42 | | e == fileError (_toStr fp) 43 | , e' == fileError (C.unpack fp') -> pure () 44 | | otherwise -> fail $ "Unexpected errors: " <> show e <> "\n\t" <> show e' 45 | (Right _, Left _) -> fail "System.Posix.IO.PosixString.openFd should not accept filepaths with NUL bytes" 46 | (Left _, Right _) -> fail "System.Posix.IO.ByteString.openFd should not accept filepaths with NUL bytes" 47 | (Right _, Right _) -> fail $ "System.Posix.IO.PosixString.openFd and System.Posix.IO.ByteString.openFd" <> 48 | " should not accept filepaths with NUL bytes" 49 | 50 | where 51 | df :: OpenFileFlags 52 | df = defaultFileFlags{ trunc = True, creat = Just 0o666, noctty = True, nonBlock = True } 53 | 54 | getTemporaryDirectory :: IO PosixPath 55 | getTemporaryDirectory = fromMaybe (fromStr' "/tmp") <$> PS.getEnv (fromStr' "TMPDIR") 56 | 57 | getTemporaryDirectory' :: IO RawFilePath 58 | getTemporaryDirectory' = fromMaybe "/tmp" <$> BS.getEnv "TMPDIR" 59 | 60 | fromStr' = pack . fmap unsafeFromChar 61 | 62 | _toStr (PosixString sbs) = C.unpack $ SBS.fromShort sbs 63 | 64 | fileError fp = IOError 65 | { ioe_handle = Nothing 66 | , ioe_type = InvalidArgument 67 | , ioe_location = "checkForInteriorNuls" 68 | , ioe_description = "POSIX filepaths must not contain internal NUL octets." 69 | , ioe_errno = Nothing 70 | , ioe_filename = Just fp 71 | } 72 | 73 | -------------------------------------------------------------------------------- /System/Posix/DynamicLinker/Module/ByteString.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : System.Posix.DynamicLinker.Module.ByteString 6 | -- Copyright : (c) Volker Stolz 2003 7 | -- License : BSD-style (see the file libraries/base/LICENSE) 8 | -- 9 | -- Maintainer : vs@foldr.org 10 | -- Stability : provisional 11 | -- Portability : non-portable (requires POSIX) 12 | -- 13 | -- DLOpen support, old API 14 | -- Derived from GModule.chs by M.Weber & M.Chakravarty which is part of c2hs 15 | -- I left the API more or less the same, mostly the flags are different. 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | module System.Posix.DynamicLinker.Module.ByteString ( 20 | 21 | -- Usage: 22 | -- ****** 23 | -- 24 | -- Let's assume you want to open a local shared library 'foo' (./libfoo.so) 25 | -- offering a function 26 | -- char * mogrify (char*,int) 27 | -- and invoke str = mogrify("test",1): 28 | -- 29 | -- type Fun = CString -> Int -> IO CString 30 | -- foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun 31 | -- 32 | -- withModule (Just ".") ("libfoo.so") [RTLD_NOW] $ \ mod -> do 33 | -- funptr <- moduleSymbol mod "mogrify" 34 | -- let fun = fun__ funptr 35 | -- withCString "test" $ \ str -> do 36 | -- strptr <- fun str 1 37 | -- strstr <- peekCString strptr 38 | -- ... 39 | 40 | Module 41 | , moduleOpen -- :: String -> ModuleFlags -> IO Module 42 | , moduleSymbol -- :: Source -> String -> IO (FunPtr a) 43 | , moduleClose -- :: Module -> IO Bool 44 | , moduleError -- :: IO String 45 | , withModule -- :: Maybe String 46 | -- -> String 47 | -- -> [ModuleFlags ] 48 | -- -> (Module -> IO a) 49 | -- -> IO a 50 | , withModule_ -- :: Maybe String 51 | -- -> String 52 | -- -> [ModuleFlags] 53 | -- -> (Module -> IO a) 54 | -- -> IO () 55 | ) 56 | where 57 | 58 | #include "HsUnix.h" 59 | 60 | import System.Posix.DynamicLinker.Module hiding (moduleOpen) 61 | import System.Posix.DynamicLinker.Prim 62 | import System.Posix.DynamicLinker.Common 63 | 64 | import Foreign 65 | import System.Posix.ByteString.FilePath 66 | 67 | -- Opens a module (EXPORTED) 68 | -- 69 | 70 | moduleOpen :: RawFilePath -> [RTLDFlags] -> IO Module 71 | moduleOpen file flags = do 72 | modPtr <- withFilePath file $ \ modAddr -> c_dlopen modAddr (packRTLDFlags flags) 73 | if (modPtr == nullPtr) 74 | then moduleError >>= \ err -> ioError (userError ("dlopen: " ++ err)) 75 | else return $ Module modPtr 76 | -------------------------------------------------------------------------------- /System/Posix/ByteString.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Safe #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : System.Posix.ByteString 6 | -- Copyright : (c) The University of Glasgow 2002 7 | -- License : BSD-style (see the file libraries/base/LICENSE) 8 | -- 9 | -- Maintainer : libraries@haskell.org 10 | -- Stability : provisional 11 | -- Portability : non-portable (requires POSIX) 12 | -- 13 | -- 14 | -- support with 'ByteString' file paths and environment strings. 15 | -- 16 | -- This module exports exactly the same API as "System.Posix", except 17 | -- that all file paths and environment strings are represented by 18 | -- 'ByteString' instead of 'String'. The "System.Posix" API 19 | -- implicitly translates all file paths and environment strings using 20 | -- the locale encoding, whereas this version of the API does no 21 | -- encoding or decoding and works directly in terms of raw bytes. 22 | -- 23 | -- Note that if you do need to interpret file paths or environment 24 | -- strings as text, then some Unicode encoding or decoding should be 25 | -- applied first. 26 | -- 27 | ----------------------------------------------------------------------------- 28 | 29 | module System.Posix.ByteString ( 30 | System.Posix.ByteString.FilePath.RawFilePath, 31 | module System.Posix.Types, 32 | module System.Posix.Signals, 33 | module System.Posix.Directory.ByteString, 34 | module System.Posix.Files.ByteString, 35 | module System.Posix.Unistd, 36 | module System.Posix.IO.ByteString, 37 | module System.Posix.Env.ByteString, 38 | module System.Posix.Process.ByteString, 39 | module System.Posix.Temp.ByteString, 40 | module System.Posix.Terminal.ByteString, 41 | module System.Posix.Time, 42 | module System.Posix.User, 43 | module System.Posix.Resource, 44 | module System.Posix.Semaphore, 45 | module System.Posix.SharedMem, 46 | module System.Posix.DynamicLinker.ByteString, 47 | -- XXX 'Module' type clashes with GHC 48 | -- module System.Posix.DynamicLinker.Module.ByteString 49 | ) where 50 | 51 | import System.Posix.ByteString.FilePath 52 | import System.Posix.Types 53 | import System.Posix.Signals 54 | import System.Posix.Directory.ByteString 55 | import System.Posix.Files.ByteString 56 | import System.Posix.Unistd 57 | import System.Posix.Process.ByteString 58 | import System.Posix.IO.ByteString 59 | import System.Posix.Env.ByteString 60 | import System.Posix.Temp.ByteString 61 | import System.Posix.Terminal.ByteString 62 | import System.Posix.Time 63 | import System.Posix.User 64 | import System.Posix.Resource 65 | import System.Posix.Semaphore 66 | import System.Posix.SharedMem 67 | -- XXX: bad planning, we have two constructors called "Default" 68 | import System.Posix.DynamicLinker.ByteString hiding (Default) 69 | --import System.Posix.DynamicLinker.Module.ByteString 70 | -------------------------------------------------------------------------------- /System/Posix/PosixString.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : System.Posix.PosixString 5 | -- Copyright : (c) The University of Glasgow 2002 6 | -- License : BSD-style (see the file libraries/base/LICENSE) 7 | -- 8 | -- Maintainer : libraries@haskell.org 9 | -- Stability : provisional 10 | -- Portability : non-portable (requires POSIX) 11 | -- 12 | -- 13 | -- support with 'ByteString' file paths and environment strings. 14 | -- 15 | -- This module exports exactly the same API as "System.Posix", except 16 | -- that all file paths and environment strings are represented by 17 | -- 'ByteString' instead of 'String'. The "System.Posix" API 18 | -- implicitly translates all file paths and environment strings using 19 | -- the locale encoding, whereas this version of the API does no 20 | -- encoding or decoding and works directly in terms of raw bytes. 21 | -- 22 | -- Note that if you do need to interpret file paths or environment 23 | -- strings as text, then some Unicode encoding or decoding should be 24 | -- applied first. 25 | -- 26 | ----------------------------------------------------------------------------- 27 | 28 | module System.Posix.PosixString ( 29 | System.OsString.Posix.PosixString, 30 | System.OsPath.Posix.PosixPath, 31 | module System.Posix.Types, 32 | module System.Posix.Signals, 33 | module System.Posix.Directory.PosixPath, 34 | module System.Posix.Files.PosixString, 35 | module System.Posix.Unistd, 36 | module System.Posix.IO.PosixString, 37 | module System.Posix.Env.PosixString, 38 | module System.Posix.Process.PosixString, 39 | module System.Posix.Temp.PosixString, 40 | -- module System.Posix.Terminal.ByteString, 41 | module System.Posix.Time, 42 | module System.Posix.User, 43 | module System.Posix.Resource, 44 | module System.Posix.Semaphore, 45 | module System.Posix.SharedMem, 46 | -- module System.Posix.DynamicLinker.ByteString, 47 | -- XXX 'Module' type clashes with GHC 48 | -- module System.Posix.DynamicLinker.Module.ByteString 49 | ) where 50 | 51 | import System.OsPath.Posix 52 | import System.OsString.Posix 53 | import System.Posix.Types 54 | import System.Posix.Signals 55 | import System.Posix.Directory.PosixPath 56 | import System.Posix.Files.PosixString 57 | import System.Posix.Unistd 58 | import System.Posix.Process.PosixString 59 | import System.Posix.IO.PosixString 60 | import System.Posix.Env.PosixString 61 | import System.Posix.Temp.PosixString 62 | -- import System.Posix.Terminal.ByteString 63 | import System.Posix.Time 64 | import System.Posix.User 65 | import System.Posix.Resource 66 | import System.Posix.Semaphore 67 | import System.Posix.SharedMem 68 | -- XXX: bad planning, we have two constructors called "Default" 69 | -- import System.Posix.DynamicLinker.ByteString hiding (Default) 70 | --import System.Posix.DynamicLinker.Module.ByteString 71 | -------------------------------------------------------------------------------- /include/HsUnix.h: -------------------------------------------------------------------------------- 1 | /* ----------------------------------------------------------------------------- 2 | * 3 | * (c) The University of Glasgow 2002 4 | * 5 | * Definitions for package `unix' which are visible in Haskell land. 6 | * 7 | * ---------------------------------------------------------------------------*/ 8 | 9 | #ifndef HSUNIX_H 10 | #define HSUNIX_H 11 | 12 | #include "HsUnixConfig.h" 13 | #include "HsFFI.h" 14 | 15 | /* ultra-evil... */ 16 | #undef PACKAGE_BUGREPORT 17 | #undef PACKAGE_NAME 18 | #undef PACKAGE_STRING 19 | #undef PACKAGE_TARNAME 20 | #undef PACKAGE_VERSION 21 | 22 | #include 23 | #include 24 | 25 | #ifdef HAVE_STRING_H 26 | #include 27 | #endif 28 | #ifdef HAVE_SYS_TIMES_H 29 | #include 30 | #endif 31 | #ifdef HAVE_SYS_TIME_H 32 | #include 33 | #endif 34 | #ifdef HAVE_SYS_RESOURCE_H 35 | #include 36 | #endif 37 | #ifdef HAVE_SYS_WAIT_H 38 | #include 39 | #endif 40 | #ifdef HAVE_SYS_STAT_H 41 | #include 42 | #endif 43 | #ifdef HAVE_TIME_H 44 | #include 45 | #endif 46 | #ifdef HAVE_UNISTD_H 47 | #include 48 | #endif 49 | #ifdef HAVE_UTIME_H 50 | #include 51 | #endif 52 | #ifdef HAVE_FCNTL_H 53 | #include 54 | #endif 55 | #ifdef HAVE_LIMITS_H 56 | #include 57 | #endif 58 | #ifdef HAVE_TERMIOS_H 59 | #include 60 | #endif 61 | #ifdef HAVE_SYS_UTSNAME_H 62 | #include 63 | #endif 64 | #ifdef HAVE_PWD_H 65 | #include 66 | #endif 67 | #ifdef HAVE_GRP_H 68 | #include 69 | #endif 70 | #ifdef HAVE_DIRENT_H 71 | #include 72 | #endif 73 | 74 | #if defined(HAVE_BSD_LIBUTIL_H) 75 | #include 76 | #elif defined(HAVE_LIBUTIL_H) 77 | #include 78 | #endif 79 | #ifdef HAVE_PTY_H 80 | #include 81 | #endif 82 | #ifdef HAVE_UTMP_H 83 | #include 84 | #endif 85 | 86 | #if defined(HAVE_DLFCN_H) 87 | #include 88 | #endif 89 | 90 | #ifdef HAVE_SIGNAL_H 91 | #include 92 | #endif 93 | #ifdef HAVE_SYS_SYSMACROS_H 94 | #include 95 | #endif 96 | 97 | /* defined in rts/posix/Signals.c */ 98 | extern HsInt nocldstop; 99 | 100 | /* defined in libc */ 101 | extern char **environ; 102 | 103 | #ifdef HAVE_RTLDNEXT 104 | void *__hsunix_rtldNext (void); 105 | #endif 106 | 107 | #ifdef HAVE_RTLDDEFAULT 108 | void *__hsunix_rtldDefault (void); 109 | #endif 110 | 111 | /* O_SYNC doesn't exist on Mac OS X and (at least some versions of) FreeBSD, 112 | fall back to O_FSYNC, which should be the same */ 113 | #ifndef O_SYNC 114 | # define O_SYNC O_FSYNC 115 | #endif 116 | 117 | // not part of POSIX, hence may not be always defined 118 | #ifndef WCOREDUMP 119 | # define WCOREDUMP(s) 0 120 | #endif 121 | 122 | // push a SVR4 STREAMS module; do nothing if STREAMS not available 123 | int __hsunix_push_module(int fd, const char *module); 124 | 125 | #ifdef HAVE_CLOCKS_PER_SEC 126 | clock_t __hsunix_clocks_per_second (void); 127 | #endif 128 | 129 | #if defined(HAVE_SYS_STAT_H) && defined(HAVE_STATX_FUN) && defined(HAVE_STRUCT_STATX) 130 | #define HAVE_STATX 1 131 | #endif 132 | 133 | #endif 134 | -------------------------------------------------------------------------------- /System/Posix/User/Common.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : System.Posix.User.Common 5 | -- Copyright : (c) The University of Glasgow 2002 6 | -- License : BSD-style (see the file libraries/base/LICENSE) 7 | -- 8 | -- Maintainer : libraries@haskell.org 9 | -- Stability : provisional 10 | -- Portability : non-portable (requires POSIX) 11 | -- 12 | -- POSIX user\/group support 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module System.Posix.User.Common where 17 | 18 | import Data.ByteString ( ByteString ) 19 | import System.Posix.Types 20 | 21 | #include "HsUnix.h" 22 | 23 | 24 | #if defined(HAVE_PWD_H) 25 | import Foreign.Ptr 26 | import Foreign.Marshal 27 | import Foreign.Storable 28 | import Data.ByteString ( packCString ) 29 | 30 | -- internal types 31 | data {-# CTYPE "struct passwd" #-} CPasswd 32 | data {-# CTYPE "struct group" #-} CGroup 33 | 34 | data LKUPTYPE = GETONE | GETALL 35 | 36 | unpackGroupEntry :: Ptr CGroup -> IO GroupEntry 37 | unpackGroupEntry ptr = do 38 | name <- (#peek struct group, gr_name) ptr >>= packCString 39 | passwd <- (#peek struct group, gr_passwd) ptr >>= packCString 40 | gid <- (#peek struct group, gr_gid) ptr 41 | mem <- (#peek struct group, gr_mem) ptr 42 | members <- peekArray0 nullPtr mem >>= mapM packCString 43 | return (GroupEntry name passwd gid members) 44 | 45 | unpackUserEntry :: Ptr CPasswd -> IO UserEntry 46 | unpackUserEntry ptr = do 47 | name <- (#peek struct passwd, pw_name) ptr >>= packCString 48 | passwd <- (#peek struct passwd, pw_passwd) ptr >>= packCString 49 | uid <- (#peek struct passwd, pw_uid) ptr 50 | gid <- (#peek struct passwd, pw_gid) ptr 51 | #ifdef HAVE_NO_PASSWD_PW_GECOS 52 | gecos <- return "" -- pw_gecos does not exist on android 53 | #else 54 | gecos <- (#peek struct passwd, pw_gecos) ptr >>= packCString 55 | #endif 56 | dir <- (#peek struct passwd, pw_dir) ptr >>= packCString 57 | shell <- (#peek struct passwd, pw_shell) ptr >>= packCString 58 | return (UserEntry name passwd uid gid gecos dir shell) 59 | 60 | #endif // HAVE_PWD_H 61 | 62 | data UserEntry = 63 | UserEntry { 64 | userName :: ByteString, -- ^ Textual name of this user (pw_name) 65 | userPassword :: ByteString, -- ^ Password -- may be empty or fake if shadow is in use (pw_passwd) 66 | userID :: UserID, -- ^ Numeric ID for this user (pw_uid) 67 | userGroupID :: GroupID, -- ^ Primary group ID (pw_gid) 68 | userGecos :: ByteString, -- ^ Usually the real name for the user (pw_gecos) 69 | homeDirectory :: ByteString, -- ^ Home directory (pw_dir) 70 | userShell :: ByteString -- ^ Default shell (pw_shell) 71 | } deriving (Show, Read, Eq) 72 | 73 | data GroupEntry = 74 | GroupEntry { 75 | groupName :: ByteString, -- ^ The name of this group (gr_name) 76 | groupPassword :: ByteString, -- ^ The password for this group (gr_passwd) 77 | groupID :: GroupID, -- ^ The unique numeric ID for this group (gr_gid) 78 | groupMembers :: [ByteString] -- ^ A list of zero or more usernames that are members (gr_mem) 79 | } deriving (Show, Read, Eq) 80 | -------------------------------------------------------------------------------- /cbits/HsUnix.c: -------------------------------------------------------------------------------- 1 | /* ----------------------------------------------------------------------------- 2 | * 3 | * (c) The University of Glasgow 2002 4 | * 5 | * Definitions for package `unix' which are visible in Haskell land. 6 | * 7 | * ---------------------------------------------------------------------------*/ 8 | 9 | #include "HsUnix.h" 10 | 11 | char **__hsunix_get_environ (void) {return environ;} 12 | 13 | #ifdef HAVE_RTLDNEXT 14 | void *__hsunix_rtldNext (void) {return RTLD_NEXT;} 15 | #endif 16 | 17 | #ifdef HAVE_RTLDDEFAULT 18 | void *__hsunix_rtldDefault (void) {return RTLD_DEFAULT;} 19 | #endif 20 | 21 | // push a SVR4 STREAMS module; do nothing if STREAMS not available 22 | int __hsunix_push_module(int fd, const char *module) 23 | { 24 | #if defined(I_PUSH) && !defined(HAVE_DEV_PTC) 25 | return ioctl(fd, I_PUSH, module); 26 | #else 27 | return 0; 28 | #endif 29 | } 30 | 31 | #ifdef HAVE_CLOCKS_PER_SEC 32 | clock_t __hsunix_clocks_per_second (void) {return CLOCKS_PER_SEC;} 33 | #endif 34 | 35 | /* 36 | * GNU glibc 2.23 and later deprecate `readdir_r` in favour of plain old 37 | * `readdir` which in some upcoming POSIX standard is going to required to be 38 | * re-entrant. 39 | * Eventually we want to drop `readdir_r` all together, but want to be 40 | * compatible with older unixen which may not have a re-entrant `readdir`. 41 | * Solution is to make systems with *known* re-entrant `readdir` use that and use 42 | * `readdir_r` wherever we have it and don't *know* that `readdir` is 43 | * re-entrant. 44 | */ 45 | 46 | #if defined (__GLIBC__) && ((__GLIBC__ > 2) || (__GLIBC__ == 2) && (__GLIBC_MINOR__ >= 23)) 47 | #define USE_READDIR_R 0 48 | #else 49 | #define USE_READDIR_R 1 50 | #endif 51 | 52 | /* 53 | * read an entry from the directory stream; opt for the 54 | * re-entrant friendly way of doing this, if available. 55 | */ 56 | int __hscore_readdir( DIR *dirPtr, struct dirent **pDirEnt ) 57 | { 58 | #if HAVE_READDIR_R && USE_READDIR_R 59 | struct dirent* p; 60 | int res; 61 | static unsigned int nm_max = (unsigned int)-1; 62 | 63 | if (pDirEnt == NULL) { 64 | return -1; 65 | } 66 | if (nm_max == (unsigned int)-1) { 67 | #ifdef NAME_MAX 68 | nm_max = NAME_MAX + 1; 69 | #else 70 | nm_max = pathconf(".", _PC_NAME_MAX); 71 | if (nm_max == -1) { nm_max = 255; } 72 | nm_max++; 73 | #endif 74 | } 75 | p = (struct dirent*)malloc(sizeof(struct dirent) + nm_max); 76 | if (p == NULL) return -1; 77 | res = readdir_r(dirPtr, p, pDirEnt); 78 | if (res != 0) { 79 | *pDirEnt = NULL; 80 | free(p); 81 | } 82 | else if (*pDirEnt == NULL) { 83 | // end of stream 84 | free(p); 85 | } 86 | return res; 87 | #else 88 | 89 | if (pDirEnt == NULL) { 90 | return -1; 91 | } 92 | 93 | *pDirEnt = readdir(dirPtr); 94 | if (*pDirEnt == NULL) { 95 | return -1; 96 | } else { 97 | return 0; 98 | } 99 | #endif 100 | } 101 | 102 | char *__hscore_d_name( struct dirent* d ) 103 | { 104 | return (d->d_name); 105 | } 106 | 107 | char __hscore_d_type( struct dirent* d ) 108 | { 109 | #ifdef HAVE_STRUCT_DIRENT_D_TYPE 110 | return (d->d_type); 111 | #else 112 | return CONST_DT_UNKNOWN; 113 | #endif 114 | } 115 | 116 | void __hscore_free_dirent(struct dirent *dEnt) 117 | { 118 | #if HAVE_READDIR_R && USE_READDIR_R 119 | free(dEnt); 120 | #endif 121 | } 122 | -------------------------------------------------------------------------------- /System/Posix/Process/Internals.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | 4 | #include "HsUnix.h" 5 | 6 | module System.Posix.Process.Internals ( 7 | pPrPr_disableITimers, c_execvpe, 8 | decipherWaitStatus, ProcessStatus(..) ) where 9 | 10 | import Foreign 11 | import Foreign.C 12 | import System.Exit 13 | import System.IO.Error 14 | import GHC.Conc (Signal) 15 | 16 | #if !defined(HAVE_GETPID) 17 | import System.IO.Error ( ioeSetLocation ) 18 | import GHC.IO.Exception ( unsupportedOperation ) 19 | #endif 20 | 21 | -- | The exit status of a process 22 | data ProcessStatus 23 | = Exited ExitCode -- ^ the process exited by calling 24 | -- @exit()@ or returning from @main@ 25 | | Terminated Signal Bool -- ^ the process was terminated by a 26 | -- signal, the @Bool@ is @True@ if a core 27 | -- dump was produced 28 | -- 29 | -- @since 2.7.0.0 30 | | Stopped Signal -- ^ the process was stopped by a signal 31 | deriving (Eq, Ord, Show) 32 | 33 | -- this function disables the itimer, which would otherwise cause confusing 34 | -- signals to be sent to the new process. 35 | foreign import capi unsafe "Rts.h stopTimer" 36 | pPrPr_disableITimers :: IO () 37 | 38 | foreign import ccall unsafe "__hsunix_execvpe" 39 | c_execvpe :: CString -> Ptr CString -> Ptr CString -> IO CInt 40 | 41 | #if !defined(HAVE_GETPID) 42 | 43 | {-# WARNING decipherWaitStatus "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_GETPID@)" #-} 44 | decipherWaitStatus :: CInt -> IO ProcessStatus 45 | decipherWaitStatus _ = ioError (ioeSetLocation unsupportedOperation "decipherWaitStatus") 46 | 47 | #else 48 | 49 | decipherWaitStatus :: CInt -> IO ProcessStatus 50 | decipherWaitStatus wstat = 51 | if c_WIFEXITED wstat /= 0 52 | then do 53 | let exitstatus = c_WEXITSTATUS wstat 54 | if exitstatus == 0 55 | then return (Exited ExitSuccess) 56 | else return (Exited (ExitFailure (fromIntegral exitstatus))) 57 | else do 58 | if c_WIFSIGNALED wstat /= 0 59 | then do 60 | let termsig = c_WTERMSIG wstat 61 | let coredumped = c_WCOREDUMP wstat /= 0 62 | return (Terminated termsig coredumped) 63 | else do 64 | if c_WIFSTOPPED wstat /= 0 65 | then do 66 | let stopsig = c_WSTOPSIG wstat 67 | return (Stopped stopsig) 68 | else do 69 | ioError (mkIOError illegalOperationErrorType 70 | "waitStatus" Nothing Nothing) 71 | 72 | 73 | foreign import capi unsafe "HsUnix.h WIFEXITED" 74 | c_WIFEXITED :: CInt -> CInt 75 | 76 | foreign import capi unsafe "HsUnix.h WEXITSTATUS" 77 | c_WEXITSTATUS :: CInt -> CInt 78 | 79 | foreign import capi unsafe "HsUnix.h WIFSIGNALED" 80 | c_WIFSIGNALED :: CInt -> CInt 81 | 82 | foreign import capi unsafe "HsUnix.h WTERMSIG" 83 | c_WTERMSIG :: CInt -> CInt 84 | 85 | foreign import capi unsafe "HsUnix.h WIFSTOPPED" 86 | c_WIFSTOPPED :: CInt -> CInt 87 | 88 | foreign import capi unsafe "HsUnix.h WSTOPSIG" 89 | c_WSTOPSIG :: CInt -> CInt 90 | 91 | foreign import capi unsafe "HsUnix.h WCOREDUMP" 92 | c_WCOREDUMP :: CInt -> CInt 93 | 94 | #endif // HAVE_GETPID 95 | -------------------------------------------------------------------------------- /System/Posix/SharedMem.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : System.Posix.SharedMem 5 | -- Copyright : (c) Daniel Franke 2007 6 | -- License : BSD-style (see the file libraries/base/LICENSE) 7 | -- 8 | -- Maintainer : libraries@haskell.org 9 | -- Stability : experimental 10 | -- Portability : non-portable (requires POSIX) 11 | -- 12 | -- POSIX shared memory support. 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module System.Posix.SharedMem 17 | (ShmOpenFlags(..), shmOpen, shmUnlink) 18 | where 19 | 20 | #include "HsUnix.h" 21 | 22 | #include 23 | #if defined(HAVE_SHM_OPEN) || defined(HAVE_SHM_UNLINK) 24 | #include 25 | #endif 26 | #include 27 | 28 | import System.Posix.Types 29 | import qualified System.Posix.Internals as Base 30 | #if defined(HAVE_SHM_OPEN) || defined(HAVE_SHM_UNLINK) 31 | import Foreign.C 32 | #endif 33 | #ifdef HAVE_SHM_OPEN 34 | import Data.Bits 35 | #endif 36 | 37 | data ShmOpenFlags = ShmOpenFlags 38 | { shmReadWrite :: Bool, 39 | -- ^ If true, open the shm object read-write rather than read-only. 40 | shmCreate :: Bool, 41 | -- ^ If true, create the shm object if it does not exist. 42 | shmExclusive :: Bool, 43 | -- ^ If true, throw an exception if the shm object already exists. 44 | shmTrunc :: Bool 45 | -- ^ If true, wipe the contents of the shm object after opening it. 46 | } 47 | 48 | -- | Open a shared memory object with the given name, flags, and mode. 49 | shmOpen :: String -> ShmOpenFlags -> FileMode -> IO Fd 50 | #ifdef HAVE_SHM_OPEN 51 | shmOpen name flags mode = 52 | do cflags0 <- return 0 53 | cflags1 <- return $ cflags0 .|. (if shmReadWrite flags 54 | then Base.o_RDWR 55 | else Base.o_RDONLY) 56 | cflags2 <- return $ cflags1 .|. (if shmCreate flags then Base.o_CREAT 57 | else 0) 58 | cflags3 <- return $ cflags2 .|. (if shmExclusive flags 59 | then Base.o_EXCL 60 | else 0) 61 | cflags4 <- return $ cflags3 .|. (if shmTrunc flags then Base.o_TRUNC 62 | else 0) 63 | withCAString name (shmOpen' cflags4) 64 | where shmOpen' cflags cname = 65 | do fd <- throwErrnoIfMinus1 "shmOpen" $ 66 | shm_open cname cflags mode 67 | return $ Fd fd 68 | #else 69 | {-# WARNING shmOpen "System.Posix.SharedMem: shm_open: not available" #-} 70 | shmOpen = error "System.Posix.SharedMem:shm_open: not available" 71 | #endif 72 | 73 | -- | Delete the shared memory object with the given name. 74 | shmUnlink :: String -> IO () 75 | #ifdef HAVE_SHM_UNLINK 76 | shmUnlink name = withCAString name shmUnlink' 77 | where shmUnlink' cname = 78 | throwErrnoIfMinus1_ "shmUnlink" $ shm_unlink cname 79 | #else 80 | {-# WARNING shmUnlink "System.Posix.SharedMem:shm_unlink: not available" #-} 81 | shmUnlink = error "System.Posix.SharedMem:shm_unlink: not available" 82 | #endif 83 | 84 | #ifdef HAVE_SHM_OPEN 85 | foreign import ccall unsafe "shm_open" 86 | shm_open :: CString -> CInt -> CMode -> IO CInt 87 | #endif 88 | 89 | #ifdef HAVE_SHM_UNLINK 90 | foreign import ccall unsafe "shm_unlink" 91 | shm_unlink :: CString -> IO CInt 92 | #endif 93 | -------------------------------------------------------------------------------- /System/Posix/IO/PosixString.hsc: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : System.Posix.IO.PosixString 4 | -- Copyright : (c) The University of Glasgow 2002 5 | -- License : BSD-style (see the file libraries/base/LICENSE) 6 | -- 7 | -- Maintainer : libraries@haskell.org 8 | -- Stability : provisional 9 | -- Portability : non-portable (requires POSIX) 10 | -- 11 | -- POSIX IO support. These types and functions correspond to the unix 12 | -- functions open(2), close(2), etc. For more portable functions 13 | -- which are more like fopen(3) and friends from stdio.h, see 14 | -- "System.IO". 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | #include "HsUnix.h" 19 | 20 | module System.Posix.IO.PosixString ( 21 | -- * Input \/ Output 22 | 23 | -- ** Standard file descriptors 24 | stdInput, stdOutput, stdError, 25 | 26 | -- ** Opening and closing files 27 | OpenMode(..), 28 | OpenFileFlags(..), defaultFileFlags, 29 | openFd, openFdAt, createFile, createFileAt, 30 | closeFd, 31 | 32 | -- ** Reading\/writing data 33 | -- |Programmers using the 'fdRead' and 'fdWrite' API should be aware that 34 | -- EAGAIN exceptions may occur for non-blocking IO! 35 | 36 | fdRead, fdWrite, 37 | fdReadBuf, fdWriteBuf, 38 | 39 | -- ** Seeking 40 | fdSeek, 41 | 42 | -- ** File options 43 | FdOption(..), 44 | queryFdOption, 45 | setFdOption, 46 | 47 | -- ** Locking 48 | FileLock, 49 | LockRequest(..), 50 | getLock, setLock, 51 | waitToSetLock, 52 | 53 | -- ** Pipes 54 | createPipe, 55 | 56 | -- ** Duplicating file descriptors 57 | dup, dupTo, 58 | 59 | -- ** Converting file descriptors to\/from Handles 60 | handleToFd, 61 | fdToHandle, 62 | 63 | ) where 64 | 65 | import System.Posix.Types 66 | import System.Posix.IO.Common 67 | import System.Posix.IO.ByteString ( fdRead, fdWrite ) 68 | import System.OsPath.Types 69 | 70 | import System.Posix.PosixPath.FilePath 71 | 72 | 73 | 74 | -- |Open and optionally create this file. See 'System.Posix.Files' 75 | -- for information on how to use the 'FileMode' type. 76 | openFd :: PosixPath 77 | -> OpenMode 78 | -> OpenFileFlags 79 | -> IO Fd 80 | openFd = openFdAt Nothing 81 | 82 | -- | Open a file relative to an optional directory file descriptor. 83 | -- 84 | -- Directory file descriptors can be used to avoid some race conditions when 85 | -- navigating changing directory trees, or to retain access to a portion of the 86 | -- directory tree that would otherwise become inaccessible after dropping 87 | -- privileges. 88 | openFdAt :: Maybe Fd -- ^ Optional directory file descriptor 89 | -> PosixPath -- ^ Pathname to open 90 | -> OpenMode -- ^ Read-only, read-write or write-only 91 | -> OpenFileFlags -- ^ Append, exclusive, truncate, etc. 92 | -> IO Fd 93 | openFdAt fdMay name how flags = 94 | withFilePath name $ \str -> 95 | throwErrnoPathIfMinus1Retry "openFdAt" name $ 96 | openat_ fdMay str how flags 97 | 98 | -- |Create and open this file in WriteOnly mode. A special case of 99 | -- 'openFd'. See 'System.Posix.Files' for information on how to use 100 | -- the 'FileMode' type. 101 | createFile :: PosixPath -> FileMode -> IO Fd 102 | createFile = createFileAt Nothing 103 | 104 | -- | Create and open a file for write-only, with default flags, 105 | -- relative an optional directory file-descriptor. 106 | -- 107 | -- Directory file descriptors can be used to avoid some race conditions when 108 | -- navigating changing directory trees, or to retain access to a portion of the 109 | -- directory tree that would otherwise become inaccessible after dropping 110 | -- privileges. 111 | createFileAt :: Maybe Fd -- ^ Optional directory file descriptor 112 | -> PosixPath -- ^ Pathname to create 113 | -> FileMode -- ^ File permission bits (before umask) 114 | -> IO Fd 115 | createFileAt fdMay name mode 116 | = openFdAt fdMay name WriteOnly defaultFileFlags{ trunc=True, creat=(Just mode) } 117 | -------------------------------------------------------------------------------- /tests/Signals001.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 4 | 5 | module Signals001 (main) where 6 | 7 | import Control.Monad 8 | import System.Posix.Signals 9 | 10 | #include "ghcconfig.h" 11 | 12 | main :: IO () 13 | main = do 14 | forM_ (filter id $ testMembers emptySignalSet) $ \_ -> 15 | fail "should be False" 16 | forM_ (filter id $ testMembers emptyset) $ \_ -> 17 | fail "should be False" 18 | forM_ (filter not $ testMembers fullSignalSet) $ \_ -> 19 | fail "should be True" 20 | forM_ (filter not $ testMembers fullset) $ \_ -> 21 | fail "should be True" 22 | 23 | fullset = internalAbort `addSignal` 24 | realTimeAlarm `addSignal` 25 | busError `addSignal` 26 | processStatusChanged `addSignal` 27 | continueProcess `addSignal` 28 | floatingPointException `addSignal` 29 | lostConnection `addSignal` 30 | illegalInstruction `addSignal` 31 | keyboardSignal `addSignal` 32 | killProcess `addSignal` 33 | openEndedPipe `addSignal` 34 | keyboardTermination `addSignal` 35 | segmentationViolation `addSignal` 36 | softwareStop `addSignal` 37 | softwareTermination `addSignal` 38 | keyboardStop `addSignal` 39 | backgroundRead `addSignal` 40 | backgroundWrite `addSignal` 41 | userDefinedSignal1 `addSignal` 42 | userDefinedSignal2 `addSignal` 43 | #if HAVE_SIGPOLL 44 | pollableEvent `addSignal` 45 | #endif 46 | profilingTimerExpired `addSignal` 47 | badSystemCall `addSignal` 48 | breakpointTrap `addSignal` 49 | urgentDataAvailable `addSignal` 50 | virtualTimerExpired `addSignal` 51 | cpuTimeLimitExceeded `addSignal` 52 | fileSizeLimitExceeded `addSignal` 53 | emptySignalSet 54 | 55 | emptyset = internalAbort `deleteSignal` 56 | realTimeAlarm `deleteSignal` 57 | busError `deleteSignal` 58 | processStatusChanged `deleteSignal` 59 | continueProcess `deleteSignal` 60 | floatingPointException `deleteSignal` 61 | lostConnection `deleteSignal` 62 | illegalInstruction `deleteSignal` 63 | keyboardSignal `deleteSignal` 64 | killProcess `deleteSignal` 65 | openEndedPipe `deleteSignal` 66 | keyboardTermination `deleteSignal` 67 | segmentationViolation `deleteSignal` 68 | softwareStop `deleteSignal` 69 | softwareTermination `deleteSignal` 70 | keyboardStop `deleteSignal` 71 | backgroundRead `deleteSignal` 72 | backgroundWrite `deleteSignal` 73 | userDefinedSignal1 `deleteSignal` 74 | userDefinedSignal2 `deleteSignal` 75 | #if HAVE_SIGPOLL 76 | pollableEvent `deleteSignal` 77 | #endif 78 | profilingTimerExpired `deleteSignal` 79 | badSystemCall `deleteSignal` 80 | breakpointTrap `deleteSignal` 81 | urgentDataAvailable `deleteSignal` 82 | virtualTimerExpired `deleteSignal` 83 | cpuTimeLimitExceeded `deleteSignal` 84 | fileSizeLimitExceeded `deleteSignal` 85 | fullSignalSet 86 | 87 | testMembers set = [ 88 | internalAbort `inSignalSet` set, 89 | realTimeAlarm `inSignalSet` set, 90 | busError `inSignalSet` set, 91 | processStatusChanged `inSignalSet` set, 92 | continueProcess `inSignalSet` set, 93 | floatingPointException `inSignalSet` set, 94 | lostConnection `inSignalSet` set, 95 | illegalInstruction `inSignalSet` set, 96 | keyboardSignal `inSignalSet` set, 97 | killProcess `inSignalSet` set, 98 | openEndedPipe `inSignalSet` set, 99 | keyboardTermination `inSignalSet` set, 100 | segmentationViolation `inSignalSet` set, 101 | softwareStop `inSignalSet` set, 102 | softwareTermination `inSignalSet` set, 103 | keyboardStop `inSignalSet` set, 104 | backgroundRead `inSignalSet` set, 105 | backgroundWrite `inSignalSet` set, 106 | userDefinedSignal1 `inSignalSet` set, 107 | userDefinedSignal2 `inSignalSet` set, 108 | #if HAVE_SIGPOLL 109 | pollableEvent `inSignalSet` set, 110 | #endif 111 | profilingTimerExpired `inSignalSet` set, 112 | badSystemCall `inSignalSet` set, 113 | breakpointTrap `inSignalSet` set, 114 | urgentDataAvailable `inSignalSet` set, 115 | virtualTimerExpired `inSignalSet` set, 116 | cpuTimeLimitExceeded `inSignalSet` set, 117 | fileSizeLimitExceeded `inSignalSet` set 118 | ] 119 | -------------------------------------------------------------------------------- /tests/FileStatusByteString.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 4 | 5 | module FileStatusByteString (main) where 6 | 7 | -- GHC trac #2969 8 | 9 | import System.Posix.ByteString 10 | import Control.Exception as E 11 | import Control.Monad 12 | import Test.Tasty.HUnit 13 | 14 | main = do 15 | cleanup 16 | fs <- testRegular 17 | ds <- testDir 18 | testSymlink fs ds 19 | testLink 20 | cleanup 21 | 22 | regular = "regular2" 23 | dir = "dir2" 24 | hlink_regular = "hlink-regular2" 25 | slink_regular = "slink-regular2" 26 | link_dir = "link-dir2" 27 | 28 | testRegular = do 29 | _ <- createFile regular ownerReadMode 30 | (fs, _) <- getStatus regular 31 | let expected = (False,False,False,True,False,False,False) 32 | actual = snd (statusElements fs) 33 | when (actual /= expected) $ 34 | fail "unexpected file status bits for regular file" 35 | return fs 36 | 37 | testDir = do 38 | createDirectory dir ownerReadMode 39 | (ds, _) <- getStatus dir 40 | let expected = (False,False,False,False,True,False,False) 41 | actual = snd (statusElements ds) 42 | when (actual /= expected) $ 43 | fail "unexpected file status bits for directory" 44 | return ds 45 | 46 | testSymlink fs ds = do 47 | createSymbolicLink regular slink_regular 48 | createSymbolicLink dir link_dir 49 | (fs', ls) <- getStatus slink_regular 50 | (ds', lds) <- getStatus link_dir 51 | 52 | let expected = (False,False,False,False,False,True,False) 53 | actualF = snd (statusElements ls) 54 | actualD = snd (statusElements lds) 55 | 56 | when (actualF /= expected) $ 57 | fail "unexpected file status bits for symlink to regular file" 58 | 59 | when (actualD /= expected) $ 60 | fail "unexpected file status bits for symlink to directory" 61 | 62 | when (statusElements fs /= statusElements fs') $ 63 | fail "status for a file does not match when it's accessed via a symlink" 64 | 65 | when (statusElements ds /= statusElements ds') $ 66 | fail "status for a directory does not match when it's accessed via a symlink" 67 | 68 | testLink = do 69 | createLink regular hlink_regular 70 | (fs, _) <- getStatus regular -- we need to retrieve it again as creating the link causes it to change! 71 | (fs', ls) <- getStatus hlink_regular 72 | snd (statusElements ls) @?= ( 73 | False, -- isBlockDevice 74 | False, -- isCharacterDevice 75 | False, -- isNamedPipe 76 | True, -- isRegularFile 77 | False, -- isDirectory 78 | False, -- isSymbolicLink 79 | False) -- isSocket 80 | linkCount fs' == 2 @? "Newly created hard link was expected to have a link count of 2" 81 | statusElements fs @?= statusElements fs' -- status for a file should match when accessed via a link 82 | 83 | 84 | cleanup = do 85 | ignoreIOExceptions $ removeDirectory dir 86 | mapM_ (ignoreIOExceptions . removeLink) 87 | [regular, hlink_regular, slink_regular, link_dir] 88 | 89 | ignoreIOExceptions io = io `E.catch` 90 | ((\_ -> return ()) :: IOException -> IO ()) 91 | 92 | getStatus f = do 93 | fs <- getFileStatus f 94 | ls <- getSymbolicLinkStatus f 95 | 96 | fd <- openFd f ReadOnly defaultFileFlags 97 | fs' <- getFdStatus fd 98 | 99 | when (statusElements fs /= statusElements fs') $ 100 | fail "getFileStatus and getFdStatus give inconsistent results" 101 | 102 | when (not (isSymbolicLink ls) && statusElements fs /= statusElements fs') $ 103 | fail $ "getFileStatus and getSymbolicLinkStatus give inconsistent results " 104 | ++ "on a file that is not a symbolic link" 105 | 106 | return (fs, ls) 107 | 108 | -- Yay for 20-element tuples! 109 | statusElements fs = (,) 110 | (deviceID fs 111 | ,fileMode fs 112 | ,linkCount fs 113 | ,fileOwner fs 114 | ,fileGroup fs 115 | ,specialDeviceID fs 116 | ,fileSize fs 117 | ,accessTime fs 118 | ,accessTimeHiRes fs 119 | ,modificationTime fs 120 | ,modificationTimeHiRes fs 121 | ,statusChangeTime fs 122 | ,statusChangeTimeHiRes fs 123 | ) 124 | (isBlockDevice fs 125 | ,isCharacterDevice fs 126 | ,isNamedPipe fs 127 | ,isRegularFile fs 128 | ,isDirectory fs 129 | ,isSymbolicLink fs 130 | ,isSocket fs 131 | ) 132 | -------------------------------------------------------------------------------- /tests/FileStatus.hs: -------------------------------------------------------------------------------- 1 | 2 | -- GHC trac #2969 3 | 4 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 5 | 6 | module FileStatus (main) where 7 | 8 | import System.Posix.Files 9 | import System.Posix.Directory 10 | import System.Posix.IO 11 | import Control.Exception as E 12 | import Control.Monad 13 | import Test.Tasty.HUnit 14 | 15 | main = do 16 | cleanup 17 | fs <- testRegular 18 | ds <- testDir 19 | testSymlink fs ds 20 | testLink 21 | cleanup 22 | 23 | regular = "regular" 24 | dir = "dir" 25 | slink_regular = "link-regular-symlink" 26 | hlink_regular = "link-regular-hardlink" 27 | link_dir = "link-dir" 28 | 29 | testRegular = do 30 | _ <- createFile regular ownerReadMode 31 | (fs, _) <- getStatus regular 32 | let expected = (False,False,False,True,False,False,False) 33 | actual = snd (statusElements fs) 34 | when (actual /= expected) $ 35 | fail "unexpected file status bits for regular file" 36 | return fs 37 | 38 | testDir = do 39 | createDirectory dir ownerReadMode 40 | (ds, _) <- getStatus dir 41 | let expected = (False,False,False,False,True,False,False) 42 | actual = snd (statusElements ds) 43 | when (actual /= expected) $ 44 | fail "unexpected file status bits for directory" 45 | return ds 46 | 47 | testSymlink fs ds = do 48 | createSymbolicLink regular slink_regular 49 | createSymbolicLink dir link_dir 50 | (fs', ls) <- getStatus slink_regular 51 | (ds', lds) <- getStatus link_dir 52 | 53 | let expected = (False,False,False,False,False,True,False) 54 | actualF = snd (statusElements ls) 55 | actualD = snd (statusElements lds) 56 | 57 | when (actualF /= expected) $ 58 | fail "unexpected file status bits for symlink to regular file" 59 | 60 | when (actualD /= expected) $ 61 | fail "unexpected file status bits for symlink to directory" 62 | 63 | when (statusElements fs /= statusElements fs') $ 64 | fail "status for a file does not match when it's accessed via a symlink" 65 | 66 | when (statusElements ds /= statusElements ds') $ 67 | fail "status for a directory does not match when it's accessed via a symlink" 68 | 69 | 70 | testLink = do 71 | createLink regular hlink_regular 72 | (fs, _) <- getStatus regular -- we need to retrieve it again as creating the link causes it to change! 73 | (fs', ls) <- getStatus hlink_regular 74 | snd (statusElements ls) @?= ( 75 | False, -- isBlockDevice 76 | False, -- isCharacterDevice 77 | False, -- isNamedPipe 78 | True, -- isRegularFile 79 | False, -- isDirectory 80 | False, -- isSymbolicLink 81 | False) -- isSocket 82 | linkCount fs' == 2 @? "Newly created hard link was expected to have a link count of 2" 83 | statusElements fs @?= statusElements fs' -- status for a file should match when accessed via a link 84 | 85 | 86 | cleanup = do 87 | ignoreIOExceptions $ removeDirectory dir 88 | mapM_ (ignoreIOExceptions . removeLink) 89 | [regular, hlink_regular, slink_regular, link_dir] 90 | 91 | ignoreIOExceptions io = io `E.catch` 92 | ((\_ -> return ()) :: IOException -> IO ()) 93 | 94 | getStatus f = do 95 | fs <- getFileStatus f 96 | ls <- getSymbolicLinkStatus f 97 | 98 | fd <- openFd f ReadOnly defaultFileFlags 99 | fs' <- getFdStatus fd 100 | 101 | when (statusElements fs /= statusElements fs') $ 102 | fail "getFileStatus and getFdStatus give inconsistent results" 103 | 104 | when (not (isSymbolicLink ls) && statusElements fs /= statusElements fs') $ 105 | fail $ "getFileStatus and getSymbolicLinkStatus give inconsistent results " 106 | ++ "on a file that is not a symbolic link" 107 | 108 | return (fs, ls) 109 | 110 | -- Yay for 20-element tuples! 111 | statusElements fs = (,) 112 | (deviceID fs 113 | ,fileMode fs 114 | ,linkCount fs 115 | ,fileOwner fs 116 | ,fileGroup fs 117 | ,specialDeviceID fs 118 | ,fileSize fs 119 | ,accessTime fs 120 | ,accessTimeHiRes fs 121 | ,modificationTime fs 122 | ,modificationTimeHiRes fs 123 | ,statusChangeTime fs 124 | ,statusChangeTimeHiRes fs 125 | ) 126 | (isBlockDevice fs 127 | ,isCharacterDevice fs 128 | ,isNamedPipe fs 129 | ,isRegularFile fs 130 | ,isDirectory fs 131 | ,isSymbolicLink fs 132 | ,isSocket fs 133 | ) 134 | -------------------------------------------------------------------------------- /System/Posix/Process.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : System.Posix.Process 5 | -- Copyright : (c) The University of Glasgow 2002 6 | -- License : BSD-style (see the file libraries/base/LICENSE) 7 | -- 8 | -- Maintainer : libraries@haskell.org 9 | -- Stability : provisional 10 | -- Portability : non-portable (requires POSIX) 11 | -- 12 | -- POSIX process support. See also the System.Cmd and System.Process 13 | -- modules in the process package. 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module System.Posix.Process ( 18 | -- * Processes 19 | 20 | -- ** Forking and executing 21 | forkProcess, 22 | forkProcessWithUnmask, 23 | executeFile, 24 | 25 | -- ** Exiting 26 | exitImmediately, 27 | 28 | -- ** Process environment 29 | getProcessID, 30 | getParentProcessID, 31 | 32 | -- ** Process groups 33 | getProcessGroupID, 34 | getProcessGroupIDOf, 35 | createProcessGroupFor, 36 | joinProcessGroup, 37 | setProcessGroupIDOf, 38 | 39 | -- ** Sessions 40 | createSession, 41 | 42 | -- ** Process times 43 | ProcessTimes(..), 44 | getProcessTimes, 45 | 46 | -- ** Scheduling priority 47 | nice, 48 | getProcessPriority, 49 | getProcessGroupPriority, 50 | getUserPriority, 51 | setProcessPriority, 52 | setProcessGroupPriority, 53 | setUserPriority, 54 | 55 | -- ** Process status 56 | ProcessStatus(..), 57 | getProcessStatus, 58 | getAnyProcessStatus, 59 | getGroupProcessStatus, 60 | 61 | -- ** Deprecated 62 | createProcessGroup, 63 | setProcessGroupID, 64 | 65 | ) where 66 | 67 | #include "HsUnix.h" 68 | 69 | import Foreign 70 | import Foreign.C 71 | import System.Posix.Process.Internals 72 | import System.Posix.Process.Common 73 | import System.Posix.Internals ( withFilePath ) 74 | 75 | #if !defined(HAVE_EXECV) 76 | import System.IO.Error ( ioeSetLocation ) 77 | import GHC.IO.Exception ( unsupportedOperation ) 78 | #endif 79 | 80 | -- | @'executeFile' cmd args env@ calls one of the 81 | -- @execv*@ family, depending on whether or not the current 82 | -- PATH is to be searched for the command, and whether or not an 83 | -- environment is provided to supersede the process's current 84 | -- environment. The basename (leading directory names suppressed) of 85 | -- the command is passed to @execv*@ as @arg[0]@; 86 | -- the argument list passed to 'executeFile' therefore 87 | -- begins with @arg[1]@. 88 | executeFile :: FilePath -- ^ Command 89 | -> Bool -- ^ Search PATH? 90 | -> [String] -- ^ Arguments 91 | -> Maybe [(String, String)] -- ^ Environment 92 | -> IO a 93 | #if !defined(HAVE_EXECV) 94 | 95 | {-# WARNING executeFile 96 | "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_EXECV@)" #-} 97 | executeFile _ _ _ _ = ioError (ioeSetLocation unsupportedOperation "executeFile") 98 | 99 | #else 100 | 101 | executeFile path search args Nothing = do 102 | withFilePath path $ \s -> 103 | withMany withFilePath (path:args) $ \cstrs -> 104 | withArray0 nullPtr cstrs $ \arr -> do 105 | pPrPr_disableITimers 106 | if search 107 | then throwErrnoPathIfMinus1_ "executeFile" path (c_execvp s arr) 108 | else throwErrnoPathIfMinus1_ "executeFile" path (c_execv s arr) 109 | return undefined -- never reached 110 | 111 | executeFile path search args (Just env) = do 112 | withFilePath path $ \s -> 113 | withMany withFilePath (path:args) $ \cstrs -> 114 | withArray0 nullPtr cstrs $ \arg_arr -> 115 | let env' = map (\ (name, val) -> name ++ ('=' : val)) env in 116 | withMany withFilePath env' $ \cenv -> 117 | withArray0 nullPtr cenv $ \env_arr -> do 118 | pPrPr_disableITimers 119 | if search 120 | then throwErrnoPathIfMinus1_ "executeFile" path 121 | (c_execvpe s arg_arr env_arr) 122 | else throwErrnoPathIfMinus1_ "executeFile" path 123 | (c_execve s arg_arr env_arr) 124 | return undefined -- never reached 125 | 126 | foreign import ccall unsafe "execvp" 127 | c_execvp :: CString -> Ptr CString -> IO CInt 128 | 129 | foreign import ccall unsafe "execv" 130 | c_execv :: CString -> Ptr CString -> IO CInt 131 | 132 | foreign import ccall unsafe "execve" 133 | c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt 134 | 135 | #endif // HAVE_EXECV 136 | -------------------------------------------------------------------------------- /System/Posix/DynamicLinker/Module.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : System.Posix.DynamicLinker.Module 5 | -- Copyright : (c) Volker Stolz 2003 6 | -- License : BSD-style (see the file libraries/base/LICENSE) 7 | -- 8 | -- Maintainer : vs@foldr.org 9 | -- Stability : provisional 10 | -- Portability : non-portable (requires POSIX) 11 | -- 12 | -- DLOpen support, old API 13 | -- Derived from GModule.chs by M.Weber & M.Chakravarty which is part of c2hs 14 | -- I left the API more or less the same, mostly the flags are different. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module System.Posix.DynamicLinker.Module ( 19 | 20 | -- Usage: 21 | -- ****** 22 | -- 23 | -- Let's assume you want to open a local shared library 'foo' (./libfoo.so) 24 | -- offering a function 25 | -- char * mogrify (char*,int) 26 | -- and invoke str = mogrify("test",1): 27 | -- 28 | -- type Fun = CString -> Int -> IO CString 29 | -- foreign import dynamic unsafe fun__ :: FunPtr Fun -> Fun 30 | -- 31 | -- withModule (Just ".") ("libfoo.so") [RTLD_NOW] $ \ mod -> do 32 | -- funptr <- moduleSymbol mod "mogrify" 33 | -- let fun = fun__ funptr 34 | -- withCString "test" $ \ str -> do 35 | -- strptr <- fun str 1 36 | -- strstr <- peekCString strptr 37 | -- ... 38 | 39 | Module 40 | , moduleOpen -- :: String -> ModuleFlags -> IO Module 41 | , moduleSymbol -- :: Source -> String -> IO (FunPtr a) 42 | , moduleClose -- :: Module -> IO Bool 43 | , moduleError -- :: IO String 44 | , withModule -- :: Maybe String 45 | -- -> String 46 | -- -> [ModuleFlags ] 47 | -- -> (Module -> IO a) 48 | -- -> IO a 49 | , withModule_ -- :: Maybe String 50 | -- -> String 51 | -- -> [ModuleFlags] 52 | -- -> (Module -> IO a) 53 | -- -> IO () 54 | ) 55 | where 56 | 57 | #include "HsUnix.h" 58 | 59 | import Prelude hiding (head, tail) 60 | import System.Posix.DynamicLinker 61 | import System.Posix.DynamicLinker.Common 62 | import Foreign.Ptr ( Ptr, nullPtr, FunPtr ) 63 | import System.Posix.Internals ( withFilePath ) 64 | 65 | unModule :: Module -> (Ptr ()) 66 | unModule (Module adr) = adr 67 | 68 | -- Opens a module (EXPORTED) 69 | -- 70 | 71 | moduleOpen :: String -> [RTLDFlags] -> IO Module 72 | moduleOpen file flags = do 73 | modPtr <- withFilePath file $ \ modAddr -> c_dlopen modAddr (packRTLDFlags flags) 74 | if (modPtr == nullPtr) 75 | then moduleError >>= \ err -> ioError (userError ("dlopen: " ++ err)) 76 | else return $ Module modPtr 77 | 78 | -- Gets a symbol pointer from a module (EXPORTED) 79 | -- 80 | moduleSymbol :: Module -> String -> IO (FunPtr a) 81 | moduleSymbol file sym = dlsym (DLHandle (unModule file)) sym 82 | 83 | -- Closes a module (EXPORTED) 84 | -- 85 | moduleClose :: Module -> IO () 86 | moduleClose file = dlclose (DLHandle (unModule file)) 87 | 88 | -- Gets a string describing the last module error (EXPORTED) 89 | -- 90 | moduleError :: IO String 91 | moduleError = dlerror 92 | 93 | 94 | -- Convenience function, cares for module open- & closing 95 | -- additionally returns status of `moduleClose' (EXPORTED) 96 | -- 97 | withModule :: Maybe String 98 | -> String 99 | -> [RTLDFlags] 100 | -> (Module -> IO a) 101 | -> IO a 102 | withModule mdir file flags p = do 103 | let modPath = case mdir of 104 | Nothing -> file 105 | Just dir -> dir ++ case unsnoc dir of 106 | Just (_, '/') -> file 107 | Just{} -> '/' : file 108 | Nothing -> error "System.Posix.DynamicLinker.Module.withModule: directory should not be Just \"\", pass Nothing instead" 109 | modu <- moduleOpen modPath flags 110 | result <- p modu 111 | moduleClose modu 112 | return result 113 | 114 | withModule_ :: Maybe String 115 | -> String 116 | -> [RTLDFlags] 117 | -> (Module -> IO a) 118 | -> IO () 119 | withModule_ dir file flags p = withModule dir file flags p >>= \ _ -> return () 120 | 121 | -- Dual to 'Data.List.uncons'. 122 | unsnoc :: [a] -> Maybe ([a], a) 123 | unsnoc = foldr go Nothing 124 | where 125 | go x Nothing = Just ([], x) 126 | go x (Just (xs, lst)) = Just (x : xs, lst) 127 | -------------------------------------------------------------------------------- /System/Posix/DynamicLinker/Prim.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | {-# OPTIONS_GHC -Wno-trustworthy-safe #-} 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : System.Posix.DynamicLinker.Prim 8 | -- Copyright : (c) Volker Stolz 2003 9 | -- License : BSD-style (see the file libraries/base/LICENSE) 10 | -- 11 | -- Maintainer : vs@foldr.org 12 | -- Stability : provisional 13 | -- Portability : non-portable (requires POSIX) 14 | -- 15 | -- @dlopen(3)@ and friends 16 | -- Derived from @GModule.chs@ by M.Weber & M.Chakravarty which is part of c2hs. 17 | -- I left the API more or less the same, mostly the flags are different. 18 | -- 19 | ----------------------------------------------------------------------------- 20 | 21 | module System.Posix.DynamicLinker.Prim ( 22 | -- * low level API 23 | c_dlopen, 24 | c_dlsym, 25 | c_dlerror, 26 | c_dlclose, 27 | -- dlAddr, -- XXX NYI 28 | haveRtldNext, 29 | haveRtldLocal, 30 | packRTLDFlags, 31 | RTLDFlags(..), 32 | packDL, 33 | DL(..), 34 | ) 35 | 36 | where 37 | 38 | #include "HsUnix.h" 39 | 40 | import Data.Bits ( (.|.) ) 41 | import Foreign.Ptr ( Ptr, FunPtr, nullPtr ) 42 | import Foreign.C.Types 43 | import Foreign.C.String ( CString ) 44 | 45 | #if !defined(HAVE_DLFCN_H) 46 | import Control.Exception ( throw ) 47 | import System.IO.Error ( ioeSetLocation ) 48 | import GHC.IO.Exception ( unsupportedOperation ) 49 | #endif 50 | 51 | -- |On some hosts (e.g. SuSe and Ubuntu Linux) @RTLD_NEXT@ (and 52 | -- @RTLD_DEFAULT@) are not visible without setting the macro 53 | -- @_GNU_SOURCE@. Since we don\'t want to define this macro, you can use 54 | -- the function 'haveRtldNext' to check whether the flag `Next` is 55 | -- available. Ideally, this will be optimized by the compiler so that it 56 | -- should be as efficient as an @#ifdef@. 57 | -- 58 | -- If you fail to test the flag and use it although it is undefined, 59 | -- 'packDL' will throw an error. 60 | 61 | haveRtldNext :: Bool 62 | 63 | #ifdef HAVE_RTLDNEXT 64 | haveRtldNext = True 65 | foreign import ccall unsafe "__hsunix_rtldNext" rtldNext :: Ptr a 66 | #else /* HAVE_RTLDNEXT */ 67 | haveRtldNext = False 68 | #endif /* HAVE_RTLDNEXT */ 69 | 70 | #ifdef HAVE_RTLDDEFAULT 71 | foreign import ccall unsafe "__hsunix_rtldDefault" rtldDefault :: Ptr a 72 | #endif /* HAVE_RTLDDEFAULT */ 73 | 74 | haveRtldLocal :: Bool 75 | haveRtldLocal = True 76 | {-# DEPRECATED haveRtldLocal "defaults to True" #-} 77 | 78 | 79 | -- |Flags for 'System.Posix.DynamicLinker.dlopen'. 80 | 81 | data RTLDFlags 82 | = RTLD_LAZY 83 | | RTLD_NOW 84 | | RTLD_GLOBAL 85 | | RTLD_LOCAL 86 | deriving (Show, Read) 87 | 88 | #if defined(HAVE_DLFCN_H) 89 | foreign import capi safe "dlfcn.h dlopen" c_dlopen :: CString -> CInt -> IO (Ptr ()) 90 | foreign import capi unsafe "dlfcn.h dlsym" c_dlsym :: Ptr () -> CString -> IO (FunPtr a) 91 | foreign import capi unsafe "dlfcn.h dlerror" c_dlerror :: IO CString 92 | foreign import capi safe "dlfcn.h dlclose" c_dlclose :: (Ptr ()) -> IO CInt 93 | #else 94 | foreign import ccall safe "dlopen" c_dlopen :: CString -> CInt -> IO (Ptr ()) 95 | foreign import ccall unsafe "dlsym" c_dlsym :: Ptr () -> CString -> IO (FunPtr a) 96 | foreign import ccall unsafe "dlerror" c_dlerror :: IO CString 97 | foreign import ccall safe "dlclose" c_dlclose :: (Ptr ()) -> IO CInt 98 | #endif // HAVE_DLFCN_H 99 | 100 | packRTLDFlags :: [RTLDFlags] -> CInt 101 | packRTLDFlags flags = foldl (\ s f -> (packRTLDFlag f) .|. s) 0 flags 102 | 103 | packRTLDFlag :: RTLDFlags -> CInt 104 | #if defined(HAVE_DLFCN_H) 105 | 106 | packRTLDFlag RTLD_LAZY = #const RTLD_LAZY 107 | packRTLDFlag RTLD_NOW = #const RTLD_NOW 108 | packRTLDFlag RTLD_GLOBAL = #const RTLD_GLOBAL 109 | packRTLDFlag RTLD_LOCAL = #const RTLD_LOCAL 110 | 111 | #else 112 | 113 | {-# WARNING packRTLDFlag 114 | "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_DLFCN_H@)" #-} 115 | packRTLDFlag _ = throw (ioeSetLocation unsupportedOperation "packRTLDFlag") 116 | 117 | #endif // HAVE_DLFCN_H 118 | 119 | -- |Flags for 'System.Posix.DynamicLinker.dlsym'. Notice that 'Next' 120 | -- might not be available on your particular platform! Use 121 | -- 'haveRtldNext'. 122 | -- 123 | -- If 'RTLD_DEFAULT' is not defined on your platform, 'packDL' 'Default' 124 | -- reduces to 'nullPtr'. 125 | 126 | data DL = Null | Next | Default | DLHandle (Ptr ()) deriving (Show) 127 | 128 | packDL :: DL -> Ptr () 129 | packDL Null = nullPtr 130 | 131 | #ifdef HAVE_RTLDNEXT 132 | packDL Next = rtldNext 133 | #else 134 | packDL Next = error "RTLD_NEXT not available" 135 | #endif 136 | 137 | #ifdef HAVE_RTLDDEFAULT 138 | packDL Default = rtldDefault 139 | #else 140 | packDL Default = nullPtr 141 | #endif 142 | 143 | packDL (DLHandle h) = h 144 | -------------------------------------------------------------------------------- /System/Posix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Safe #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : System.Posix 6 | -- Copyright : (c) The University of Glasgow 2002 7 | -- License : BSD-style (see the file libraries/base/LICENSE) 8 | -- 9 | -- Maintainer : libraries@haskell.org 10 | -- Stability : provisional 11 | -- Portability : non-portable (requires POSIX) 12 | -- 13 | -- support 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module System.Posix ( 18 | module System.Posix.Types, 19 | module System.Posix.Signals, 20 | module System.Posix.Directory, 21 | module System.Posix.Files, 22 | module System.Posix.Unistd, 23 | module System.Posix.IO, 24 | module System.Posix.Env, 25 | module System.Posix.Process, 26 | module System.Posix.Temp, 27 | module System.Posix.Terminal, 28 | module System.Posix.Time, 29 | module System.Posix.User, 30 | module System.Posix.Resource, 31 | module System.Posix.Semaphore, 32 | module System.Posix.SharedMem, 33 | module System.Posix.DynamicLinker, 34 | -- XXX 'Module' type clashes with GHC 35 | -- module System.Posix.DynamicLinker.Module 36 | ) where 37 | 38 | import System.Posix.Types 39 | import System.Posix.Signals 40 | import System.Posix.Directory 41 | import System.Posix.Files 42 | import System.Posix.Unistd 43 | import System.Posix.Process 44 | import System.Posix.IO 45 | import System.Posix.Env 46 | import System.Posix.Temp 47 | import System.Posix.Terminal 48 | import System.Posix.Time 49 | import System.Posix.User 50 | import System.Posix.Resource 51 | import System.Posix.Semaphore 52 | import System.Posix.SharedMem 53 | -- XXX: bad planning, we have two constructors called "Default" 54 | import System.Posix.DynamicLinker hiding (Default) 55 | --import System.Posix.DynamicLinker.Module 56 | 57 | {- TODO 58 | 59 | Here we detail our support for the IEEE Std 1003.1-2001 standard. For 60 | each header file defined by the standard, we categorise its 61 | functionality as 62 | 63 | - "supported" 64 | 65 | Full equivalent functionality is provided by the specified Haskell 66 | module. 67 | 68 | - "unsupported" (functionality not provided by a Haskell module) 69 | 70 | The functionality is not currently provided. 71 | 72 | - "to be supported" 73 | 74 | Currently unsupported, but support is planned for the future. 75 | 76 | Exceptions are listed where appropriate. 77 | 78 | Interfaces supported 79 | -------------------- 80 | 81 | unix package: 82 | 83 | dirent.h System.Posix.Directory 84 | dlfcn.h System.Posix.DynamicLinker 85 | errno.h Foreign.C.Error 86 | fcntl.h System.Posix.IO 87 | signal.h System.Posix.Signals 88 | sys/stat.h System.Posix.Files 89 | sys/times.h System.Posix.Process 90 | sys/types.h System.Posix.Types (with exceptions...) 91 | sys/utsname.h System.Posix.Unistd 92 | sys/wait.h System.Posix.Process 93 | termios.h System.Posix.Terminal (check exceptions) 94 | unistd.h System.Posix.* 95 | utime.h System.Posix.Files 96 | pwd.h System.Posix.User 97 | grp.h System.Posix.User 98 | stdlib.h: System.Posix.Env (getenv()/setenv()/unsetenv()) 99 | System.Posix.Temp (mkstemp()) 100 | sys/resource.h: System.Posix.Resource (get/setrlimit() only) 101 | 102 | regex-posix package: 103 | 104 | regex.h Text.Regex.Posix 105 | 106 | network package: 107 | 108 | arpa/inet.h 109 | net/if.h 110 | netinet/in.h 111 | netinet/tcp.h 112 | sys/socket.h 113 | sys/un.h 114 | 115 | To be supported 116 | --------------- 117 | 118 | limits.h (pathconf()/fpathconf() already done) 119 | poll.h 120 | sys/resource.h (getrusage(): use instead of times() for getProcessTimes?) 121 | sys/select.h 122 | sys/statvfs.h (?) 123 | sys/time.h (but maybe not the itimer?) 124 | time.h (System.Posix.Time) 125 | stdio.h (popen only: System.Posix.IO) 126 | sys/mman.h 127 | 128 | Unsupported interfaces 129 | ---------------------- 130 | 131 | aio.h 132 | assert.h 133 | complex.h 134 | cpio.h 135 | ctype.h 136 | fenv.h 137 | float.h 138 | fmtmsg.h 139 | fnmatch.h 140 | ftw.h 141 | glob.h 142 | iconv.h 143 | inttypes.h 144 | iso646.h 145 | langinfo.h 146 | libgen.h 147 | locale.h (see System.Locale) 148 | math.h 149 | monetary.h 150 | mqueue.h 151 | ndbm.h 152 | netdb.h 153 | nl_types.h 154 | pthread.h 155 | sched.h 156 | search.h 157 | semaphore.h 158 | setjmp.h 159 | spawn.h 160 | stdarg.h 161 | stdbool.h 162 | stddef.h 163 | stdint.h 164 | stdio.h except: popen() 165 | stdlib.h except: exit(): System.Posix.Process 166 | free()/malloc(): Foreign.Marshal.Alloc 167 | getenv()/setenv(): ?? System.Environment 168 | rand() etc.: System.Random 169 | string.h 170 | strings.h 171 | stropts.h 172 | sys/ipc.h 173 | sys/msg.h 174 | sys/sem.h 175 | sys/shm.h 176 | sys/timeb.h 177 | sys/uio.h 178 | syslog.h 179 | tar.h 180 | tgmath.h 181 | trace.h 182 | ucontext.h 183 | ulimit.h 184 | utmpx.h 185 | wchar.h 186 | wctype.h 187 | wordexp.h 188 | 189 | -} 190 | -------------------------------------------------------------------------------- /System/Posix/Process/ByteString.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : System.Posix.Process.ByteString 6 | -- Copyright : (c) The University of Glasgow 2002 7 | -- License : BSD-style (see the file libraries/base/LICENSE) 8 | -- 9 | -- Maintainer : libraries@haskell.org 10 | -- Stability : provisional 11 | -- Portability : non-portable (requires POSIX) 12 | -- 13 | -- POSIX process support. See also the System.Cmd and System.Process 14 | -- modules in the process package. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module System.Posix.Process.ByteString ( 19 | -- * Processes 20 | 21 | -- ** Forking and executing 22 | forkProcess, 23 | forkProcessWithUnmask, 24 | executeFile, 25 | 26 | -- ** Exiting 27 | exitImmediately, 28 | 29 | -- ** Process environment 30 | getProcessID, 31 | getParentProcessID, 32 | 33 | -- ** Process groups 34 | getProcessGroupID, 35 | getProcessGroupIDOf, 36 | createProcessGroupFor, 37 | joinProcessGroup, 38 | setProcessGroupIDOf, 39 | 40 | -- ** Sessions 41 | createSession, 42 | 43 | -- ** Process times 44 | ProcessTimes(..), 45 | getProcessTimes, 46 | 47 | -- ** Scheduling priority 48 | nice, 49 | getProcessPriority, 50 | getProcessGroupPriority, 51 | getUserPriority, 52 | setProcessPriority, 53 | setProcessGroupPriority, 54 | setUserPriority, 55 | 56 | -- ** Process status 57 | ProcessStatus(..), 58 | getProcessStatus, 59 | getAnyProcessStatus, 60 | getGroupProcessStatus, 61 | 62 | -- ** Deprecated 63 | createProcessGroup, 64 | setProcessGroupID, 65 | 66 | ) where 67 | 68 | #include "HsUnix.h" 69 | 70 | import Foreign 71 | import System.Posix.Process.Internals 72 | import System.Posix.Process.Common 73 | 74 | import Foreign.C hiding ( 75 | throwErrnoPath, 76 | throwErrnoPathIf, 77 | throwErrnoPathIf_, 78 | throwErrnoPathIfNull, 79 | throwErrnoPathIfMinus1, 80 | throwErrnoPathIfMinus1_ ) 81 | 82 | import Data.ByteString (ByteString) 83 | import qualified Data.ByteString.Char8 as BC 84 | 85 | import System.Posix.ByteString.FilePath 86 | 87 | #if !defined(HAVE_EXECV) 88 | import System.IO.Error ( ioeSetLocation ) 89 | import GHC.IO.Exception ( unsupportedOperation ) 90 | #endif 91 | 92 | -- | @'executeFile' cmd args env@ calls one of the 93 | -- @execv*@ family, depending on whether or not the current 94 | -- PATH is to be searched for the command, and whether or not an 95 | -- environment is provided to supersede the process's current 96 | -- environment. The basename (leading directory names suppressed) of 97 | -- the command is passed to @execv*@ as @arg[0]@; 98 | -- the argument list passed to 'executeFile' therefore 99 | -- begins with @arg[1]@. 100 | executeFile :: RawFilePath -- ^ Command 101 | -> Bool -- ^ Search PATH? 102 | -> [ByteString] -- ^ Arguments 103 | -> Maybe [(ByteString, ByteString)] -- ^ Environment 104 | -> IO a 105 | #if !defined(HAVE_EXECV) 106 | 107 | {-# WARNING executeFile 108 | "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_EXECV@)" #-} 109 | executeFile _ _ _ _ = ioError (ioeSetLocation unsupportedOperation "executeFile") 110 | 111 | #else 112 | 113 | executeFile path search args Nothing = do 114 | withFilePath path $ \s -> 115 | withMany withFilePath (path:args) $ \cstrs -> 116 | withArray0 nullPtr cstrs $ \arr -> do 117 | pPrPr_disableITimers 118 | if search 119 | then throwErrnoPathIfMinus1_ "executeFile" path (c_execvp s arr) 120 | else throwErrnoPathIfMinus1_ "executeFile" path (c_execv s arr) 121 | return undefined -- never reached 122 | 123 | executeFile path search args (Just env) = do 124 | withFilePath path $ \s -> 125 | withMany withFilePath (path:args) $ \cstrs -> 126 | withArray0 nullPtr cstrs $ \arg_arr -> 127 | let env' = map (\ (name, val) -> name `BC.append` ('=' `BC.cons` val)) env in 128 | withMany withFilePath env' $ \cenv -> 129 | withArray0 nullPtr cenv $ \env_arr -> do 130 | pPrPr_disableITimers 131 | if search 132 | then throwErrnoPathIfMinus1_ "executeFile" path 133 | (c_execvpe s arg_arr env_arr) 134 | else throwErrnoPathIfMinus1_ "executeFile" path 135 | (c_execve s arg_arr env_arr) 136 | return undefined -- never reached 137 | 138 | foreign import ccall unsafe "execvp" 139 | c_execvp :: CString -> Ptr CString -> IO CInt 140 | 141 | foreign import ccall unsafe "execv" 142 | c_execv :: CString -> Ptr CString -> IO CInt 143 | 144 | foreign import ccall unsafe "execve" 145 | c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt 146 | 147 | #endif // HAVE_EXECV 148 | -------------------------------------------------------------------------------- /tests/FileExtendedStatus.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | 3 | module FileExtendedStatus (main) where 4 | 5 | import System.Posix.Files 6 | import System.Posix.Directory 7 | import System.Posix.IO 8 | import System.Posix.Types 9 | import Control.Exception as E 10 | import Control.Monad 11 | import Test.Tasty.HUnit 12 | 13 | main = do 14 | cleanup 15 | fs <- testRegular 16 | ds <- testDir 17 | testSymlink fs ds 18 | testLink 19 | cleanup 20 | 21 | regular = "regular" 22 | dir = "dir" 23 | slink_regular = "link-regular-symlink" 24 | hlink_regular = "link-regular-hardlink" 25 | link_dir = "link-dir" 26 | 27 | testRegular = do 28 | _ <- createFile regular ownerReadMode 29 | (fs, _) <- getStatus regular 30 | let expected = (False,False,False,True,False,False,False) 31 | actual = snd (statusExtendedElements fs) 32 | when (actual /= expected) $ 33 | fail "unexpected file status bits for regular file" 34 | return fs 35 | 36 | testDir = do 37 | createDirectory dir ownerReadMode 38 | (ds, _) <- getStatus dir 39 | let expected = (False,False,False,False,True,False,False) 40 | actual = snd (statusExtendedElements ds) 41 | when (actual /= expected) $ 42 | fail "unexpected file status bits for directory" 43 | return ds 44 | 45 | testSymlink fs ds = do 46 | createSymbolicLink regular slink_regular 47 | createSymbolicLink dir link_dir 48 | (fs', ls) <- getStatus slink_regular 49 | (ds', lds) <- getStatus link_dir 50 | 51 | let expected = (False,False,False,False,False,True,False) 52 | actualF = snd (statusExtendedElements ls) 53 | actualD = snd (statusExtendedElements lds) 54 | 55 | when (actualF /= expected) $ 56 | fail "unexpected file status bits for symlink to regular file" 57 | 58 | when (actualD /= expected) $ 59 | fail "unexpected file status bits for symlink to directory" 60 | 61 | when (statusExtendedElements fs /= statusExtendedElements fs') $ 62 | fail "status for a file does not match when it's accessed via a symlink" 63 | 64 | when (statusExtendedElements ds /= statusExtendedElements ds') $ 65 | fail "status for a directory does not match when it's accessed via a symlink" 66 | 67 | 68 | testLink = do 69 | createLink regular hlink_regular 70 | (fs, _) <- getStatus regular -- we need to retrieve it again as creating the link causes it to change! 71 | (fs', ls) <- getStatus hlink_regular 72 | snd (statusExtendedElements ls) @?= ( 73 | False, -- isBlockDevice 74 | False, -- isCharacterDevice 75 | False, -- isNamedPipe 76 | True, -- isRegularFile 77 | False, -- isDirectory 78 | False, -- isSymbolicLink 79 | False) -- isSocket 80 | linkCountX fs' @?= 2 81 | statusExtendedElements fs @?= statusExtendedElements fs' -- status for a file should match when accessed via a link 82 | 83 | 84 | cleanup = do 85 | ignoreIOExceptions $ removeDirectory dir 86 | mapM_ (ignoreIOExceptions . removeLink) 87 | [regular, hlink_regular, slink_regular, link_dir] 88 | 89 | ignoreIOExceptions io = io `E.catch` 90 | ((\_ -> return ()) :: IOException -> IO ()) 91 | 92 | getStatus f = do 93 | fs <- getExtendedFileStatus Nothing f defaultStatxFlags defaultStatxMask 94 | ls <- getExtendedFileStatus Nothing f SymlinkNoFollow defaultStatxMask 95 | fs' <- getFileStatus f 96 | 97 | statusExtendedElementsMinimal fs @?= statusElementsMinimal fs' 98 | 99 | return (fs, ls) 100 | 101 | -- Yay for 20-element tuples! 102 | statusExtendedElements fs = (,) 103 | (fileBlockSizeX fs 104 | ,linkCountX fs 105 | ,fileOwnerX fs 106 | ,fileGroupX fs 107 | ,fileModeX fs 108 | ,fileIDX fs 109 | ,fileSizeX fs 110 | ,accessTimeHiResX fs 111 | ,creationTimeHiResX fs 112 | ,statusChangeTimeHiResX fs 113 | ,modificationTimeHiResX fs 114 | ) 115 | (isBlockDeviceX fs 116 | ,isCharacterDeviceX fs 117 | ,isNamedPipeX fs 118 | ,isRegularFileX fs 119 | ,isDirectoryX fs 120 | ,isSymbolicLinkX fs 121 | ,isSocketX fs 122 | ) 123 | 124 | statusExtendedElementsMinimal fs = (,) 125 | (fileModeX fs 126 | ,deviceIDX fs 127 | ,specialDeviceIDX fs 128 | ,linkCountX fs 129 | ,fileOwnerX fs 130 | ,fileGroupX fs 131 | ,COff (fromIntegral (fileSizeX fs)) 132 | ,Just $ CBlkCnt (fromIntegral (fileBlocksX fs)) 133 | ,accessTimeHiResX fs 134 | ,statusChangeTimeHiResX fs 135 | ,modificationTimeHiResX fs 136 | ) 137 | (isBlockDeviceX fs 138 | ,isCharacterDeviceX fs 139 | ,isNamedPipeX fs 140 | ,isRegularFileX fs 141 | ,isDirectoryX fs 142 | ,isSymbolicLinkX fs 143 | ,isSocketX fs 144 | ) 145 | 146 | statusElementsMinimal fs = (,) 147 | (fileMode fs 148 | ,deviceID fs 149 | ,specialDeviceID fs 150 | ,linkCount fs 151 | ,fileOwner fs 152 | ,fileGroup fs 153 | ,fileSize fs 154 | ,fileBlocks fs 155 | ,accessTimeHiRes fs 156 | ,statusChangeTimeHiRes fs 157 | ,modificationTimeHiRes fs 158 | ) 159 | (isBlockDevice fs 160 | ,isCharacterDevice fs 161 | ,isNamedPipe fs 162 | ,isRegularFile fs 163 | ,isDirectory fs 164 | ,isSymbolicLink fs 165 | ,isSocket fs 166 | ) 167 | -------------------------------------------------------------------------------- /System/Posix/IO/ByteString.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : System.Posix.IO.ByteString 5 | -- Copyright : (c) The University of Glasgow 2002 6 | -- License : BSD-style (see the file libraries/base/LICENSE) 7 | -- 8 | -- Maintainer : libraries@haskell.org 9 | -- Stability : provisional 10 | -- Portability : non-portable (requires POSIX) 11 | -- 12 | -- POSIX IO support. These types and functions correspond to the unix 13 | -- functions open(2), close(2), etc. For more portable functions 14 | -- which are more like fopen(3) and friends from stdio.h, see 15 | -- "System.IO". 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | #include "HsUnix.h" 20 | 21 | module System.Posix.IO.ByteString ( 22 | -- * Input \/ Output 23 | 24 | -- ** Standard file descriptors 25 | stdInput, stdOutput, stdError, 26 | 27 | -- ** Opening and closing files 28 | OpenMode(..), 29 | OpenFileFlags(..), defaultFileFlags, 30 | openFd, openFdAt, createFile, createFileAt, 31 | closeFd, 32 | 33 | -- ** Reading\/writing data 34 | -- |Programmers using the 'fdRead' and 'fdWrite' API should be aware that 35 | -- EAGAIN exceptions may occur for non-blocking IO! 36 | 37 | fdRead, fdWrite, 38 | fdReadBuf, fdWriteBuf, 39 | 40 | -- ** Seeking 41 | fdSeek, 42 | 43 | -- ** File options 44 | FdOption(..), 45 | queryFdOption, 46 | setFdOption, 47 | 48 | -- ** Locking 49 | FileLock, 50 | LockRequest(..), 51 | getLock, setLock, 52 | waitToSetLock, 53 | 54 | -- ** Pipes 55 | createPipe, 56 | 57 | -- ** Duplicating file descriptors 58 | dup, dupTo, 59 | 60 | -- ** Converting file descriptors to\/from Handles 61 | handleToFd, 62 | fdToHandle, 63 | 64 | ) where 65 | 66 | import Data.ByteString ( ByteString, empty ) 67 | import qualified Data.ByteString.Internal as BI 68 | import qualified Data.ByteString.Unsafe as BU 69 | 70 | import Foreign ( castPtr ) 71 | 72 | import GHC.IO.Exception ( IOErrorType(EOF) ) 73 | 74 | import System.IO.Error ( ioeSetErrorString, mkIOError ) 75 | 76 | import System.Posix.Types 77 | import System.Posix.IO.Common 78 | 79 | import System.Posix.ByteString.FilePath 80 | 81 | -- |Open and optionally create this file. See 'System.Posix.Files' 82 | -- for information on how to use the 'FileMode' type. 83 | openFd :: RawFilePath 84 | -> OpenMode 85 | -> OpenFileFlags 86 | -> IO Fd 87 | openFd = openFdAt Nothing 88 | 89 | -- | Open a file relative to an optional directory file descriptor. 90 | -- 91 | -- Directory file descriptors can be used to avoid some race conditions when 92 | -- navigating changing directory trees, or to retain access to a portion of the 93 | -- directory tree that would otherwise become inaccessible after dropping 94 | -- privileges. 95 | openFdAt :: Maybe Fd -- ^ Optional directory file descriptor 96 | -> RawFilePath -- ^ Pathname to open 97 | -> OpenMode -- ^ Read-only, read-write or write-only 98 | -> OpenFileFlags -- ^ Append, exclusive, truncate, etc. 99 | -> IO Fd 100 | openFdAt fdMay name how flags = 101 | withFilePath name $ \str -> 102 | throwErrnoPathIfMinus1Retry "openFdAt" name $ 103 | openat_ fdMay str how flags 104 | 105 | -- |Create and open this file in WriteOnly mode. A special case of 106 | -- 'openFd'. See 'System.Posix.Files' for information on how to use 107 | -- the 'FileMode' type. 108 | createFile :: RawFilePath -> FileMode -> IO Fd 109 | createFile = createFileAt Nothing 110 | 111 | -- | Create and open a file for write-only, with default flags, 112 | -- relative an optional directory file-descriptor. 113 | -- 114 | -- Directory file descriptors can be used to avoid some race conditions when 115 | -- navigating changing directory trees, or to retain access to a portion of the 116 | -- directory tree that would otherwise become inaccessible after dropping 117 | -- privileges. 118 | createFileAt :: Maybe Fd -- ^ Optional directory file descriptor 119 | -> RawFilePath -- ^ Pathname to create 120 | -> FileMode -- ^ File permission bits (before umask) 121 | -> IO Fd 122 | createFileAt fdMay name mode 123 | = openFdAt fdMay name WriteOnly defaultFileFlags{ trunc=True, creat=(Just mode) } 124 | 125 | -- | Read data from an 'Fd' and return it as a 'ByteString'. 126 | -- Throws an exception if this is an invalid descriptor, or EOF has been 127 | -- reached. 128 | fdRead :: Fd 129 | -> ByteCount -- ^How many bytes to read 130 | -> IO ByteString -- ^The bytes read 131 | fdRead _fd 0 = return empty 132 | fdRead fd nbytes = 133 | BI.createUptoN (fromIntegral nbytes) $ \ buf -> do 134 | rc <- fdReadBuf fd buf nbytes 135 | case rc of 136 | 0 -> ioError (ioeSetErrorString (mkIOError EOF "fdRead" Nothing Nothing) "EOF") 137 | n -> return (fromIntegral n) 138 | 139 | -- | Write a 'ByteString' to an 'Fd'. 140 | fdWrite :: Fd -> ByteString -> IO ByteCount 141 | fdWrite fd bs = 142 | BU.unsafeUseAsCStringLen bs $ \ (buf,len) -> 143 | fdWriteBuf fd (castPtr buf) (fromIntegral len) 144 | -------------------------------------------------------------------------------- /System/Posix/Temp/ByteString.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | {-# LANGUAGE Safe #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : System.Posix.Temp.ByteString 6 | -- Copyright : (c) Volker Stolz 7 | -- Deian Stefan 8 | -- License : BSD-style (see the file libraries/base/LICENSE) 9 | -- 10 | -- Maintainer : libraries@haskell.org, vs@foldr.org, deian@cs.stanford.edu 11 | -- Stability : provisional 12 | -- Portability : non-portable (requires POSIX) 13 | -- 14 | -- POSIX temporary file and directory creation functions. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module System.Posix.Temp.ByteString ( 19 | mkstemp, mkstemps, mkdtemp 20 | ) where 21 | 22 | #include "HsUnix.h" 23 | 24 | import Data.ByteString (ByteString) 25 | import qualified Data.ByteString as B 26 | import qualified Data.ByteString.Char8 as BC 27 | 28 | import Foreign.C 29 | 30 | import System.IO 31 | import System.Posix.ByteString.FilePath 32 | #if !HAVE_MKDTEMP 33 | import System.Posix.Directory (createDirectory) 34 | #endif 35 | import System.Posix.IO 36 | import System.Posix.Types 37 | 38 | #if !defined(HAVE_MKSTEMP) 39 | import System.IO.Error ( ioeSetLocation ) 40 | import GHC.IO.Exception ( unsupportedOperation ) 41 | #endif 42 | 43 | #if !defined(HAVE_MKSTEMP) 44 | 45 | {-# WARNING mkstemp "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_MKSTEMP@)" #-} 46 | mkstemp :: ByteString -> IO (RawFilePath, Handle) 47 | mkstemp _ = ioError (ioeSetLocation unsupportedOperation "mkstemp") 48 | 49 | #else 50 | 51 | foreign import capi unsafe "HsUnix.h mkstemp" 52 | c_mkstemp :: CString -> IO CInt 53 | 54 | -- | Make a unique filename and open it for reading\/writing. The returned 55 | -- 'RawFilePath' is the (possibly relative) path of the created file, which is 56 | -- padded with 6 random characters. The argument is the desired prefix of the 57 | -- filepath of the temporary file to be created. 58 | -- 59 | -- If you aren't using GHC or Hugs then this function simply wraps mktemp and 60 | -- so shouldn't be considered safe. 61 | mkstemp :: ByteString -> IO (RawFilePath, Handle) 62 | mkstemp template' = do 63 | let template = template' `B.append` (BC.pack "XXXXXX") 64 | withFilePath template $ \ ptr -> do 65 | fd <- throwErrnoIfMinus1 "mkstemp" (c_mkstemp ptr) 66 | name <- peekFilePath ptr 67 | h <- fdToHandle (Fd fd) 68 | return (name, h) 69 | 70 | #endif // HAVE_MKSTEMP 71 | 72 | #if HAVE_MKSTEMPS 73 | foreign import capi unsafe "HsUnix.h mkstemps" 74 | c_mkstemps :: CString -> CInt -> IO CInt 75 | #endif 76 | 77 | -- |'mkstemps' - make a unique filename with a given prefix and suffix 78 | -- and open it for reading\/writing (only safe on GHC & Hugs). 79 | -- The returned 'RawFilePath' is the (possibly relative) path of 80 | -- the created file, which contains 6 random characters in between 81 | -- the prefix and suffix. 82 | mkstemps :: ByteString -> ByteString -> IO (RawFilePath, Handle) 83 | #if HAVE_MKSTEMPS 84 | mkstemps prefix suffix = do 85 | let template = prefix `B.append` (BC.pack "XXXXXX") `B.append` suffix 86 | lenOfsuf = (fromIntegral $ B.length suffix) :: CInt 87 | withFilePath template $ \ ptr -> do 88 | fd <- throwErrnoIfMinus1 "mkstemps" (c_mkstemps ptr lenOfsuf) 89 | name <- peekFilePath ptr 90 | h <- fdToHandle (Fd fd) 91 | return (name, h) 92 | #else 93 | {-# WARNING mkstemps "System.Posix.Temp.mkstemps: not available on this platform" #-} 94 | mkstemps = error "System.Posix.Temp.mkstemps: not available on this platform" 95 | #endif 96 | 97 | #if HAVE_MKDTEMP 98 | foreign import capi unsafe "HsUnix.h mkdtemp" 99 | c_mkdtemp :: CString -> IO CString 100 | #endif 101 | 102 | -- | Make a unique directory. The returned 'RawFilePath' is the path of the 103 | -- created directory, which is padded with 6 random characters. The argument is 104 | -- the desired prefix of the filepath of the temporary directory to be created. 105 | -- 106 | -- If you aren't using GHC or Hugs then this function simply wraps mktemp and 107 | -- so shouldn't be considered safe. 108 | mkdtemp :: ByteString -> IO RawFilePath 109 | mkdtemp template' = do 110 | let template = template' `B.append` (BC.pack "XXXXXX") 111 | #if HAVE_MKDTEMP 112 | withFilePath template $ \ ptr -> do 113 | _ <- throwErrnoIfNull "mkdtemp" (c_mkdtemp ptr) 114 | name <- peekFilePath ptr 115 | return name 116 | #else 117 | name <- mktemp template 118 | _ <- createDirectory (BC.unpack name) (toEnum 0o700) 119 | return name 120 | #endif 121 | 122 | #if !HAVE_MKDTEMP 123 | 124 | foreign import ccall unsafe "mktemp" 125 | c_mktemp :: CString -> IO CString 126 | 127 | -- | Make a unique file name It is required that the template have six trailing 128 | -- \'X\'s. This function should be considered deprecated. 129 | {-# WARNING mktemp "This function is unsafe; use mkstemp instead" #-} 130 | mktemp :: ByteString -> IO RawFilePath 131 | mktemp template = do 132 | withFilePath template $ \ ptr -> do 133 | ptr' <- throwErrnoIfNull "mktemp" (c_mktemp ptr) 134 | peekFilePath ptr' 135 | #endif 136 | -------------------------------------------------------------------------------- /System/Posix/Directory.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | {-# LANGUAGE NondecreasingIndentation #-} 3 | {-# LANGUAGE Safe #-} 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : System.Posix.Directory 8 | -- Copyright : (c) The University of Glasgow 2002 9 | -- License : BSD-style (see the file libraries/base/LICENSE) 10 | -- 11 | -- Maintainer : libraries@haskell.org 12 | -- Stability : provisional 13 | -- Portability : non-portable (requires POSIX) 14 | -- 15 | -- String-based POSIX directory support 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | #include "HsUnix.h" 20 | 21 | -- hack copied from System.Posix.Files 22 | #if !defined(PATH_MAX) 23 | # define PATH_MAX 4096 24 | #endif 25 | 26 | module System.Posix.Directory ( 27 | -- * Creating and removing directories 28 | createDirectory, removeDirectory, 29 | 30 | -- * Reading directories 31 | DirStream, 32 | openDirStream, 33 | readDirStream, 34 | readDirStreamMaybe, 35 | rewindDirStream, 36 | closeDirStream, 37 | DirStreamOffset, 38 | #ifdef HAVE_TELLDIR 39 | tellDirStream, 40 | #endif 41 | #ifdef HAVE_SEEKDIR 42 | seekDirStream, 43 | #endif 44 | 45 | -- * The working dirctory 46 | getWorkingDirectory, 47 | changeWorkingDirectory, 48 | changeWorkingDirectoryFd, 49 | ) where 50 | 51 | import Control.Monad ((>=>)) 52 | import Data.Maybe 53 | import System.Posix.Error 54 | import System.Posix.Types 55 | import Foreign 56 | import Foreign.C 57 | 58 | import System.Posix.Directory.Common 59 | import System.Posix.Internals (withFilePath, peekFilePath) 60 | 61 | -- | @createDirectory dir mode@ calls @mkdir@ to 62 | -- create a new directory, @dir@, with permissions based on 63 | -- @mode@. 64 | createDirectory :: FilePath -> FileMode -> IO () 65 | createDirectory name mode = 66 | withFilePath name $ \s -> 67 | throwErrnoPathIfMinus1Retry_ "createDirectory" name (c_mkdir s mode) 68 | -- POSIX doesn't allow mkdir() to return EINTR, but it does on 69 | -- OS X (#5184), so we need the Retry variant here. 70 | 71 | foreign import ccall unsafe "mkdir" 72 | c_mkdir :: CString -> CMode -> IO CInt 73 | 74 | -- | @openDirStream dir@ calls @opendir@ to obtain a 75 | -- directory stream for @dir@. 76 | openDirStream :: FilePath -> IO DirStream 77 | openDirStream name = 78 | withFilePath name $ \s -> do 79 | dirp <- throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s 80 | return (DirStream dirp) 81 | 82 | foreign import capi unsafe "HsUnix.h opendir" 83 | c_opendir :: CString -> IO (Ptr CDir) 84 | 85 | -- | @readDirStream dp@ calls @readdir@ to obtain the 86 | -- next directory entry (@struct dirent@) for the open directory 87 | -- stream @dp@, and returns the @d_name@ member of that 88 | -- structure. 89 | -- 90 | -- Note that this function returns an empty filepath if the end of the 91 | -- directory stream is reached. For a safer alternative use 92 | -- 'readDirStreamMaybe'. 93 | readDirStream :: DirStream -> IO FilePath 94 | readDirStream = fmap (fromMaybe "") . readDirStreamMaybe 95 | 96 | -- | @readDirStreamMaybe dp@ calls @readdir@ to obtain the 97 | -- next directory entry (@struct dirent@) for the open directory 98 | -- stream @dp@. It returns the @d_name@ member of that 99 | -- structure wrapped in a @Just d_name@ if an entry was read and @Nothing@ if 100 | -- the end of the directory stream was reached. 101 | readDirStreamMaybe :: DirStream -> IO (Maybe FilePath) 102 | readDirStreamMaybe = readDirStreamWith (dirEntName >=> peekFilePath) 103 | 104 | 105 | -- | @getWorkingDirectory@ calls @getcwd@ to obtain the name 106 | -- of the current working directory. 107 | getWorkingDirectory :: IO FilePath 108 | getWorkingDirectory = go (#const PATH_MAX) 109 | where 110 | go bytes = do 111 | r <- allocaBytes bytes $ \buf -> do 112 | buf' <- c_getcwd buf (fromIntegral bytes) 113 | if buf' /= nullPtr 114 | then do s <- peekFilePath buf 115 | return (Just s) 116 | else do errno <- getErrno 117 | if errno == eRANGE 118 | -- we use Nothing to indicate that we should 119 | -- try again with a bigger buffer 120 | then return Nothing 121 | else throwErrno "getWorkingDirectory" 122 | maybe (go (2 * bytes)) return r 123 | 124 | foreign import ccall unsafe "getcwd" 125 | c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar) 126 | 127 | -- | @changeWorkingDirectory dir@ calls @chdir@ to change 128 | -- the current working directory to @dir@. 129 | changeWorkingDirectory :: FilePath -> IO () 130 | changeWorkingDirectory path = 131 | withFilePath path $ \s -> 132 | throwErrnoPathIfMinus1Retry_ "changeWorkingDirectory" path (c_chdir s) 133 | 134 | foreign import ccall unsafe "chdir" 135 | c_chdir :: CString -> IO CInt 136 | 137 | removeDirectory :: FilePath -> IO () 138 | removeDirectory path = 139 | withFilePath path $ \s -> 140 | throwErrnoPathIfMinus1Retry_ "removeDirectory" path (c_rmdir s) 141 | 142 | foreign import ccall unsafe "rmdir" 143 | c_rmdir :: CString -> IO CInt 144 | -------------------------------------------------------------------------------- /System/Posix/Temp.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | {-# LANGUAGE Safe #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : System.Posix.Temp 6 | -- Copyright : (c) Volker Stolz 7 | -- Deian Stefan 8 | -- License : BSD-style (see the file libraries/base/LICENSE) 9 | -- 10 | -- Maintainer : libraries@haskell.org, vs@foldr.org, deian@cs.stanford.edu 11 | -- Stability : provisional 12 | -- Portability : non-portable (requires POSIX) 13 | -- 14 | -- POSIX temporary file and directory creation functions. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module System.Posix.Temp ( 19 | mkstemp, mkstemps, mkdtemp 20 | ) where 21 | 22 | #include "HsUnix.h" 23 | 24 | import Foreign.C 25 | import System.IO 26 | #if !HAVE_MKDTEMP 27 | import System.Posix.Directory (createDirectory) 28 | #endif 29 | import System.Posix.IO 30 | import System.Posix.Types 31 | import System.Posix.Internals (withFilePath, peekFilePath) 32 | 33 | #if !defined(HAVE_MKSTEMP) 34 | import System.IO.Error ( ioeSetLocation ) 35 | import GHC.IO.Exception ( unsupportedOperation ) 36 | #endif 37 | 38 | #if !defined(HAVE_MKSTEMP) 39 | 40 | {-# WARNING mkstemp "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_MKSTEMP@)" #-} 41 | mkstemp :: String -> IO (FilePath, Handle) 42 | mkstemp _ = ioError (ioeSetLocation unsupportedOperation "mkstemp") 43 | 44 | #else 45 | 46 | foreign import capi unsafe "HsUnix.h mkstemp" 47 | c_mkstemp :: CString -> IO CInt 48 | 49 | -- | Make a unique filename and open it for reading\/writing. The returned 50 | -- 'FilePath' is the (possibly relative) path of the created file, which is 51 | -- padded with 6 random characters. The argument is the desired prefix of the 52 | -- filepath of the temporary file to be created. 53 | -- 54 | -- If you aren't using GHC or Hugs then this function simply wraps mktemp and 55 | -- so shouldn't be considered safe. 56 | mkstemp :: String -> IO (FilePath, Handle) 57 | mkstemp template' = do 58 | let template = template' ++ "XXXXXX" 59 | withFilePath template $ \ ptr -> do 60 | fd <- throwErrnoIfMinus1 "mkstemp" (c_mkstemp ptr) 61 | name <- peekFilePath ptr 62 | h <- fdToHandle (Fd fd) 63 | return (name, h) 64 | 65 | #endif // HAVE_MKSTEMP 66 | 67 | #if HAVE_MKSTEMPS 68 | foreign import capi unsafe "HsUnix.h mkstemps" 69 | c_mkstemps :: CString -> CInt -> IO CInt 70 | #endif 71 | 72 | -- | Make a unique filename with a given prefix and suffix and open it for 73 | -- reading\/writing. The returned 'FilePath' is the (possibly relative) path of 74 | -- the created file, which contains 6 random characters in between the prefix 75 | -- and suffix. The first argument is the desired prefix of the filepath of the 76 | -- temporary file to be created. The second argument is the suffix of the 77 | -- temporary file to be created. 78 | -- 79 | -- If you are using as system that doesn't support the mkstemps glibc function 80 | -- (supported in glibc > 2.11) then this function simply throws an error. 81 | mkstemps :: String -> String -> IO (FilePath, Handle) 82 | #if HAVE_MKSTEMPS 83 | mkstemps prefix suffix = do 84 | let template = prefix ++ "XXXXXX" ++ suffix 85 | lenOfsuf = (fromIntegral $ length suffix) :: CInt 86 | withFilePath template $ \ ptr -> do 87 | fd <- throwErrnoIfMinus1 "mkstemps" (c_mkstemps ptr lenOfsuf) 88 | name <- peekFilePath ptr 89 | h <- fdToHandle (Fd fd) 90 | return (name, h) 91 | #else 92 | {-# WARNING mkstemps "System.Posix.Temp.mkstemps: not available on this platform" #-} 93 | mkstemps = error "System.Posix.Temp.mkstemps: not available on this platform" 94 | #endif 95 | 96 | #if HAVE_MKDTEMP 97 | foreign import capi unsafe "HsUnix.h mkdtemp" 98 | c_mkdtemp :: CString -> IO CString 99 | #endif 100 | 101 | -- | Make a unique directory. The returned 'FilePath' is the path of the 102 | -- created directory, which is padded with 6 random characters. The argument is 103 | -- the desired prefix of the filepath of the temporary directory to be created. 104 | -- 105 | -- If you are using as system that doesn't support the mkdtemp glibc function 106 | -- (supported in glibc > 2.1.91) then this function uses mktemp and so 107 | -- shouldn't be considered safe. 108 | mkdtemp :: String -> IO FilePath 109 | mkdtemp template' = do 110 | let template = template' ++ "XXXXXX" 111 | #if HAVE_MKDTEMP 112 | withFilePath template $ \ ptr -> do 113 | _ <- throwErrnoIfNull "mkdtemp" (c_mkdtemp ptr) 114 | name <- peekFilePath ptr 115 | return name 116 | #else 117 | name <- mktemp template 118 | _ <- createDirectory name (toEnum 0o700) 119 | return name 120 | #endif 121 | 122 | #if !HAVE_MKDTEMP 123 | 124 | foreign import ccall unsafe "mktemp" 125 | c_mktemp :: CString -> IO CString 126 | 127 | -- | Make a unique file name It is required that the template have six trailing 128 | -- \'X\'s. This function should be considered deprecated. 129 | {-# WARNING mktemp "This function is unsafe; use mkstemp instead" #-} 130 | mktemp :: String -> IO String 131 | mktemp template = do 132 | withFilePath template $ \ ptr -> do 133 | ptr' <- throwErrnoIfNull "mktemp" (c_mktemp ptr) 134 | peekFilePath ptr' 135 | #endif 136 | -------------------------------------------------------------------------------- /System/Posix/Directory/ByteString.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | {-# LANGUAGE NondecreasingIndentation #-} 3 | {-# LANGUAGE Safe #-} 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : System.Posix.Directory.ByteString 8 | -- Copyright : (c) The University of Glasgow 2002 9 | -- License : BSD-style (see the file libraries/base/LICENSE) 10 | -- 11 | -- Maintainer : libraries@haskell.org 12 | -- Stability : provisional 13 | -- Portability : non-portable (requires POSIX) 14 | -- 15 | -- String-based POSIX directory support 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | #include "HsUnix.h" 20 | 21 | -- hack copied from System.Posix.Files 22 | #if !defined(PATH_MAX) 23 | # define PATH_MAX 4096 24 | #endif 25 | 26 | module System.Posix.Directory.ByteString ( 27 | -- * Creating and removing directories 28 | createDirectory, removeDirectory, 29 | 30 | -- * Reading directories 31 | DirStream, 32 | openDirStream, 33 | readDirStream, 34 | readDirStreamMaybe, 35 | rewindDirStream, 36 | closeDirStream, 37 | DirStreamOffset, 38 | #ifdef HAVE_TELLDIR 39 | tellDirStream, 40 | #endif 41 | #ifdef HAVE_SEEKDIR 42 | seekDirStream, 43 | #endif 44 | 45 | -- * The working directory 46 | getWorkingDirectory, 47 | changeWorkingDirectory, 48 | changeWorkingDirectoryFd, 49 | ) where 50 | 51 | import Control.Monad ((>=>)) 52 | import Data.Maybe 53 | import System.Posix.Types 54 | import Foreign 55 | import Foreign.C 56 | 57 | import Data.ByteString.Char8 as BC 58 | 59 | import System.Posix.Directory.Common 60 | import System.Posix.ByteString.FilePath 61 | 62 | -- | @createDirectory dir mode@ calls @mkdir@ to 63 | -- create a new directory, @dir@, with permissions based on 64 | -- @mode@. 65 | createDirectory :: RawFilePath -> FileMode -> IO () 66 | createDirectory name mode = 67 | withFilePath name $ \s -> 68 | throwErrnoPathIfMinus1Retry_ "createDirectory" name (c_mkdir s mode) 69 | -- POSIX doesn't allow mkdir() to return EINTR, but it does on 70 | -- OS X (#5184), so we need the Retry variant here. 71 | 72 | foreign import ccall unsafe "mkdir" 73 | c_mkdir :: CString -> CMode -> IO CInt 74 | 75 | -- | @openDirStream dir@ calls @opendir@ to obtain a 76 | -- directory stream for @dir@. 77 | openDirStream :: RawFilePath -> IO DirStream 78 | openDirStream name = 79 | withFilePath name $ \s -> do 80 | dirp <- throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s 81 | return (DirStream dirp) 82 | 83 | foreign import capi unsafe "HsUnix.h opendir" 84 | c_opendir :: CString -> IO (Ptr CDir) 85 | 86 | -- | @readDirStream dp@ calls @readdir@ to obtain the 87 | -- next directory entry (@struct dirent@) for the open directory 88 | -- stream @dp@, and returns the @d_name@ member of that 89 | -- structure. 90 | -- 91 | -- Note that this function returns an empty filepath if the end of the 92 | -- directory stream is reached. For a safer alternative use 93 | -- 'readDirStreamMaybe'. 94 | readDirStream :: DirStream -> IO RawFilePath 95 | readDirStream = fmap (fromMaybe BC.empty) . readDirStreamMaybe 96 | 97 | -- | @readDirStreamMaybe dp@ calls @readdir@ to obtain the 98 | -- next directory entry (@struct dirent@) for the open directory 99 | -- stream @dp@. It returns the @d_name@ member of that 100 | -- structure wrapped in a @Just d_name@ if an entry was read and @Nothing@ if 101 | -- the end of the directory stream was reached. 102 | readDirStreamMaybe :: DirStream -> IO (Maybe RawFilePath) 103 | readDirStreamMaybe = readDirStreamWith (dirEntName >=> peekFilePath) 104 | 105 | 106 | -- | @getWorkingDirectory@ calls @getcwd@ to obtain the name 107 | -- of the current working directory. 108 | getWorkingDirectory :: IO RawFilePath 109 | getWorkingDirectory = go (#const PATH_MAX) 110 | where 111 | go bytes = do 112 | r <- allocaBytes bytes $ \buf -> do 113 | buf' <- c_getcwd buf (fromIntegral bytes) 114 | if buf' /= nullPtr 115 | then do s <- peekFilePath buf 116 | return (Just s) 117 | else do errno <- getErrno 118 | if errno == eRANGE 119 | -- we use Nothing to indicate that we should 120 | -- try again with a bigger buffer 121 | then return Nothing 122 | else throwErrno "getWorkingDirectory" 123 | maybe (go (2 * bytes)) return r 124 | 125 | foreign import ccall unsafe "getcwd" 126 | c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar) 127 | 128 | -- | @changeWorkingDirectory dir@ calls @chdir@ to change 129 | -- the current working directory to @dir@. 130 | changeWorkingDirectory :: RawFilePath -> IO () 131 | changeWorkingDirectory path = 132 | withFilePath path $ \s -> 133 | throwErrnoPathIfMinus1Retry_ "changeWorkingDirectory" path (c_chdir s) 134 | 135 | foreign import ccall unsafe "chdir" 136 | c_chdir :: CString -> IO CInt 137 | 138 | removeDirectory :: RawFilePath -> IO () 139 | removeDirectory path = 140 | withFilePath path $ \s -> 141 | throwErrnoPathIfMinus1Retry_ "removeDirectory" path (c_rmdir s) 142 | 143 | foreign import ccall unsafe "rmdir" 144 | c_rmdir :: CString -> IO CInt 145 | -------------------------------------------------------------------------------- /System/Posix/Process/PosixString.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : System.Posix.Process.PosixString 5 | -- Copyright : (c) The University of Glasgow 2002 6 | -- License : BSD-style (see the file libraries/base/LICENSE) 7 | -- 8 | -- Maintainer : libraries@haskell.org 9 | -- Stability : provisional 10 | -- Portability : non-portable (requires POSIX) 11 | -- 12 | -- POSIX process support. See also the System.Cmd and System.Process 13 | -- modules in the process package. 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module System.Posix.Process.PosixString ( 18 | -- * Processes 19 | 20 | -- ** Forking and executing 21 | forkProcess, 22 | forkProcessWithUnmask, 23 | executeFile, 24 | 25 | -- ** Exiting 26 | exitImmediately, 27 | 28 | -- ** Process environment 29 | getProcessID, 30 | getParentProcessID, 31 | 32 | -- ** Process groups 33 | getProcessGroupID, 34 | getProcessGroupIDOf, 35 | createProcessGroupFor, 36 | joinProcessGroup, 37 | setProcessGroupIDOf, 38 | 39 | -- ** Sessions 40 | createSession, 41 | 42 | -- ** Process times 43 | ProcessTimes(..), 44 | getProcessTimes, 45 | 46 | -- ** Scheduling priority 47 | nice, 48 | getProcessPriority, 49 | getProcessGroupPriority, 50 | getUserPriority, 51 | setProcessPriority, 52 | setProcessGroupPriority, 53 | setUserPriority, 54 | 55 | -- ** Process status 56 | ProcessStatus(..), 57 | getProcessStatus, 58 | getAnyProcessStatus, 59 | getGroupProcessStatus, 60 | 61 | -- ** Deprecated 62 | createProcessGroup, 63 | setProcessGroupID, 64 | 65 | ) where 66 | 67 | #include "HsUnix.h" 68 | 69 | import Foreign 70 | import System.Posix.Process.Internals 71 | import System.Posix.Process (ProcessTimes(..), setProcessGroupID, createProcessGroup, getGroupProcessStatus, getAnyProcessStatus, getProcessStatus, setUserPriority, setProcessGroupPriority, setProcessPriority, getUserPriority, getProcessGroupPriority, getProcessPriority, nice, getProcessTimes, createSession, setProcessGroupIDOf, joinProcessGroup, createProcessGroupFor, getProcessGroupIDOf, getProcessGroupID, getParentProcessID, getProcessID, exitImmediately, forkProcessWithUnmask, forkProcess) 72 | 73 | import Foreign.C hiding ( 74 | throwErrnoPath, 75 | throwErrnoPathIf, 76 | throwErrnoPathIf_, 77 | throwErrnoPathIfNull, 78 | throwErrnoPathIfMinus1, 79 | throwErrnoPathIfMinus1_ ) 80 | 81 | import System.OsPath.Types 82 | import System.OsString.Internal.Types (PosixString(..)) 83 | #if MIN_VERSION_filepath(1, 5, 0) 84 | import qualified "os-string" System.OsString.Data.ByteString.Short as BC 85 | #else 86 | import qualified "filepath" System.OsPath.Data.ByteString.Short as BC 87 | #endif 88 | 89 | import System.Posix.PosixPath.FilePath 90 | 91 | -- | @'executeFile' cmd args env@ calls one of the 92 | -- @execv*@ family, depending on whether or not the current 93 | -- PATH is to be searched for the command, and whether or not an 94 | -- environment is provided to supersede the process's current 95 | -- environment. The basename (leading directory names suppressed) of 96 | -- the command is passed to @execv*@ as @arg[0]@; 97 | -- the argument list passed to 'executeFile' therefore 98 | -- begins with @arg[1]@. 99 | executeFile :: PosixPath -- ^ Command 100 | -> Bool -- ^ Search PATH? 101 | -> [PosixString] -- ^ Arguments 102 | -> Maybe [(PosixString, PosixString)] -- ^ Environment 103 | -> IO a 104 | executeFile path search args Nothing = do 105 | withFilePath path $ \s -> 106 | withMany withFilePath (path:args) $ \cstrs -> 107 | withArray0 nullPtr cstrs $ \arr -> do 108 | pPrPr_disableITimers 109 | if search 110 | then throwErrnoPathIfMinus1_ "executeFile" path (c_execvp s arr) 111 | else throwErrnoPathIfMinus1_ "executeFile" path (c_execv s arr) 112 | return undefined -- never reached 113 | 114 | executeFile path search args (Just env) = do 115 | withFilePath path $ \s -> 116 | withMany withFilePath (path:args) $ \cstrs -> 117 | withArray0 nullPtr cstrs $ \arg_arr -> 118 | let env' = map (\ (PosixString name, PosixString val) -> PosixString $ name `BC.append` (_equal `BC.cons` val)) env in 119 | withMany withFilePath env' $ \cenv -> 120 | withArray0 nullPtr cenv $ \env_arr -> do 121 | pPrPr_disableITimers 122 | if search 123 | then throwErrnoPathIfMinus1_ "executeFile" path 124 | (c_execvpe s arg_arr env_arr) 125 | else throwErrnoPathIfMinus1_ "executeFile" path 126 | (c_execve s arg_arr env_arr) 127 | return undefined -- never reached 128 | 129 | foreign import ccall unsafe "execvp" 130 | c_execvp :: CString -> Ptr CString -> IO CInt 131 | 132 | foreign import ccall unsafe "execv" 133 | c_execv :: CString -> Ptr CString -> IO CInt 134 | 135 | foreign import ccall unsafe "execve" 136 | c_execve :: CString -> Ptr CString -> Ptr CString -> IO CInt 137 | 138 | _equal :: Word8 139 | _equal = 0x3d 140 | -------------------------------------------------------------------------------- /System/Posix/Directory/PosixPath.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | {-# LANGUAGE NondecreasingIndentation #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : System.Posix.Directory.PosixPath 7 | -- Copyright : (c) The University of Glasgow 2002 8 | -- License : BSD-style (see the file libraries/base/LICENSE) 9 | -- 10 | -- Maintainer : libraries@haskell.org 11 | -- Stability : provisional 12 | -- Portability : non-portable (requires POSIX) 13 | -- 14 | -- PosixPath based POSIX directory support 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | #include "HsUnix.h" 19 | 20 | -- hack copied from System.Posix.Files 21 | #if !defined(PATH_MAX) 22 | # define PATH_MAX 4096 23 | #endif 24 | 25 | module System.Posix.Directory.PosixPath ( 26 | -- * Creating and removing directories 27 | createDirectory, removeDirectory, 28 | 29 | -- * Reading directories 30 | Common.DirStream, 31 | openDirStream, 32 | readDirStream, 33 | readDirStreamMaybe, 34 | Common.rewindDirStream, 35 | Common.closeDirStream, 36 | Common.DirStreamOffset, 37 | #ifdef HAVE_TELLDIR 38 | Common.tellDirStream, 39 | #endif 40 | #ifdef HAVE_SEEKDIR 41 | Common.seekDirStream, 42 | #endif 43 | 44 | -- * The working directory 45 | getWorkingDirectory, 46 | changeWorkingDirectory, 47 | Common.changeWorkingDirectoryFd, 48 | ) where 49 | 50 | import Control.Monad ((>=>)) 51 | import Data.Maybe 52 | import System.Posix.Types 53 | import Foreign 54 | import Foreign.C 55 | 56 | import System.OsPath.Posix 57 | import qualified System.Posix.Directory.Common as Common 58 | import System.Posix.PosixPath.FilePath 59 | 60 | -- | @createDirectory dir mode@ calls @mkdir@ to 61 | -- create a new directory, @dir@, with permissions based on 62 | -- @mode@. 63 | createDirectory :: PosixPath -> FileMode -> IO () 64 | createDirectory name mode = 65 | withFilePath name $ \s -> 66 | throwErrnoPathIfMinus1Retry_ "createDirectory" name (c_mkdir s mode) 67 | -- POSIX doesn't allow mkdir() to return EINTR, but it does on 68 | -- OS X (#5184), so we need the Retry variant here. 69 | 70 | foreign import ccall unsafe "mkdir" 71 | c_mkdir :: CString -> CMode -> IO CInt 72 | 73 | -- | @openDirStream dir@ calls @opendir@ to obtain a 74 | -- directory stream for @dir@. 75 | openDirStream :: PosixPath -> IO Common.DirStream 76 | openDirStream name = 77 | withFilePath name $ \s -> do 78 | dirp <- throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s 79 | return (Common.DirStream dirp) 80 | 81 | foreign import capi unsafe "HsUnix.h opendir" 82 | c_opendir :: CString -> IO (Ptr Common.CDir) 83 | 84 | -- | @readDirStream dp@ calls @readdir@ to obtain the 85 | -- next directory entry (@struct dirent@) for the open directory 86 | -- stream @dp@, and returns the @d_name@ member of that 87 | -- structure. 88 | -- 89 | -- Note that this function returns an empty filepath if the end of the 90 | -- directory stream is reached. For a safer alternative use 91 | -- 'readDirStreamMaybe'. 92 | readDirStream :: Common.DirStream -> IO PosixPath 93 | readDirStream = fmap (fromMaybe mempty) . readDirStreamMaybe 94 | 95 | -- | @readDirStreamMaybe dp@ calls @readdir@ to obtain the 96 | -- next directory entry (@struct dirent@) for the open directory 97 | -- stream @dp@. It returns the @d_name@ member of that 98 | -- structure wrapped in a @Just d_name@ if an entry was read and @Nothing@ if 99 | -- the end of the directory stream was reached. 100 | readDirStreamMaybe :: Common.DirStream -> IO (Maybe PosixPath) 101 | readDirStreamMaybe = Common.readDirStreamWith 102 | (Common.dirEntName >=> peekFilePath) 103 | 104 | 105 | -- | @getWorkingDirectory@ calls @getcwd@ to obtain the name 106 | -- of the current working directory. 107 | getWorkingDirectory :: IO PosixPath 108 | getWorkingDirectory = go (#const PATH_MAX) 109 | where 110 | go bytes = do 111 | r <- allocaBytes bytes $ \buf -> do 112 | buf' <- c_getcwd buf (fromIntegral bytes) 113 | if buf' /= nullPtr 114 | then do s <- peekFilePath buf 115 | return (Just s) 116 | else do errno <- getErrno 117 | if errno == eRANGE 118 | -- we use Nothing to indicate that we should 119 | -- try again with a bigger buffer 120 | then return Nothing 121 | else throwErrno "getWorkingDirectory" 122 | maybe (go (2 * bytes)) return r 123 | 124 | foreign import ccall unsafe "getcwd" 125 | c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar) 126 | 127 | -- | @changeWorkingDirectory dir@ calls @chdir@ to change 128 | -- the current working directory to @dir@. 129 | changeWorkingDirectory :: PosixPath -> IO () 130 | changeWorkingDirectory path = 131 | withFilePath path $ \s -> 132 | throwErrnoPathIfMinus1Retry_ "changeWorkingDirectory" path (c_chdir s) 133 | 134 | foreign import ccall unsafe "chdir" 135 | c_chdir :: CString -> IO CInt 136 | 137 | removeDirectory :: PosixPath -> IO () 138 | removeDirectory path = 139 | withFilePath path $ \s -> 140 | throwErrnoPathIfMinus1Retry_ "removeDirectory" path (c_rmdir s) 141 | 142 | foreign import ccall unsafe "rmdir" 143 | c_rmdir :: CString -> IO CInt 144 | -------------------------------------------------------------------------------- /System/Posix/IO.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : System.Posix.IO 5 | -- Copyright : (c) The University of Glasgow 2002 6 | -- License : BSD-style (see the file libraries/base/LICENSE) 7 | -- 8 | -- Maintainer : libraries@haskell.org 9 | -- Stability : provisional 10 | -- Portability : non-portable (requires POSIX) 11 | -- 12 | -- POSIX IO support. These types and functions correspond to the unix 13 | -- functions open(2), close(2), etc. For more portable functions 14 | -- which are more like fopen(3) and friends from stdio.h, see 15 | -- "System.IO". 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | #include "HsUnix.h" 20 | 21 | module System.Posix.IO ( 22 | -- * Input \/ Output 23 | 24 | -- ** Standard file descriptors 25 | stdInput, stdOutput, stdError, 26 | 27 | -- ** Opening and closing files 28 | OpenMode(..), 29 | OpenFileFlags(..), defaultFileFlags, 30 | openFd, openFdAt, createFile, createFileAt, 31 | closeFd, 32 | 33 | -- ** Reading\/writing data 34 | -- |Programmers using the 'fdRead' and 'fdWrite' API should be aware that 35 | -- EAGAIN exceptions may occur for non-blocking IO! 36 | 37 | fdRead, fdWrite, 38 | fdReadBuf, fdWriteBuf, 39 | 40 | -- ** Seeking 41 | fdSeek, 42 | 43 | -- ** File options 44 | FdOption(..), 45 | queryFdOption, 46 | setFdOption, 47 | 48 | -- ** Locking 49 | FileLock, 50 | LockRequest(..), 51 | getLock, setLock, 52 | waitToSetLock, 53 | 54 | -- ** Pipes 55 | createPipe, 56 | 57 | -- ** Duplicating file descriptors 58 | dup, dupTo, 59 | 60 | -- ** Converting file descriptors to\/from Handles 61 | handleToFd, 62 | fdToHandle, 63 | 64 | ) where 65 | 66 | import Foreign ( allocaBytes, castPtr ) 67 | import Foreign.C ( peekCStringLen, withCStringLen ) 68 | 69 | import GHC.IO.Exception ( IOErrorType(EOF) ) 70 | 71 | import System.IO.Error ( ioeSetErrorString, mkIOError ) 72 | 73 | import System.Posix.Types 74 | import System.Posix.Error 75 | import System.Posix.IO.Common 76 | import System.Posix.Internals ( withFilePath ) 77 | 78 | -- |Open and optionally create this file. See 'System.Posix.Files' 79 | -- for information on how to use the 'FileMode' type. 80 | openFd :: FilePath 81 | -> OpenMode 82 | -> OpenFileFlags 83 | -> IO Fd 84 | openFd = openFdAt Nothing 85 | 86 | -- | Open a file relative to an optional directory file descriptor. 87 | -- 88 | -- Directory file descriptors can be used to avoid some race conditions when 89 | -- navigating changing directory trees, or to retain access to a portion of the 90 | -- directory tree that would otherwise become inaccessible after dropping 91 | -- privileges. 92 | openFdAt :: Maybe Fd -- ^ Optional directory file descriptor 93 | -> FilePath -- ^ Pathname to open 94 | -> OpenMode -- ^ Read-only, read-write or write-only 95 | -> OpenFileFlags -- ^ Append, exclusive, truncate, etc. 96 | -> IO Fd 97 | openFdAt fdMay name how flags = 98 | withFilePath name $ \str -> 99 | throwErrnoPathIfMinus1Retry "openFdAt" name $ 100 | openat_ fdMay str how flags 101 | 102 | -- |Create and open this file in WriteOnly mode. A special case of 103 | -- 'openFd'. See 'System.Posix.Files' for information on how to use 104 | -- the 'FileMode' type. 105 | createFile :: FilePath -> FileMode -> IO Fd 106 | createFile = createFileAt Nothing 107 | 108 | -- | Create and open a file for write-only, with default flags, 109 | -- relative an optional directory file-descriptor. 110 | -- 111 | -- Directory file descriptors can be used to avoid some race conditions when 112 | -- navigating changing directory trees, or to retain access to a portion of the 113 | -- directory tree that would otherwise become inaccessible after dropping 114 | -- privileges. 115 | createFileAt :: Maybe Fd -- ^ Optional directory file descriptor 116 | -> FilePath -- ^ Pathname to create 117 | -> FileMode -- ^ File permission bits (before umask) 118 | -> IO Fd 119 | createFileAt fdMay name mode 120 | = openFdAt fdMay name WriteOnly defaultFileFlags{ trunc=True, creat=(Just mode) } 121 | 122 | {-# DEPRECATED fdRead "This function is scheduled to be dropped in favor of 'System.Posix.IO.ByteString.fdRead', because decoding e.g. UTF-8 streams partially is unsafe." #-} -- deprecated in 2.8.0.0 123 | -- | Read data from an 'Fd' and convert it to a 'String' using the locale encoding. 124 | -- Throws an exception if this is an invalid descriptor, or EOF has been 125 | -- reached. 126 | fdRead :: Fd 127 | -> ByteCount -- ^How many bytes to read 128 | -> IO (String, ByteCount) -- ^The bytes read, how many bytes were read. 129 | fdRead _fd 0 = return ("", 0) 130 | fdRead fd nbytes = 131 | allocaBytes (fromIntegral nbytes) $ \ buf -> do 132 | rc <- fdReadBuf fd buf nbytes 133 | case rc of 134 | 0 -> ioError (ioeSetErrorString (mkIOError EOF "fdRead" Nothing Nothing) "EOF") 135 | n -> do 136 | s <- peekCStringLen (castPtr buf, fromIntegral n) 137 | return (s, n) 138 | 139 | -- | Write a 'String' to an 'Fd' using the locale encoding. 140 | fdWrite :: Fd -> String -> IO ByteCount 141 | fdWrite fd str = 142 | withCStringLen str $ \ (buf,len) -> 143 | fdWriteBuf fd (castPtr buf) (fromIntegral len) 144 | -------------------------------------------------------------------------------- /System/Posix/Temp/PosixString.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | {-# LANGUAGE PackageImports #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : System.Posix.Temp.PosixString 6 | -- Copyright : (c) Volker Stolz 7 | -- Deian Stefan 8 | -- License : BSD-style (see the file libraries/base/LICENSE) 9 | -- 10 | -- Maintainer : libraries@haskell.org, vs@foldr.org, deian@cs.stanford.edu 11 | -- Stability : provisional 12 | -- Portability : non-portable (requires POSIX) 13 | -- 14 | -- POSIX temporary file and directory creation functions. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module System.Posix.Temp.PosixString ( 19 | mkstemp, mkstemps, mkdtemp 20 | ) where 21 | 22 | #include "HsUnix.h" 23 | 24 | #if MIN_VERSION_filepath(1, 5, 0) 25 | import qualified "os-string" System.OsString.Data.ByteString.Short as BC 26 | #else 27 | import qualified "filepath" System.OsPath.Data.ByteString.Short as BC 28 | #endif 29 | import Data.Word 30 | 31 | import Foreign.C 32 | 33 | import System.OsPath.Types 34 | import System.IO 35 | import System.Posix.PosixPath.FilePath 36 | import System.OsString.Internal.Types (PosixString(..)) 37 | #if !HAVE_MKDTEMP 38 | import System.Posix.Directory.PosixPath (createDirectory) 39 | #endif 40 | import System.Posix.IO.PosixString 41 | import System.Posix.Types 42 | 43 | #if !defined(HAVE_MKSTEMP) 44 | import System.IO.Error ( ioeSetLocation ) 45 | import GHC.IO.Exception ( unsupportedOperation ) 46 | #endif 47 | 48 | #if !defined(HAVE_MKSTEMP) 49 | 50 | {-# WARNING mkstemp "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_MKSTEMP@)" #-} 51 | mkstemp :: PosixString -> IO (PosixPath, Handle) 52 | mkstemp _ = ioError (ioeSetLocation unsupportedOperation "mkstemp") 53 | 54 | #else 55 | 56 | foreign import capi unsafe "HsUnix.h mkstemp" 57 | c_mkstemp :: CString -> IO CInt 58 | 59 | -- | Make a unique filename and open it for reading\/writing. The returned 60 | -- 'PosixPath' is the (possibly relative) path of the created file, which is 61 | -- padded with 6 random characters. The argument is the desired prefix of the 62 | -- filepath of the temporary file to be created. 63 | -- 64 | -- If you aren't using GHC or Hugs then this function simply wraps mktemp and 65 | -- so shouldn't be considered safe. 66 | mkstemp :: PosixString -> IO (PosixPath, Handle) 67 | mkstemp (PosixString template') = do 68 | let template = PosixString $ template' `BC.append` (BC.pack [_X,_X,_X,_X,_X,_X]) 69 | withFilePath template $ \ ptr -> do 70 | fd <- throwErrnoIfMinus1 "mkstemp" (c_mkstemp ptr) 71 | name <- peekFilePath ptr 72 | h <- fdToHandle (Fd fd) 73 | return (name, h) 74 | 75 | #endif // HAVE_MKSTEMP 76 | 77 | #if HAVE_MKSTEMPS 78 | foreign import capi unsafe "HsUnix.h mkstemps" 79 | c_mkstemps :: CString -> CInt -> IO CInt 80 | #endif 81 | 82 | -- |'mkstemps' - make a unique filename with a given prefix and suffix 83 | -- and open it for reading\/writing (only safe on GHC & Hugs). 84 | -- The returned 'PosixPath' is the (possibly relative) path of 85 | -- the created file, which contains 6 random characters in between 86 | -- the prefix and suffix. 87 | mkstemps :: PosixString -> PosixString -> IO (PosixPath, Handle) 88 | #if HAVE_MKSTEMPS 89 | mkstemps (PosixString prefix) (PosixString suffix) = do 90 | let template = PosixString $ prefix `BC.append` (BC.pack [_X,_X,_X,_X,_X,_X]) `BC.append` suffix 91 | lenOfsuf = (fromIntegral $ BC.length suffix) :: CInt 92 | withFilePath template $ \ ptr -> do 93 | fd <- throwErrnoIfMinus1 "mkstemps" (c_mkstemps ptr lenOfsuf) 94 | name <- peekFilePath ptr 95 | h <- fdToHandle (Fd fd) 96 | return (name, h) 97 | #else 98 | mkstemps = error "System.Posix.Temp.mkstemps: not available on this platform" 99 | #endif 100 | 101 | #if HAVE_MKDTEMP 102 | foreign import capi unsafe "HsUnix.h mkdtemp" 103 | c_mkdtemp :: CString -> IO CString 104 | #endif 105 | 106 | -- | Make a unique directory. The returned 'PosixPath' is the path of the 107 | -- created directory, which is padded with 6 random characters. The argument is 108 | -- the desired prefix of the filepath of the temporary directory to be created. 109 | -- 110 | -- If you aren't using GHC or Hugs then this function simply wraps mktemp and 111 | -- so shouldn't be considered safe. 112 | mkdtemp :: PosixString -> IO PosixPath 113 | mkdtemp (PosixString template') = do 114 | let template = PosixString $ template' `BC.append` (BC.pack [_X,_X,_X,_X,_X,_X]) 115 | #if HAVE_MKDTEMP 116 | withFilePath template $ \ ptr -> do 117 | _ <- throwErrnoIfNull "mkdtemp" (c_mkdtemp ptr) 118 | name <- peekFilePath ptr 119 | return name 120 | #else 121 | name <- mktemp template 122 | h <- createDirectory name (toEnum 0o700) 123 | return name 124 | #endif 125 | 126 | #if !HAVE_MKDTEMP 127 | 128 | foreign import ccall unsafe "mktemp" 129 | c_mktemp :: CString -> IO CString 130 | 131 | -- | Make a unique file name It is required that the template have six trailing 132 | -- \'X\'s. This function should be considered deprecated. 133 | {-# WARNING mktemp "This function is unsafe; use mkstemp instead" #-} 134 | mktemp :: PosixString -> IO PosixPath 135 | mktemp template = do 136 | withFilePath template $ \ ptr -> do 137 | ptr <- throwErrnoIfNull "mktemp" (c_mktemp ptr) 138 | peekFilePath ptr 139 | #endif 140 | 141 | _X :: Word8 142 | _X = 0x58 143 | 144 | -------------------------------------------------------------------------------- /System/Posix/Env.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | {-# LANGUAGE Safe #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : System.Posix.Env 6 | -- Copyright : (c) The University of Glasgow 2002 7 | -- License : BSD-style (see the file libraries/base/LICENSE) 8 | -- 9 | -- Maintainer : libraries@haskell.org 10 | -- Stability : provisional 11 | -- Portability : non-portable (requires POSIX) 12 | -- 13 | -- POSIX environment support 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module System.Posix.Env ( 18 | getEnv 19 | , getEnvDefault 20 | , getEnvironmentPrim 21 | , getEnvironment 22 | , setEnvironment 23 | , putEnv 24 | , setEnv 25 | , unsetEnv 26 | , clearEnv 27 | ) where 28 | 29 | #include "HsUnix.h" 30 | 31 | import Foreign hiding (void) 32 | import Foreign.C.Error (throwErrnoIfMinus1_) 33 | import Foreign.C.Types 34 | import Foreign.C.String 35 | import Control.Monad 36 | import Data.Maybe (fromMaybe) 37 | import System.Posix.Internals 38 | 39 | import qualified System.Posix.Env.Internal as Internal 40 | 41 | -- |'getEnv' looks up a variable in the environment. 42 | 43 | getEnv :: 44 | String {- ^ variable name -} -> 45 | IO (Maybe String) {- ^ variable value -} 46 | getEnv name = do 47 | litstring <- withFilePath name c_getenv 48 | if litstring /= nullPtr 49 | then Just <$> peekFilePath litstring 50 | else return Nothing 51 | 52 | -- |'getEnvDefault' is a wrapper around 'getEnv' where the 53 | -- programmer can specify a fallback if the variable is not found 54 | -- in the environment. 55 | 56 | getEnvDefault :: 57 | String {- ^ variable name -} -> 58 | String {- ^ fallback value -} -> 59 | IO String {- ^ variable value or fallback value -} 60 | getEnvDefault name fallback = fromMaybe fallback <$> getEnv name 61 | 62 | foreign import ccall unsafe "getenv" 63 | c_getenv :: CString -> IO CString 64 | 65 | getEnvironmentPrim :: IO [String] 66 | getEnvironmentPrim = Internal.getEnvironmentPrim >>= mapM peekFilePath 67 | 68 | -- |'getEnvironment' retrieves the entire environment as a 69 | -- list of @(key,value)@ pairs. 70 | 71 | getEnvironment :: IO [(String,String)] {- ^ @[(key,value)]@ -} 72 | getEnvironment = do 73 | env <- getEnvironmentPrim 74 | return $ map (dropEq.(break ((==) '='))) env 75 | where 76 | dropEq (x,'=':ys) = (x,ys) 77 | dropEq (x,_) = error $ "getEnvironment: insane variable " ++ x 78 | 79 | -- |'setEnvironment' resets the entire environment to the given list of 80 | -- @(key,value)@ pairs. 81 | 82 | setEnvironment :: 83 | [(String,String)] {- ^ @[(key,value)]@ -} -> 84 | IO () 85 | setEnvironment env = do 86 | clearEnv 87 | forM_ env $ \(key,value) -> 88 | setEnv key value True {-overwrite-} 89 | 90 | -- |The 'unsetEnv' function deletes all instances of the variable name 91 | -- from the environment. 92 | 93 | unsetEnv :: String {- ^ variable name -} -> IO () 94 | #if HAVE_UNSETENV 95 | # if !UNSETENV_RETURNS_VOID 96 | unsetEnv name = withFilePath name $ \ s -> 97 | throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s) 98 | 99 | -- POSIX.1-2001 compliant unsetenv(3) 100 | foreign import capi unsafe "HsUnix.h unsetenv" 101 | c_unsetenv :: CString -> IO CInt 102 | # else 103 | unsetEnv name = withFilePath name c_unsetenv 104 | 105 | -- pre-POSIX unsetenv(3) returning @void@ 106 | foreign import capi unsafe "HsUnix.h unsetenv" 107 | c_unsetenv :: CString -> IO () 108 | # endif 109 | #else 110 | unsetEnv name = putEnv (name ++ "=") 111 | #endif 112 | 113 | -- |'putEnv' function takes an argument of the form @name=value@ 114 | -- and is equivalent to @setEnv(key,value,True{-overwrite-})@. 115 | 116 | putEnv :: String {- ^ "key=value" -} -> IO () 117 | putEnv keyvalue = do s <- newFilePath keyvalue 118 | -- Do not free `s` after calling putenv. 119 | -- According to SUSv2, the string passed to putenv 120 | -- becomes part of the environment. #7342 121 | throwErrnoIfMinus1_ "putenv" (c_putenv s) 122 | 123 | foreign import ccall unsafe "putenv" 124 | c_putenv :: CString -> IO CInt 125 | 126 | {- |The 'setEnv' function inserts or resets the environment variable name in 127 | the current environment list. If the variable @name@ does not exist in the 128 | list, it is inserted with the given value. If the variable does exist, 129 | the argument @overwrite@ is tested; if @overwrite@ is @False@, the variable is 130 | not reset, otherwise it is reset to the given value. 131 | -} 132 | 133 | setEnv :: 134 | String {- ^ variable name -} -> 135 | String {- ^ variable value -} -> 136 | Bool {- ^ overwrite -} -> 137 | IO () 138 | #ifdef HAVE_SETENV 139 | setEnv key value ovrwrt = do 140 | withFilePath key $ \ keyP -> 141 | withFilePath value $ \ valueP -> 142 | throwErrnoIfMinus1_ "setenv" $ 143 | c_setenv keyP valueP (fromIntegral (fromEnum ovrwrt)) 144 | 145 | foreign import ccall unsafe "setenv" 146 | c_setenv :: CString -> CString -> CInt -> IO CInt 147 | #else 148 | setEnv key value True = putEnv (key++"="++value) 149 | setEnv key value False = do 150 | res <- getEnv key 151 | case res of 152 | Just _ -> return () 153 | Nothing -> putEnv (key++"="++value) 154 | #endif 155 | 156 | -- |The 'clearEnv' function clears the environment of all name-value pairs. 157 | clearEnv :: IO () 158 | #if HAVE_CLEARENV 159 | clearEnv = void c_clearenv 160 | 161 | foreign import ccall unsafe "clearenv" 162 | c_clearenv :: IO Int 163 | #else 164 | -- Fallback to 'environ[0] = NULL'. 165 | clearEnv = do 166 | c_environ <- Internal.getCEnviron 167 | unless (c_environ == nullPtr) $ 168 | poke c_environ nullPtr 169 | #endif 170 | -------------------------------------------------------------------------------- /cbits/execvpe.c: -------------------------------------------------------------------------------- 1 | /* ----------------------------------------------------------------------------- 2 | (c) The University of Glasgow 1995-2004 3 | 4 | Our low-level exec() variant. 5 | 6 | Note: __hsunix_execvpe() is very similar to the function 7 | execvpe(3) as provided by glibc 2.11 and later. However, if 8 | execvpe(3) is available, we use that instead. 9 | 10 | -------------------------------------------------------------------------- */ 11 | 12 | #include "HsUnixConfig.h" 13 | 14 | #include 15 | #include 16 | #if HAVE_SYS_WAIT_H 17 | # include 18 | #endif 19 | #include 20 | #include 21 | #include 22 | #include 23 | #include 24 | 25 | #include "execvpe.h" 26 | 27 | #if !defined(execvpe) && !HAVE_DECL_EXECVPE 28 | // On some archs such as AIX, the prototype may be missing 29 | int execvpe(const char *file, char *const argv[], char *const envp[]); 30 | #endif 31 | 32 | /* 33 | * We want the search semantics of execvp, but we want to provide our 34 | * own environment, like execve. The following copyright applies to 35 | * this code, as it is a derivative of execvp: 36 | *- 37 | * Copyright (c) 1991 The Regents of the University of California. 38 | * All rights reserved. 39 | * 40 | * Redistribution and use in source and binary forms, with or without 41 | * modification, are permitted provided that the following conditions 42 | * are met: 43 | * 1. Redistributions of source code must retain the above copyright 44 | * notice, this list of conditions and the following disclaimer. 45 | * 2. Redistributions in binary form must reproduce the above copyright 46 | * notice, this list of conditions and the following disclaimer in the 47 | * documentation and/or other materials provided with the distribution. 48 | * 3. All advertising materials mentioning features or use of this software 49 | * must display the following acknowledgement: 50 | * This product includes software developed by the University of 51 | * California, Berkeley and its contributors. 52 | * 4. Neither the name of the University nor the names of its contributors 53 | * may be used to endorse or promote products derived from this software 54 | * without specific prior written permission. 55 | * 56 | * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 57 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 58 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 59 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 60 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 61 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 62 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 63 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 64 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 65 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 66 | * SUCH DAMAGE. 67 | */ 68 | 69 | int 70 | __hsunix_execvpe(const char *name, char *const argv[], char *const envp[]) 71 | { 72 | #if HAVE_EXECVPE 73 | return execvpe(name, argv, envp); 74 | #elif !defined(HAVE_EXECV) 75 | errno = ENOSYS; 76 | return (-1); 77 | #else 78 | register int lp, ln; 79 | register char *p; 80 | int eacces=0, etxtbsy=0; 81 | char *bp, *cur, *path, *buf = 0; 82 | 83 | /* If it's an absolute or relative path name, it's easy. */ 84 | if (strchr(name, '/')) { 85 | bp = (char *) name; 86 | cur = path = buf = NULL; 87 | goto retry; 88 | } 89 | 90 | /* Get the path we're searching. */ 91 | if (!(path = getenv("PATH"))) { 92 | # ifdef HAVE_CONFSTR 93 | ln = confstr(_CS_PATH, NULL, 0); 94 | if ((cur = path = malloc(ln + 1)) != NULL) { 95 | path[0] = ':'; 96 | (void) confstr (_CS_PATH, path + 1, ln); 97 | } 98 | # else 99 | if ((cur = path = malloc(1 + 1)) != NULL) { 100 | path[0] = ':'; 101 | path[1] = '\0'; 102 | } 103 | # endif 104 | } else 105 | cur = path = strdup(path); 106 | 107 | if (path == NULL || (bp = buf = malloc(strlen(path)+strlen(name)+2)) == NULL) 108 | goto done; 109 | 110 | while (cur != NULL) { 111 | p = cur; 112 | if ((cur = strchr(cur, ':')) != NULL) 113 | *cur++ = '\0'; 114 | 115 | /* 116 | * It's a SHELL path -- double, leading and trailing colons mean the current 117 | * directory. 118 | */ 119 | if (!*p) { 120 | p = "."; 121 | lp = 1; 122 | } else 123 | lp = strlen(p); 124 | ln = strlen(name); 125 | 126 | memcpy(buf, p, lp); 127 | buf[lp] = '/'; 128 | memcpy(buf + lp + 1, name, ln); 129 | buf[lp + ln + 1] = '\0'; 130 | 131 | retry: 132 | (void) execve(bp, argv, envp); 133 | switch (errno) { 134 | case EACCES: 135 | eacces = 1; 136 | break; 137 | case ENOTDIR: 138 | case ENOENT: 139 | break; 140 | case ENOEXEC: 141 | { 142 | register size_t cnt; 143 | register char **ap; 144 | 145 | for (cnt = 0, ap = (char **) argv; *ap; ++ap, ++cnt) 146 | ; 147 | if ((ap = malloc((cnt + 2) * sizeof(char *))) != NULL) { 148 | memcpy(ap + 2, argv + 1, cnt * sizeof(char *)); 149 | 150 | ap[0] = "sh"; 151 | ap[1] = bp; 152 | (void) execve("/bin/sh", ap, envp); 153 | free(ap); 154 | } 155 | goto done; 156 | } 157 | case ETXTBSY: 158 | if (etxtbsy < 3) 159 | (void) sleep(++etxtbsy); 160 | goto retry; 161 | default: 162 | goto done; 163 | } 164 | } 165 | if (eacces) 166 | errno = EACCES; 167 | else if (!errno) 168 | errno = ENOENT; 169 | done: 170 | if (path) 171 | free(path); 172 | if (buf) 173 | free(buf); 174 | return (-1); 175 | #endif 176 | } 177 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: ci 2 | on: 3 | push: 4 | pull_request: 5 | schedule: 6 | - cron: 0 0 * * * 7 | 8 | defaults: 9 | run: 10 | shell: bash 11 | 12 | jobs: 13 | build: 14 | runs-on: ${{ matrix.os }} 15 | strategy: 16 | fail-fast: true 17 | matrix: 18 | os: [ubuntu-24.04, macOS-latest] 19 | ghc: ['9.12', '9.10', '9.8', '9.6', '9.4', '9.2', '9.0', '8.10', '8.8', '8.6'] 20 | exclude: 21 | - os: macos-latest 22 | ghc: '9.0' 23 | - os: macos-latest 24 | ghc: '8.10' 25 | - os: macos-latest 26 | ghc: '8.8' 27 | - os: macos-latest 28 | ghc: '8.6' 29 | steps: 30 | - uses: actions/checkout@v4 31 | 32 | - name: Install GHCup 33 | uses: haskell/ghcup-setup@v1 34 | with: 35 | ghc: ${{ matrix.ghc }} 36 | cabal: latest 37 | 38 | - if: runner.os == 'macOS' 39 | name: Install system deps via brew 40 | run: brew install coreutils autoconf automake 41 | 42 | - uses: actions/cache@v4 43 | name: Cache cabal stuff 44 | with: 45 | path: | 46 | ~/.cabal/store 47 | dist-newstyle 48 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ github.sha }} 49 | restore-keys: ${{ runner.os }}-${{ matrix.ghc }}- 50 | - name: Build 51 | run: | 52 | ghc --version 53 | cabal --version 54 | cabal update 55 | autoreconf --version 56 | autoreconf -i 57 | cabal sdist -z -o . 58 | cabal get unix-*.tar.gz 59 | cd unix-*/ 60 | cabal test -f+non-portable-tests all --test-show-details=direct 61 | - name: Haddock 62 | run: | 63 | cabal haddock --disable-documentation 64 | 65 | redhat-ubi9: 66 | runs-on: ubuntu-24.04 67 | container: 68 | image: redhat/ubi9:latest 69 | steps: 70 | - name: Install prerequisites 71 | run: | 72 | yum install -y gcc gmp gmp-devel make ncurses xz perl autoconf 73 | 74 | - name: Install GHCup 75 | uses: haskell/ghcup-setup@v1 76 | with: 77 | ghc: latest 78 | cabal: latest 79 | 80 | - uses: actions/checkout@v4 81 | 82 | - name: Test 83 | run: | 84 | cabal --version 85 | cabal update 86 | autoreconf --version 87 | autoreconf -i 88 | cabal test -f+non-portable-tests all --test-show-details=direct 89 | 90 | fedora37: 91 | runs-on: ubuntu-latest 92 | container: 93 | image: fedora:37 94 | steps: 95 | - name: Install prerequisites 96 | run: | 97 | dnf install -y gcc gmp gmp-devel make ncurses ncurses-compat-libs xz perl autoconf 98 | 99 | - name: Install GHCup 100 | uses: haskell/ghcup-setup@v1 101 | with: 102 | ghc: latest 103 | cabal: latest 104 | 105 | - uses: actions/checkout@v4 106 | - name: Test 107 | run: | 108 | cabal --version 109 | cabal update 110 | autoreconf --version 111 | autoreconf -i 112 | # test filepath >= 1.5 113 | cabal test -f+non-portable-tests --constraint='filepath >= 1.5.0.0' all --test-show-details=direct 114 | 115 | i386: 116 | runs-on: ubuntu-latest 117 | steps: 118 | - name: Checkout code 119 | uses: actions/checkout@v4 120 | 121 | - name: Run build (32 bit linux) 122 | uses: docker://hasufell/i386-alpine-haskell:3.12 123 | with: 124 | args: sh -c "apk update && apk add --no-cache autoconf automake make && cabal update && autoreconf --version && autoreconf -i && cabal v2-test --constraint 'optparse-applicative -process' --constraint 'QuickCheck +old-random' --constraint 'tasty -unix' all" 125 | 126 | arm: 127 | runs-on: [self-hosted, Linux, ARM64] 128 | strategy: 129 | fail-fast: false 130 | matrix: 131 | arch: [arm32v7, arm64v8] 132 | steps: 133 | - uses: docker://hasufell/arm64v8-ubuntu-haskell:focal 134 | name: Cleanup 135 | with: 136 | args: "find . -mindepth 1 -maxdepth 1 -exec rm -rf -- {} +" 137 | 138 | - name: Checkout code 139 | uses: actions/checkout@v4 140 | 141 | - if: matrix.arch == 'arm32v7' 142 | uses: docker://hasufell/arm32v7-ubuntu-haskell:focal 143 | name: Run build (arm32v7 linux) 144 | with: 145 | args: sh -c "cabal update && autoreconf -i && cabal test all --test-show-details=direct" 146 | 147 | - if: matrix.arch == 'arm64v8' 148 | uses: docker://hasufell/arm64v8-ubuntu-haskell:focal 149 | name: Run build (arm64v8 linux) 150 | with: 151 | args: sh -c "cabal update && autoreconf -i && cabal test all --test-show-details=direct" 152 | 153 | freebsd: 154 | runs-on: ${{ matrix.os }} 155 | strategy: 156 | fail-fast: false 157 | matrix: 158 | include: 159 | - os: [self-hosted, FreeBSD, X64] 160 | ghc: 9.4 161 | - os: [self-hosted, FreeBSD, X64] 162 | ghc: 9.6 163 | steps: 164 | - name: Checkout code 165 | uses: actions/checkout@v4 166 | 167 | - name: Install prerequisites 168 | run: | 169 | sudo pkg install -y curl gcc gmp gmake ncurses perl5 libffi libiconv git bash misc/compat10x misc/compat11x misc/compat12x gmake autoconf 170 | 171 | - name: Install GHCup 172 | uses: haskell/ghcup-setup@v1 173 | with: 174 | ghc: ${{ matrix.ghc }} 175 | cabal: latest 176 | 177 | - name: Run build 178 | run: | 179 | autoreconf --version 180 | autoreconf -i 181 | cabal update 182 | cabal sdist -z -o . 183 | cabal get unix-*.tar.gz 184 | cd unix-*/ 185 | cabal test -f+non-portable-tests all --test-show-details=direct 186 | 187 | -------------------------------------------------------------------------------- /System/Posix/PosixPath/FilePath.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE PackageImports #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : System.Posix.PosixPath.FilePath 9 | -- Copyright : (c) The University of Glasgow 2002 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : libraries@haskell.org 13 | -- Stability : provisional 14 | -- Portability : non-portable (requires POSIX) 15 | -- 16 | -- Internal stuff: support for ByteString FilePaths 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module System.Posix.PosixPath.FilePath ( 21 | withFilePath, peekFilePath, peekFilePathLen, 22 | throwErrnoPathIfMinus1Retry, 23 | throwErrnoPathIfMinus1Retry_, 24 | throwErrnoPathIfNullRetry, 25 | throwErrnoPathIfRetry, 26 | throwErrnoPath, 27 | throwErrnoPathIf, 28 | throwErrnoPathIf_, 29 | throwErrnoPathIfNull, 30 | throwErrnoPathIfMinus1, 31 | throwErrnoPathIfMinus1_, 32 | throwErrnoTwoPathsIfMinus1_ 33 | ) where 34 | 35 | import Foreign hiding ( void ) 36 | import Foreign.C hiding ( 37 | throwErrnoPath, 38 | throwErrnoPathIf, 39 | throwErrnoPathIf_, 40 | throwErrnoPathIfNull, 41 | throwErrnoPathIfMinus1, 42 | throwErrnoPathIfMinus1_ ) 43 | 44 | import System.OsPath.Types 45 | import Data.ByteString.Internal (c_strlen) 46 | import Control.Monad 47 | import Control.Exception 48 | import System.OsPath.Posix as PS 49 | #if MIN_VERSION_filepath(1, 5, 0) 50 | import "os-string" System.OsString.Data.ByteString.Short as BSS 51 | #else 52 | import "filepath" System.OsPath.Data.ByteString.Short as BSS 53 | #endif 54 | import Prelude hiding (FilePath) 55 | import System.OsString.Internal.Types (PosixString(..), pattern PS) 56 | import GHC.IO.Exception 57 | 58 | #if !MIN_VERSION_base(4, 11, 0) 59 | import Data.Monoid ((<>)) 60 | #endif 61 | 62 | 63 | withFilePath :: PosixPath -> (CString -> IO a) -> IO a 64 | withFilePath path = useAsCStringSafe path 65 | 66 | peekFilePath :: CString -> IO PosixPath 67 | peekFilePath = fmap PosixString . packCString 68 | 69 | peekFilePathLen :: CStringLen -> IO PosixPath 70 | peekFilePathLen = fmap PosixString . packCStringLen 71 | 72 | 73 | throwErrnoPathIfMinus1Retry :: (Eq a, Num a) 74 | => String -> PosixPath -> IO a -> IO a 75 | throwErrnoPathIfMinus1Retry loc path f = do 76 | throwErrnoPathIfRetry (== -1) loc path f 77 | 78 | throwErrnoPathIfMinus1Retry_ :: (Eq a, Num a) 79 | => String -> PosixPath -> IO a -> IO () 80 | throwErrnoPathIfMinus1Retry_ loc path f = 81 | void $ throwErrnoPathIfRetry (== -1) loc path f 82 | 83 | throwErrnoPathIfNullRetry :: String -> PosixPath -> IO (Ptr a) -> IO (Ptr a) 84 | throwErrnoPathIfNullRetry loc path f = 85 | throwErrnoPathIfRetry (== nullPtr) loc path f 86 | 87 | throwErrnoPathIfRetry :: (a -> Bool) -> String -> PosixPath -> IO a -> IO a 88 | throwErrnoPathIfRetry pr loc rpath f = 89 | do 90 | res <- f 91 | if pr res 92 | then do 93 | err <- getErrno 94 | if err == eINTR 95 | then throwErrnoPathIfRetry pr loc rpath f 96 | else throwErrnoPath loc rpath 97 | else return res 98 | 99 | -- | as 'throwErrno', but exceptions include the given path when appropriate. 100 | -- 101 | throwErrnoPath :: String -> PosixPath -> IO a 102 | throwErrnoPath loc path = 103 | do 104 | errno <- getErrno 105 | path' <- either (const (_toStr path)) id <$> try @IOException (PS.decodeFS path) 106 | ioError (errnoToIOError loc errno Nothing (Just path')) 107 | 108 | -- | as 'throwErrnoIf', but exceptions include the given path when 109 | -- appropriate. 110 | -- 111 | throwErrnoPathIf :: (a -> Bool) -> String -> PosixPath -> IO a -> IO a 112 | throwErrnoPathIf cond loc path f = 113 | do 114 | res <- f 115 | if cond res then throwErrnoPath loc path else return res 116 | 117 | -- | as 'throwErrnoIf_', but exceptions include the given path when 118 | -- appropriate. 119 | -- 120 | throwErrnoPathIf_ :: (a -> Bool) -> String -> PosixPath -> IO a -> IO () 121 | throwErrnoPathIf_ cond loc path f = void $ throwErrnoPathIf cond loc path f 122 | 123 | -- | as 'throwErrnoIfNull', but exceptions include the given path when 124 | -- appropriate. 125 | -- 126 | throwErrnoPathIfNull :: String -> PosixPath -> IO (Ptr a) -> IO (Ptr a) 127 | throwErrnoPathIfNull = throwErrnoPathIf (== nullPtr) 128 | 129 | -- | as 'throwErrnoIfMinus1', but exceptions include the given path when 130 | -- appropriate. 131 | -- 132 | throwErrnoPathIfMinus1 :: (Eq a, Num a) => String -> PosixPath -> IO a -> IO a 133 | throwErrnoPathIfMinus1 = throwErrnoPathIf (== -1) 134 | 135 | -- | as 'throwErrnoIfMinus1_', but exceptions include the given path when 136 | -- appropriate. 137 | -- 138 | throwErrnoPathIfMinus1_ :: (Eq a, Num a) => String -> PosixPath -> IO a -> IO () 139 | throwErrnoPathIfMinus1_ = throwErrnoPathIf_ (== -1) 140 | 141 | -- | as 'throwErrnoTwoPathsIfMinus1_', but exceptions include two paths when appropriate. 142 | -- 143 | throwErrnoTwoPathsIfMinus1_ :: (Eq a, Num a) => String -> PosixPath -> PosixPath -> IO a -> IO () 144 | throwErrnoTwoPathsIfMinus1_ loc path1 path2 action = do 145 | path1' <- either (const (_toStr path1)) id <$> try @IOException (PS.decodeFS path1) 146 | path2' <- either (const (_toStr path2)) id <$> try @IOException (PS.decodeFS path2) 147 | throwErrnoIfMinus1_ (loc <> " '" <> path1' <> "' to '" <> path2' <> "'") action 148 | 149 | _toStr :: PosixPath -> String 150 | _toStr = fmap PS.toChar . PS.unpack 151 | 152 | -- | Wrapper around 'useAsCString', checking the encoded 'FilePath' for internal NUL octets as these are 153 | -- disallowed in POSIX filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660 154 | useAsCStringSafe :: PosixPath -> (CString -> IO a) -> IO a 155 | useAsCStringSafe pp@(PS path) f = useAsCString path $ \ptr -> do 156 | let len = BSS.length path 157 | clen <- c_strlen ptr 158 | if clen == fromIntegral len 159 | then f ptr 160 | else do 161 | path' <- either (const (_toStr pp)) id <$> try @IOException (PS.decodeFS pp) 162 | ioError (err path') 163 | where 164 | err path' = 165 | IOError 166 | { ioe_handle = Nothing 167 | , ioe_type = InvalidArgument 168 | , ioe_location = "checkForInteriorNuls" 169 | , ioe_description = "POSIX filepaths must not contain internal NUL octets." 170 | , ioe_errno = Nothing 171 | , ioe_filename = Just path' 172 | } 173 | -------------------------------------------------------------------------------- /System/Posix/Terminal.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | {-# LANGUAGE Safe #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : System.Posix.Terminal 6 | -- Copyright : (c) The University of Glasgow 2002 7 | -- License : BSD-style (see the file libraries/base/LICENSE) 8 | -- 9 | -- Maintainer : libraries@haskell.org 10 | -- Stability : provisional 11 | -- Portability : non-portable (requires POSIX) 12 | -- 13 | -- POSIX Terminal support 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module System.Posix.Terminal ( 18 | -- * Terminal support 19 | 20 | -- ** Terminal attributes 21 | TerminalAttributes, 22 | getTerminalAttributes, 23 | TerminalState(..), 24 | setTerminalAttributes, 25 | 26 | TerminalMode(..), 27 | withoutMode, 28 | withMode, 29 | terminalMode, 30 | bitsPerByte, 31 | withBits, 32 | 33 | ControlCharacter(..), 34 | controlChar, 35 | withCC, 36 | withoutCC, 37 | 38 | inputTime, 39 | withTime, 40 | minInput, 41 | withMinInput, 42 | 43 | BaudRate(..), 44 | inputSpeed, 45 | withInputSpeed, 46 | outputSpeed, 47 | withOutputSpeed, 48 | 49 | -- ** Terminal operations 50 | sendBreak, 51 | drainOutput, 52 | QueueSelector(..), 53 | discardData, 54 | FlowAction(..), 55 | controlFlow, 56 | 57 | -- ** Process groups 58 | getTerminalProcessGroupID, 59 | setTerminalProcessGroupID, 60 | 61 | -- ** Testing a file descriptor 62 | queryTerminal, 63 | getTerminalName, 64 | getControllingTerminalName, 65 | 66 | -- ** Pseudoterminal operations 67 | openPseudoTerminal, 68 | getSlaveTerminalName 69 | ) where 70 | 71 | #include "HsUnix.h" 72 | 73 | import Foreign 74 | import Foreign.C 75 | import System.Posix.Terminal.Common 76 | import System.Posix.Types 77 | #ifndef HAVE_OPENPTY 78 | import System.Posix.IO 79 | #endif 80 | 81 | import System.Posix.Internals (peekFilePath) 82 | 83 | #if !(HAVE_CTERMID && defined(HAVE_TERMIOS_H)) 84 | import System.IO.Error ( ioeSetLocation ) 85 | import GHC.IO.Exception ( unsupportedOperation ) 86 | #endif 87 | 88 | -- | @getTerminalName fd@ calls @ttyname@ to obtain a name associated 89 | -- with the terminal for @Fd@ @fd@. If @fd@ is associated 90 | -- with a terminal, @getTerminalName@ returns the name of the 91 | -- terminal. 92 | getTerminalName :: Fd -> IO FilePath 93 | getTerminalName (Fd fd) = do 94 | s <- throwErrnoIfNull "getTerminalName" (c_ttyname fd) 95 | peekFilePath s 96 | 97 | foreign import ccall unsafe "ttyname" 98 | c_ttyname :: CInt -> IO CString 99 | 100 | -- | @getControllingTerminalName@ calls @ctermid@ to obtain 101 | -- a name associated with the controlling terminal for the process. If a 102 | -- controlling terminal exists, 103 | -- @getControllingTerminalName@ returns the name of the 104 | -- controlling terminal. 105 | -- 106 | -- Throws 'IOError' (\"unsupported operation\") if platform does not 107 | -- provide @ctermid(3)@ (use @#if HAVE_CTERMID@ CPP guard to 108 | -- detect availability). 109 | getControllingTerminalName :: IO FilePath 110 | #if HAVE_CTERMID && defined(HAVE_TERMIOS_H) 111 | getControllingTerminalName = do 112 | s <- throwErrnoIfNull "getControllingTerminalName" (c_ctermid nullPtr) 113 | peekFilePath s 114 | 115 | foreign import capi unsafe "termios.h ctermid" 116 | c_ctermid :: CString -> IO CString 117 | #else 118 | {-# WARNING getControllingTerminalName 119 | "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_CTERMID@)" #-} 120 | getControllingTerminalName = ioError (ioeSetLocation unsupportedOperation "getControllingTerminalName") 121 | #endif 122 | 123 | -- | @getSlaveTerminalName@ calls @ptsname@ to obtain the name of the 124 | -- slave terminal associated with a pseudoterminal pair. The file 125 | -- descriptor to pass in must be that of the master. 126 | getSlaveTerminalName :: Fd -> IO FilePath 127 | 128 | #ifdef HAVE_PTSNAME 129 | getSlaveTerminalName (Fd fd) = do 130 | s <- throwErrnoIfNull "getSlaveTerminalName" (c_ptsname fd) 131 | peekFilePath s 132 | 133 | foreign import capi unsafe "HsUnix.h ptsname" 134 | c_ptsname :: CInt -> IO CString 135 | #else 136 | getSlaveTerminalName _ = 137 | ioError (errnoToIOError "getSlaveTerminalName" eNOSYS Nothing Nothing) 138 | {-# WARNING getSlaveTerminalName "getSlaveTerminalName: not available on this platform" #-} 139 | #endif 140 | 141 | -- ----------------------------------------------------------------------------- 142 | -- openPseudoTerminal needs to be here because it depends on 143 | -- getSlaveTerminalName. 144 | 145 | -- | @openPseudoTerminal@ creates a pseudoterminal (pty) pair, and 146 | -- returns the newly created pair as a (@master@, @slave@) tuple. 147 | openPseudoTerminal :: IO (Fd, Fd) 148 | 149 | #ifdef HAVE_OPENPTY 150 | openPseudoTerminal = 151 | alloca $ \p_master -> 152 | alloca $ \p_slave -> do 153 | throwErrnoIfMinus1_ "openPty" 154 | (c_openpty p_master p_slave nullPtr nullPtr nullPtr) 155 | master <- peek p_master 156 | slave <- peek p_slave 157 | return (Fd master, Fd slave) 158 | 159 | foreign import ccall unsafe "openpty" 160 | c_openpty :: Ptr CInt -> Ptr CInt -> CString -> Ptr CTermios -> Ptr a 161 | -> IO CInt 162 | #else 163 | openPseudoTerminal = do 164 | (Fd master) <- openFd "/dev/ptmx" ReadWrite 165 | defaultFileFlags{noctty=True} 166 | throwErrnoIfMinus1_ "openPseudoTerminal" (c_grantpt master) 167 | throwErrnoIfMinus1_ "openPseudoTerminal" (c_unlockpt master) 168 | slaveName <- getSlaveTerminalName (Fd master) 169 | slave <- openFd slaveName ReadWrite defaultFileFlags{noctty=True} 170 | pushModule slave "ptem" 171 | pushModule slave "ldterm" 172 | # ifndef __hpux 173 | pushModule slave "ttcompat" 174 | # endif /* __hpux */ 175 | return (Fd master, slave) 176 | 177 | # ifndef HAVE_PTSNAME 178 | {-# WARNING openPseudoTerminal "openPseudoTerminal: not available on this platform (neither OPENPTY nor PTSNAME available)" #-} 179 | # endif /* HAVE_PTSNAME */ 180 | 181 | -- Push a STREAMS module, for System V systems. 182 | pushModule :: Fd -> String -> IO () 183 | pushModule (Fd fd) name = 184 | withCString name $ \p_name -> 185 | throwErrnoIfMinus1_ "openPseudoTerminal" 186 | (c_push_module fd p_name) 187 | 188 | foreign import ccall unsafe "__hsunix_push_module" 189 | c_push_module :: CInt -> CString -> IO CInt 190 | 191 | #ifdef HAVE_PTSNAME 192 | foreign import capi unsafe "HsUnix.h grantpt" 193 | c_grantpt :: CInt -> IO CInt 194 | 195 | foreign import capi unsafe "HsUnix.h unlockpt" 196 | c_unlockpt :: CInt -> IO CInt 197 | #else 198 | c_grantpt :: CInt -> IO CInt 199 | c_grantpt _ = pure 0 200 | 201 | c_unlockpt :: CInt -> IO CInt 202 | c_unlockpt _ = pure 0 203 | #endif /* HAVE_PTSNAME */ 204 | #endif /* !HAVE_OPENPTY */ 205 | -------------------------------------------------------------------------------- /System/Posix/Fcntl.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | {-# LANGUAGE Safe #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : System.Posix.Fcntl 6 | -- Copyright : (c) The University of Glasgow 2014 7 | -- License : BSD-style (see the file LICENSE) 8 | -- 9 | -- Maintainer : libraries@haskell.org 10 | -- Stability : provisional 11 | -- Portability : non-portable (requires POSIX) 12 | -- 13 | -- POSIX file control support 14 | -- 15 | -- @since 2.7.1.0 16 | ----------------------------------------------------------------------------- 17 | 18 | #include "HsUnix.h" 19 | #include 20 | 21 | module System.Posix.Fcntl ( 22 | -- * File allocation 23 | Advice(..), fileAdvise, 24 | fileAllocate, 25 | -- * File caching 26 | fileGetCaching, 27 | fileSetCaching, 28 | ) where 29 | 30 | import Foreign.C 31 | import System.Posix.Types 32 | 33 | #if !HAVE_POSIX_FALLOCATE || !HAVE_O_DIRECT 34 | import System.IO.Error ( ioeSetLocation ) 35 | import GHC.IO.Exception ( unsupportedOperation ) 36 | #endif 37 | 38 | #if HAVE_O_DIRECT 39 | import Data.Bits (complement, (.&.), (.|.)) 40 | import System.Posix.Internals (c_fcntl_read) 41 | #endif 42 | 43 | #if HAVE_O_DIRECT || HAVE_F_NOCACHE 44 | import System.Posix.Internals (c_fcntl_write) 45 | #endif 46 | 47 | -- ----------------------------------------------------------------------------- 48 | -- File control 49 | 50 | -- | Advice parameter for 'fileAdvise' operation. 51 | -- 52 | -- For more details, see documentation of @posix_fadvise(2)@. 53 | -- 54 | -- @since 2.7.1.0 55 | data Advice 56 | = AdviceNormal 57 | | AdviceRandom 58 | | AdviceSequential 59 | | AdviceWillNeed 60 | | AdviceDontNeed 61 | | AdviceNoReuse 62 | deriving Eq 63 | 64 | -- | Performs @posix_fadvise(2)@ operation on file-descriptor. 65 | -- 66 | -- If platform does not provide @posix_fadvise(2)@ 'fileAdvise' 67 | -- becomes a no-op. 68 | -- 69 | -- (use @#if HAVE_POSIX_FADVISE@ CPP guard to detect availability) 70 | -- 71 | -- @since 2.7.1.0 72 | fileAdvise :: Fd -> FileOffset -> FileOffset -> Advice -> IO () 73 | #if HAVE_POSIX_FADVISE 74 | fileAdvise fd off len adv = do 75 | throwErrnoIfMinus1_ "fileAdvise" (c_posix_fadvise (fromIntegral fd) (fromIntegral off) (fromIntegral len) (packAdvice adv)) 76 | 77 | foreign import capi safe "fcntl.h posix_fadvise" 78 | c_posix_fadvise :: CInt -> COff -> COff -> CInt -> IO CInt 79 | 80 | packAdvice :: Advice -> CInt 81 | packAdvice AdviceNormal = (#const POSIX_FADV_NORMAL) 82 | packAdvice AdviceRandom = (#const POSIX_FADV_RANDOM) 83 | packAdvice AdviceSequential = (#const POSIX_FADV_SEQUENTIAL) 84 | packAdvice AdviceWillNeed = (#const POSIX_FADV_WILLNEED) 85 | packAdvice AdviceDontNeed = (#const POSIX_FADV_DONTNEED) 86 | packAdvice AdviceNoReuse = (#const POSIX_FADV_NOREUSE) 87 | #else 88 | fileAdvise _ _ _ _ = return () 89 | #endif 90 | 91 | -- | Performs @posix_fallocate(2)@ operation on file-descriptor. 92 | -- 93 | -- Throws 'IOError' (\"unsupported operation\") if platform does not 94 | -- provide @posix_fallocate(2)@. 95 | -- 96 | -- (use @#if HAVE_POSIX_FALLOCATE@ CPP guard to detect availability). 97 | -- 98 | -- @since 2.7.1.0 99 | fileAllocate :: Fd -> FileOffset -> FileOffset -> IO () 100 | #if HAVE_POSIX_FALLOCATE 101 | fileAllocate fd off len = do 102 | ret <- c_posix_fallocate (fromIntegral fd) (fromIntegral off) (fromIntegral len) 103 | if ret == 0 104 | then pure () 105 | else ioError (errnoToIOError "fileAllocate" (Errno ret) Nothing Nothing) 106 | 107 | foreign import capi safe "fcntl.h posix_fallocate" 108 | c_posix_fallocate :: CInt -> COff -> COff -> IO CInt 109 | #else 110 | {-# WARNING fileAllocate 111 | "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_POSIX_FALLOCATE@)" #-} 112 | fileAllocate _ _ _ = ioError (ioeSetLocation unsupportedOperation 113 | "fileAllocate") 114 | #endif 115 | 116 | -- ----------------------------------------------------------------------------- 117 | -- File caching 118 | 119 | -- | Performs the @fcntl(2)@ operation on a file-desciptor to get the cache mode. 120 | -- 121 | -- If the cache mode is 'False', then cache effects for file system reads and 122 | -- writes are minimised or otherwise eliminated. If the cache mode is 'True', 123 | -- then cache effects occur like normal. 124 | -- 125 | -- On Linux, FreeBSD, and NetBSD this checks whether the @O_DIRECT@ file flag is 126 | -- set. 127 | -- 128 | -- Throws 'IOError' (\"unsupported operation\") if platform does not support 129 | -- getting the cache mode. 130 | -- 131 | -- Use @#if HAVE_O_DIRECT@ CPP guard to detect availability. Use @#include 132 | -- "HsUnix.h"@ to bring @HAVE_O_DIRECT@ into scope. 133 | -- 134 | -- @since 2.8.7.0 135 | fileGetCaching :: Fd -> IO Bool 136 | #if HAVE_O_DIRECT 137 | fileGetCaching (Fd fd) = do 138 | r <- throwErrnoIfMinus1 "fileGetCaching" (c_fcntl_read fd #{const F_GETFL}) 139 | return ((r .&. opt_val) == 0) 140 | where 141 | opt_val = #{const O_DIRECT} 142 | #else 143 | {-# WARNING fileGetCaching 144 | "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_O_DIRECT@)" #-} 145 | fileGetCaching _ = ioError (ioeSetLocation unsupportedOperation "fileGetCaching") 146 | #endif 147 | 148 | -- | Performs the @fcntl(2)@ operation on a file-desciptor to set the cache 149 | -- mode. 150 | -- 151 | -- If the cache mode is 'False', then cache effects for file system reads and 152 | -- writes are minimised or otherwise eliminated. If the cache mode is 'True', 153 | -- then cache effects occur like normal. 154 | -- 155 | -- On Linux, FreeBSD, and NetBSD this sets the @O_DIRECT@ file flag. On OSX, 156 | -- this sets the @F_NOCACHE@ @fcntl@ flag. 157 | -- 158 | -- Throws 'IOError' (\"unsupported operation\") if platform does not support 159 | -- setting the cache mode. 160 | -- 161 | -- Use @#if HAVE_O_DIRECT || HAVE_F_NOCACHE@ CPP guard to detect availability. 162 | -- Use @#include "HsUnix.h"@ to bring @HAVE_O_DIRECT@ and @HAVE_F_NOCACHE@ into 163 | -- scope. 164 | -- 165 | -- @since 2.8.7.0 166 | fileSetCaching :: Fd -> Bool -> IO () 167 | #if HAVE_O_DIRECT 168 | fileSetCaching (Fd fd) val = do 169 | r <- throwErrnoIfMinus1 "fileSetCaching" (c_fcntl_read fd #{const F_GETFL}) 170 | let r' | val = fromIntegral r .&. complement opt_val 171 | | otherwise = fromIntegral r .|. opt_val 172 | throwErrnoIfMinus1_ "fileSetCaching" (c_fcntl_write fd #{const F_SETFL} r') 173 | where 174 | opt_val = #{const O_DIRECT} 175 | #elif HAVE_F_NOCACHE 176 | fileSetCaching (Fd fd) val = do 177 | throwErrnoIfMinus1_ "fileSetCaching" (c_fcntl_write fd #{const F_NOCACHE} (if val then 0 else 1)) 178 | #else 179 | {-# WARNING fileSetCaching 180 | "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_O_DIRECT || HAVE_F_NOCACHE @)" #-} 181 | fileSetCaching _ _ = ioError (ioeSetLocation unsupportedOperation "fileSetCaching") 182 | #endif 183 | -------------------------------------------------------------------------------- /System/Posix/ByteString/FilePath.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : System.Posix.ByteString.FilePath 7 | -- Copyright : (c) The University of Glasgow 2002 8 | -- License : BSD-style (see the file libraries/base/LICENSE) 9 | -- 10 | -- Maintainer : libraries@haskell.org 11 | -- Stability : provisional 12 | -- Portability : non-portable (requires POSIX) 13 | -- 14 | -- Internal stuff: support for ByteString FilePaths 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module System.Posix.ByteString.FilePath ( 19 | RawFilePath, withFilePath, peekFilePath, peekFilePathLen, 20 | throwErrnoPathIfMinus1Retry, 21 | throwErrnoPathIfMinus1Retry_, 22 | throwErrnoPathIfNullRetry, 23 | throwErrnoPathIfRetry, 24 | throwErrnoPath, 25 | throwErrnoPathIf, 26 | throwErrnoPathIf_, 27 | throwErrnoPathIfNull, 28 | throwErrnoPathIfMinus1, 29 | throwErrnoPathIfMinus1_, 30 | throwErrnoTwoPathsIfMinus1_ 31 | ) where 32 | 33 | import Foreign hiding ( void ) 34 | import Foreign.C hiding ( 35 | throwErrnoPath, 36 | throwErrnoPathIf, 37 | throwErrnoPathIf_, 38 | throwErrnoPathIfNull, 39 | throwErrnoPathIfMinus1, 40 | throwErrnoPathIfMinus1_ ) 41 | 42 | import Control.Monad 43 | import Control.Exception 44 | import Data.ByteString.Internal (c_strlen) 45 | import GHC.Foreign as GHC ( peekCStringLen ) 46 | import GHC.IO.Encoding ( getFileSystemEncoding ) 47 | import GHC.IO.Exception 48 | import Data.ByteString as B 49 | import Data.ByteString.Char8 as BC 50 | import Prelude hiding (FilePath) 51 | #if !MIN_VERSION_base(4, 11, 0) 52 | import Data.Monoid ((<>)) 53 | #endif 54 | 55 | -- | A literal POSIX file path 56 | type RawFilePath = ByteString 57 | 58 | withFilePath :: RawFilePath -> (CString -> IO a) -> IO a 59 | withFilePath path = useAsCStringSafe path 60 | 61 | peekFilePath :: CString -> IO RawFilePath 62 | peekFilePath = packCString 63 | 64 | peekFilePathLen :: CStringLen -> IO RawFilePath 65 | peekFilePathLen = packCStringLen 66 | 67 | 68 | throwErrnoPathIfMinus1Retry :: (Eq a, Num a) 69 | => String -> RawFilePath -> IO a -> IO a 70 | throwErrnoPathIfMinus1Retry loc path f = do 71 | throwErrnoPathIfRetry (== -1) loc path f 72 | 73 | throwErrnoPathIfMinus1Retry_ :: (Eq a, Num a) 74 | => String -> RawFilePath -> IO a -> IO () 75 | throwErrnoPathIfMinus1Retry_ loc path f = 76 | void $ throwErrnoPathIfRetry (== -1) loc path f 77 | 78 | throwErrnoPathIfNullRetry :: String -> RawFilePath -> IO (Ptr a) -> IO (Ptr a) 79 | throwErrnoPathIfNullRetry loc path f = 80 | throwErrnoPathIfRetry (== nullPtr) loc path f 81 | 82 | throwErrnoPathIfRetry :: (a -> Bool) -> String -> RawFilePath -> IO a -> IO a 83 | throwErrnoPathIfRetry pr loc rpath f = 84 | do 85 | res <- f 86 | if pr res 87 | then do 88 | err <- getErrno 89 | if err == eINTR 90 | then throwErrnoPathIfRetry pr loc rpath f 91 | else throwErrnoPath loc rpath 92 | else return res 93 | 94 | -- | as 'throwErrno', but exceptions include the given path when appropriate. 95 | -- 96 | throwErrnoPath :: String -> RawFilePath -> IO a 97 | throwErrnoPath loc path = 98 | do 99 | errno <- getErrno 100 | path' <- either (const (BC.unpack path)) id <$> try @IOException (decodeWithBasePosix path) 101 | ioError (errnoToIOError loc errno Nothing (Just path')) 102 | 103 | -- | as 'throwErrnoIf', but exceptions include the given path when 104 | -- appropriate. 105 | -- 106 | throwErrnoPathIf :: (a -> Bool) -> String -> RawFilePath -> IO a -> IO a 107 | throwErrnoPathIf cond loc path f = 108 | do 109 | res <- f 110 | if cond res then throwErrnoPath loc path else return res 111 | 112 | -- | as 'throwErrnoIf_', but exceptions include the given path when 113 | -- appropriate. 114 | -- 115 | throwErrnoPathIf_ :: (a -> Bool) -> String -> RawFilePath -> IO a -> IO () 116 | throwErrnoPathIf_ cond loc path f = void $ throwErrnoPathIf cond loc path f 117 | 118 | -- | as 'throwErrnoIfNull', but exceptions include the given path when 119 | -- appropriate. 120 | -- 121 | throwErrnoPathIfNull :: String -> RawFilePath -> IO (Ptr a) -> IO (Ptr a) 122 | throwErrnoPathIfNull = throwErrnoPathIf (== nullPtr) 123 | 124 | -- | as 'throwErrnoIfMinus1', but exceptions include the given path when 125 | -- appropriate. 126 | -- 127 | throwErrnoPathIfMinus1 :: (Eq a, Num a) => String -> RawFilePath -> IO a -> IO a 128 | throwErrnoPathIfMinus1 = throwErrnoPathIf (== -1) 129 | 130 | -- | as 'throwErrnoIfMinus1_', but exceptions include the given path when 131 | -- appropriate. 132 | -- 133 | throwErrnoPathIfMinus1_ :: (Eq a, Num a) => String -> RawFilePath -> IO a -> IO () 134 | throwErrnoPathIfMinus1_ = throwErrnoPathIf_ (== -1) 135 | 136 | -- | as 'throwErrnoTwoPathsIfMinus1_', but exceptions include two paths when appropriate. 137 | -- 138 | throwErrnoTwoPathsIfMinus1_ :: (Eq a, Num a) => String -> RawFilePath -> RawFilePath -> IO a -> IO () 139 | throwErrnoTwoPathsIfMinus1_ loc path1 path2 action = do 140 | path1' <- either (const (BC.unpack path1)) id <$> try @IOException (decodeWithBasePosix path1) 141 | path2' <- either (const (BC.unpack path2)) id <$> try @IOException (decodeWithBasePosix path2) 142 | throwErrnoIfMinus1_ (loc <> " '" <> path1' <> "' to '" <> path2' <> "'") action 143 | 144 | -- | This mimics the filepath decoder base uses on unix, 145 | -- with the small distinction that we're not truncating at NUL bytes (because we're not at 146 | -- the outer FFI layer). 147 | decodeWithBasePosix :: RawFilePath -> IO String 148 | decodeWithBasePosix ba = B.useAsCStringLen ba $ \fp -> peekFilePathPosix fp 149 | where 150 | peekFilePathPosix :: CStringLen -> IO String 151 | peekFilePathPosix fp = getFileSystemEncoding >>= \enc -> GHC.peekCStringLen enc fp 152 | 153 | -- | Wrapper around 'useAsCString', checking the encoded 'FilePath' for internal NUL octets as these are 154 | -- disallowed in POSIX filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660 155 | useAsCStringSafe :: RawFilePath -> (CString -> IO a) -> IO a 156 | useAsCStringSafe path f = useAsCString path $ \ptr -> do 157 | let len = B.length path 158 | clen <- c_strlen ptr 159 | if clen == fromIntegral len 160 | then f ptr 161 | else do 162 | path' <- either (const (BC.unpack path)) id <$> try @IOException (decodeWithBasePosix path) 163 | ioError (err path') 164 | where 165 | err path' = 166 | IOError 167 | { ioe_handle = Nothing 168 | , ioe_type = InvalidArgument 169 | , ioe_location = "checkForInteriorNuls" 170 | , ioe_description = "POSIX filepaths must not contain internal NUL octets." 171 | , ioe_errno = Nothing 172 | , ioe_filename = Just path' 173 | } 174 | -------------------------------------------------------------------------------- /System/Posix/Env/ByteString.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : System.Posix.Env.ByteString 7 | -- Copyright : (c) The University of Glasgow 2002 8 | -- License : BSD-style (see the file libraries/base/LICENSE) 9 | -- 10 | -- Maintainer : libraries@haskell.org 11 | -- Stability : provisional 12 | -- Portability : non-portable (requires POSIX) 13 | -- 14 | -- POSIX environment support 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module System.Posix.Env.ByteString ( 19 | -- * Environment Variables 20 | getEnv 21 | , getEnvDefault 22 | , getEnvironmentPrim 23 | , getEnvironment 24 | , setEnvironment 25 | , putEnv 26 | , setEnv 27 | , unsetEnv 28 | , clearEnv 29 | 30 | -- * Program arguments 31 | , getArgs 32 | ) where 33 | 34 | #include "HsUnix.h" 35 | 36 | import Control.Monad 37 | import Foreign 38 | import Foreign.C 39 | import Data.Maybe ( fromMaybe ) 40 | 41 | import System.Posix.Env ( clearEnv ) 42 | import qualified Data.ByteString as B 43 | import qualified Data.ByteString.Char8 as BC 44 | import Data.ByteString (ByteString) 45 | import Data.ByteString.Internal (ByteString (PS)) 46 | 47 | import qualified System.Posix.Env.Internal as Internal 48 | 49 | -- |'getEnv' looks up a variable in the environment. 50 | 51 | getEnv :: 52 | ByteString {- ^ variable name -} -> 53 | IO (Maybe ByteString) {- ^ variable value -} 54 | getEnv name = do 55 | litstring <- B.useAsCString name c_getenv 56 | if litstring /= nullPtr 57 | then Just <$> B.packCString litstring 58 | else return Nothing 59 | 60 | -- |'getEnvDefault' is a wrapper around 'getEnv' where the 61 | -- programmer can specify a fallback as the second argument, which will be 62 | -- used if the variable is not found in the environment. 63 | 64 | getEnvDefault :: 65 | ByteString {- ^ variable name -} -> 66 | ByteString {- ^ fallback value -} -> 67 | IO ByteString {- ^ variable value or fallback value -} 68 | getEnvDefault name fallback = fromMaybe fallback <$> getEnv name 69 | 70 | foreign import ccall unsafe "getenv" 71 | c_getenv :: CString -> IO CString 72 | 73 | getEnvironmentPrim :: IO [ByteString] 74 | getEnvironmentPrim = Internal.getEnvironmentPrim >>= mapM B.packCString 75 | 76 | -- |'getEnvironment' retrieves the entire environment as a 77 | -- list of @(key,value)@ pairs. 78 | 79 | getEnvironment :: IO [(ByteString,ByteString)] {- ^ @[(key,value)]@ -} 80 | getEnvironment = do 81 | env <- getEnvironmentPrim 82 | return $ map (dropEq.(BC.break ((==) '='))) env 83 | where 84 | dropEq (x,y) 85 | | BC.head y == '=' = (x,B.tail y) 86 | | otherwise = error $ "getEnvironment: insane variable " ++ BC.unpack x 87 | 88 | -- |'setEnvironment' resets the entire environment to the given list of 89 | -- @(key,value)@ pairs. 90 | -- 91 | -- @since 2.8.0.0 92 | setEnvironment :: 93 | [(ByteString,ByteString)] {- ^ @[(key,value)]@ -} -> 94 | IO () 95 | setEnvironment env = do 96 | clearEnv 97 | forM_ env $ \(key,value) -> 98 | setEnv key value True {-overwrite-} 99 | 100 | -- |The 'unsetEnv' function deletes all instances of the variable name 101 | -- from the environment. 102 | 103 | unsetEnv :: ByteString {- ^ variable name -} -> IO () 104 | #if HAVE_UNSETENV 105 | # if !UNSETENV_RETURNS_VOID 106 | unsetEnv name = B.useAsCString name $ \ s -> 107 | throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s) 108 | 109 | -- POSIX.1-2001 compliant unsetenv(3) 110 | foreign import capi unsafe "HsUnix.h unsetenv" 111 | c_unsetenv :: CString -> IO CInt 112 | # else 113 | unsetEnv name = B.useAsCString name c_unsetenv 114 | 115 | -- pre-POSIX unsetenv(3) returning @void@ 116 | foreign import capi unsafe "HsUnix.h unsetenv" 117 | c_unsetenv :: CString -> IO () 118 | # endif 119 | #else 120 | unsetEnv name = putEnv (BC.snoc name '=') 121 | #endif 122 | 123 | -- |'putEnv' function takes an argument of the form @name=value@ 124 | -- and is equivalent to @setEnv(key,value,True{-overwrite-})@. 125 | 126 | putEnv :: ByteString {- ^ "key=value" -} -> IO () 127 | putEnv (PS fp o l) = withForeignPtr fp $ \p -> do 128 | -- https://pubs.opengroup.org/onlinepubs/009696899/functions/putenv.html 129 | -- 130 | -- "the string pointed to by string shall become part of the environment, 131 | -- so altering the string shall change the environment. The space used by 132 | -- string is no longer used once a new string which defines name is passed to putenv()." 133 | -- 134 | -- hence we must not free the buffer 135 | buf <- mallocBytes (l+1) 136 | copyBytes buf (p `plusPtr` o) l 137 | pokeByteOff buf l (0::Word8) 138 | throwErrnoIfMinus1_ "putenv" (c_putenv (castPtr buf)) 139 | 140 | foreign import ccall unsafe "putenv" 141 | c_putenv :: CString -> IO CInt 142 | 143 | {- |The 'setEnv' function inserts or resets the environment variable name in 144 | the current environment list. If the variable @name@ does not exist in the 145 | list, it is inserted with the given value. If the variable does exist, 146 | the argument @overwrite@ is tested; if @overwrite@ is @False@, the variable is 147 | not reset, otherwise it is reset to the given value. 148 | -} 149 | 150 | setEnv :: 151 | ByteString {- ^ variable name -} -> 152 | ByteString {- ^ variable value -} -> 153 | Bool {- ^ overwrite -} -> 154 | IO () 155 | #ifdef HAVE_SETENV 156 | setEnv key value ovrwrt = do 157 | B.useAsCString key $ \ keyP -> 158 | B.useAsCString value $ \ valueP -> 159 | throwErrnoIfMinus1_ "setenv" $ 160 | c_setenv keyP valueP (fromIntegral (fromEnum ovrwrt)) 161 | 162 | foreign import ccall unsafe "setenv" 163 | c_setenv :: CString -> CString -> CInt -> IO CInt 164 | #else 165 | setEnv key value True = putEnv (key++"="++value) 166 | setEnv key value False = do 167 | res <- getEnv key 168 | case res of 169 | Just _ -> return () 170 | Nothing -> putEnv (key++"="++value) 171 | #endif 172 | 173 | -- | Computation 'getArgs' returns a list of the program's command 174 | -- line arguments (not including the program name), as 'ByteString's. 175 | -- 176 | -- Unlike 'System.Environment.getArgs', this function does no Unicode 177 | -- decoding of the arguments; you get the exact bytes that were passed 178 | -- to the program by the OS. To interpret the arguments as text, some 179 | -- Unicode decoding should be applied. 180 | -- 181 | getArgs :: IO [ByteString] 182 | getArgs = 183 | alloca $ \ p_argc -> 184 | alloca $ \ p_argv -> do 185 | getProgArgv p_argc p_argv 186 | p <- fromIntegral <$> peek p_argc 187 | argv <- peek p_argv 188 | peekArray (p - 1) (advancePtr argv 1) >>= mapM B.packCString 189 | 190 | foreign import ccall unsafe "getProgArgv" 191 | getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () 192 | -------------------------------------------------------------------------------- /System/Posix/Terminal/ByteString.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | {-# LANGUAGE Safe #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : System.Posix.Terminal.ByteString 6 | -- Copyright : (c) The University of Glasgow 2002 7 | -- License : BSD-style (see the file libraries/base/LICENSE) 8 | -- 9 | -- Maintainer : libraries@haskell.org 10 | -- Stability : provisional 11 | -- Portability : non-portable (requires POSIX) 12 | -- 13 | -- POSIX Terminal support 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module System.Posix.Terminal.ByteString ( 18 | -- * Terminal support 19 | 20 | -- ** Terminal attributes 21 | TerminalAttributes, 22 | getTerminalAttributes, 23 | TerminalState(..), 24 | setTerminalAttributes, 25 | 26 | TerminalMode(..), 27 | withoutMode, 28 | withMode, 29 | terminalMode, 30 | bitsPerByte, 31 | withBits, 32 | 33 | ControlCharacter(..), 34 | controlChar, 35 | withCC, 36 | withoutCC, 37 | 38 | inputTime, 39 | withTime, 40 | minInput, 41 | withMinInput, 42 | 43 | BaudRate(..), 44 | inputSpeed, 45 | withInputSpeed, 46 | outputSpeed, 47 | withOutputSpeed, 48 | 49 | -- ** Terminal operations 50 | sendBreak, 51 | drainOutput, 52 | QueueSelector(..), 53 | discardData, 54 | FlowAction(..), 55 | controlFlow, 56 | 57 | -- ** Process groups 58 | getTerminalProcessGroupID, 59 | setTerminalProcessGroupID, 60 | 61 | -- ** Testing a file descriptor 62 | queryTerminal, 63 | getTerminalName, 64 | getControllingTerminalName, 65 | 66 | -- ** Pseudoterminal operations 67 | openPseudoTerminal, 68 | getSlaveTerminalName 69 | ) where 70 | 71 | #include "HsUnix.h" 72 | 73 | import Foreign 74 | import System.Posix.Types 75 | import System.Posix.Terminal.Common 76 | #ifndef HAVE_OPENPTY 77 | import System.Posix.IO.ByteString (defaultFileFlags, openFd, noctty, OpenMode(ReadWrite)) 78 | import Data.ByteString.Char8 as B ( pack, ) 79 | #endif 80 | 81 | import Foreign.C hiding ( 82 | throwErrnoPath, 83 | throwErrnoPathIf, 84 | throwErrnoPathIf_, 85 | throwErrnoPathIfNull, 86 | throwErrnoPathIfMinus1, 87 | throwErrnoPathIfMinus1_ ) 88 | 89 | import System.Posix.ByteString.FilePath 90 | 91 | #if !(HAVE_CTERMID && defined(HAVE_TERMIOS_H)) 92 | import System.IO.Error ( ioeSetLocation ) 93 | import GHC.IO.Exception ( unsupportedOperation ) 94 | #endif 95 | 96 | -- | @getTerminalName fd@ calls @ttyname@ to obtain a name associated 97 | -- with the terminal for @Fd@ @fd@. If @fd@ is associated 98 | -- with a terminal, @getTerminalName@ returns the name of the 99 | -- terminal. 100 | getTerminalName :: Fd -> IO RawFilePath 101 | getTerminalName (Fd fd) = do 102 | s <- throwErrnoIfNull "getTerminalName" (c_ttyname fd) 103 | peekFilePath s 104 | 105 | foreign import ccall unsafe "ttyname" 106 | c_ttyname :: CInt -> IO CString 107 | 108 | -- | @getControllingTerminalName@ calls @ctermid@ to obtain 109 | -- a name associated with the controlling terminal for the process. If a 110 | -- controlling terminal exists, 111 | -- @getControllingTerminalName@ returns the name of the 112 | -- controlling terminal. 113 | -- 114 | -- Throws 'IOError' (\"unsupported operation\") if platform does not 115 | -- provide @ctermid(3)@ (use @#if HAVE_CTERMID@ CPP guard to 116 | -- detect availability). 117 | getControllingTerminalName :: IO RawFilePath 118 | #if HAVE_CTERMID && defined(HAVE_TERMIOS_H) 119 | getControllingTerminalName = do 120 | s <- throwErrnoIfNull "getControllingTerminalName" (c_ctermid nullPtr) 121 | peekFilePath s 122 | 123 | foreign import capi unsafe "termios.h ctermid" 124 | c_ctermid :: CString -> IO CString 125 | #else 126 | {-# WARNING getControllingTerminalName 127 | "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_CTERMID@)" #-} 128 | getControllingTerminalName = ioError (ioeSetLocation unsupportedOperation "getControllingTerminalName") 129 | #endif 130 | 131 | -- | @getSlaveTerminalName@ calls @ptsname@ to obtain the name of the 132 | -- slave terminal associated with a pseudoterminal pair. The file 133 | -- descriptor to pass in must be that of the master. 134 | getSlaveTerminalName :: Fd -> IO RawFilePath 135 | 136 | #ifdef HAVE_PTSNAME 137 | getSlaveTerminalName (Fd fd) = do 138 | s <- throwErrnoIfNull "getSlaveTerminalName" (c_ptsname fd) 139 | peekFilePath s 140 | 141 | foreign import capi unsafe "HsUnix.h ptsname" 142 | c_ptsname :: CInt -> IO CString 143 | #else 144 | {-# WARNING getSlaveTerminalName "getSlaveTerminalName: not available on this platform" #-} 145 | getSlaveTerminalName _ = 146 | ioError (errnoToIOError "getSlaveTerminalName" eNOSYS Nothing Nothing) 147 | #endif 148 | 149 | -- ----------------------------------------------------------------------------- 150 | -- openPseudoTerminal needs to be here because it depends on 151 | -- getSlaveTerminalName. 152 | 153 | -- | @openPseudoTerminal@ creates a pseudoterminal (pty) pair, and 154 | -- returns the newly created pair as a (@master@, @slave@) tuple. 155 | openPseudoTerminal :: IO (Fd, Fd) 156 | 157 | #ifdef HAVE_OPENPTY 158 | openPseudoTerminal = 159 | alloca $ \p_master -> 160 | alloca $ \p_slave -> do 161 | throwErrnoIfMinus1_ "openPty" 162 | (c_openpty p_master p_slave nullPtr nullPtr nullPtr) 163 | master <- peek p_master 164 | slave <- peek p_slave 165 | return (Fd master, Fd slave) 166 | 167 | foreign import ccall unsafe "openpty" 168 | c_openpty :: Ptr CInt -> Ptr CInt -> CString -> Ptr CTermios -> Ptr a 169 | -> IO CInt 170 | #else 171 | openPseudoTerminal = do 172 | (Fd master) <- openFd (B.pack "/dev/ptmx") ReadWrite 173 | defaultFileFlags{noctty=True} 174 | throwErrnoIfMinus1_ "openPseudoTerminal" (c_grantpt master) 175 | throwErrnoIfMinus1_ "openPseudoTerminal" (c_unlockpt master) 176 | slaveName <- getSlaveTerminalName (Fd master) 177 | slave <- openFd slaveName ReadWrite defaultFileFlags{noctty=True} 178 | pushModule slave "ptem" 179 | pushModule slave "ldterm" 180 | # ifndef __hpux 181 | pushModule slave "ttcompat" 182 | # endif /* __hpux */ 183 | return (Fd master, slave) 184 | 185 | -- Push a STREAMS module, for System V systems. 186 | pushModule :: Fd -> String -> IO () 187 | pushModule (Fd fd) name = 188 | withCString name $ \p_name -> 189 | throwErrnoIfMinus1_ "openPseudoTerminal" 190 | (c_push_module fd p_name) 191 | 192 | foreign import ccall unsafe "__hsunix_push_module" 193 | c_push_module :: CInt -> CString -> IO CInt 194 | 195 | #if HAVE_PTSNAME 196 | foreign import capi unsafe "HsUnix.h grantpt" 197 | c_grantpt :: CInt -> IO CInt 198 | 199 | foreign import capi unsafe "HsUnix.h unlockpt" 200 | c_unlockpt :: CInt -> IO CInt 201 | #else 202 | c_grantpt :: CInt -> IO CInt 203 | c_grantpt _ = return (fromIntegral (0::Int)) 204 | 205 | c_unlockpt :: CInt -> IO CInt 206 | c_unlockpt _ = return (fromIntegral (0::Int)) 207 | #endif /* HAVE_PTSNAME */ 208 | #endif /* !HAVE_OPENPTY */ 209 | --------------------------------------------------------------------------------