Skip to content

Commit f37227e

Browse files
hasufellhasufell
committed
Add PosixFilePath and friends support (for AFPP)
1 parent 3862b76 commit f37227e

File tree

9 files changed

+1328
-2
lines changed

9 files changed

+1328
-2
lines changed

‎System/Posix/Directory/PosixFilePath.hsc

+164
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,164 @@
1+
{-# LANGUAGE CApiFFI #-}
2+
{-# LANGUAGE NondecreasingIndentation #-}
3+
4+
-----------------------------------------------------------------------------
5+
-- |
6+
-- Module : System.Posix.Directory.PosixFilePath
7+
-- Copyright : (c) The University of Glasgow 2002
8+
-- License : BSD-style (see the file libraries/base/LICENSE)
9+
--
10+
-- Maintainer : [email protected]
11+
-- Stability : provisional
12+
-- Portability : non-portable (requires POSIX)
13+
--
14+
-- PosixFilePath 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.PosixFilePath (
26+
-- * Creating and removing directories
27+
createDirectory, removeDirectory,
28+
29+
-- * Reading directories
30+
DirStream,
31+
openDirStream,
32+
readDirStream,
33+
rewindDirStream,
34+
closeDirStream,
35+
DirStreamOffset,
36+
#ifdef HAVE_TELLDIR
37+
tellDirStream,
38+
#endif
39+
#ifdef HAVE_SEEKDIR
40+
seekDirStream,
41+
#endif
42+
43+
-- * The working directory
44+
getWorkingDirectory,
45+
changeWorkingDirectory,
46+
changeWorkingDirectoryFd,
47+
) where
48+
49+
import System.IO.Error
50+
import System.Posix.Types
51+
import Foreign
52+
import Foreign.C
53+
54+
import System.AbstractFilePath.Types
55+
import System.AbstractFilePath.Data.ByteString.Short.Decode (decodeUtf8With, lenientDecode)
56+
import System.Posix.Directory hiding (createDirectory, openDirStream, readDirStream, getWorkingDirectory, changeWorkingDirectory, removeDirectory)
57+
import qualified System.Posix.Directory.Common as Common
58+
import System.Posix.PosixFilePath.FilePath
59+
60+
-- | @createDirectory dir mode@ calls @mkdir@ to
61+
-- create a new directory, @dir@, with permissions based on
62+
-- @mode@.
63+
createDirectory :: PosixFilePath -> 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 :: PosixFilePath -> IO 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+
readDirStream :: DirStream -> IO PosixFilePath
89+
readDirStream (Common.DirStream dirp) = alloca $ \ptr_dEnt -> loop ptr_dEnt
90+
where
91+
loop ptr_dEnt = do
92+
resetErrno
93+
r <- c_readdir dirp ptr_dEnt
94+
if (r == 0)
95+
then do dEnt <- peek ptr_dEnt
96+
if (dEnt == nullPtr)
97+
then return mempty
98+
else do
99+
entry <- (d_name dEnt >>= peekFilePath)
100+
c_freeDirEnt dEnt
101+
return entry
102+
else do errno <- getErrno
103+
if (errno == eINTR) then loop ptr_dEnt else do
104+
let (Errno eo) = errno
105+
if (eo == 0)
106+
then return mempty
107+
else throwErrno "readDirStream"
108+
109+
-- traversing directories
110+
foreign import ccall unsafe "__hscore_readdir"
111+
c_readdir :: Ptr Common.CDir -> Ptr (Ptr Common.CDirent) -> IO CInt
112+
113+
foreign import ccall unsafe "__hscore_free_dirent"
114+
c_freeDirEnt :: Ptr Common.CDirent -> IO ()
115+
116+
foreign import ccall unsafe "__hscore_d_name"
117+
d_name :: Ptr Common.CDirent -> IO CString
118+
119+
120+
-- | @getWorkingDirectory@ calls @getcwd@ to obtain the name
121+
-- of the current working directory.
122+
getWorkingDirectory :: IO PosixFilePath
123+
getWorkingDirectory = go (#const PATH_MAX)
124+
where
125+
go bytes = do
126+
r <- allocaBytes bytes $ \buf -> do
127+
buf' <- c_getcwd buf (fromIntegral bytes)
128+
if buf' /= nullPtr
129+
then do s <- peekFilePath buf
130+
return (Just s)
131+
else do errno <- getErrno
132+
if errno == eRANGE
133+
-- we use Nothing to indicate that we should
134+
-- try again with a bigger buffer
135+
then return Nothing
136+
else throwErrno "getWorkingDirectory"
137+
maybe (go (2 * bytes)) return r
138+
139+
foreign import ccall unsafe "getcwd"
140+
c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar)
141+
142+
-- | @changeWorkingDirectory dir@ calls @chdir@ to change
143+
-- the current working directory to @dir@.
144+
changeWorkingDirectory :: PosixFilePath -> IO ()
145+
changeWorkingDirectory path =
146+
modifyIOError (`ioeSetFileName` (_toStr path)) $
147+
withFilePath path $ \s ->
148+
throwErrnoIfMinus1Retry_ "changeWorkingDirectory" (c_chdir s)
149+
150+
foreign import ccall unsafe "chdir"
151+
c_chdir :: CString -> IO CInt
152+
153+
removeDirectory :: PosixFilePath -> IO ()
154+
removeDirectory path =
155+
modifyIOError (`ioeSetFileName` _toStr path) $
156+
withFilePath path $ \s ->
157+
throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s)
158+
159+
foreign import ccall unsafe "rmdir"
160+
c_rmdir :: CString -> IO CInt
161+
162+
_toStr :: PosixFilePath -> String
163+
_toStr (PS fp) = decodeUtf8With lenientDecode fp
164+

‎System/Posix/Env/PosixString.hsc

+186
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,186 @@
1+
{-# LANGUAGE CApiFFI #-}
2+
3+
-----------------------------------------------------------------------------
4+
-- |
5+
-- Module : System.Posix.Env.PosixString
6+
-- Copyright : (c) The University of Glasgow 2002
7+
-- License : BSD-style (see the file libraries/base/LICENSE)
8+
--
9+
-- Maintainer : [email protected]
10+
-- Stability : provisional
11+
-- Portability : non-portable (requires POSIX)
12+
--
13+
-- POSIX environment support
14+
--
15+
-----------------------------------------------------------------------------
16+
17+
module System.Posix.Env.PosixString (
18+
-- * Environment Variables
19+
getEnv
20+
, getEnvDefault
21+
, getEnvironmentPrim
22+
, getEnvironment
23+
, putEnv
24+
, setEnv
25+
, unsetEnv
26+
27+
-- * Program arguments
28+
, getArgs
29+
) where
30+
31+
#include "HsUnix.h"
32+
33+
import Foreign
34+
import Foreign.C
35+
import Data.Maybe ( fromMaybe )
36+
37+
import System.AbstractFilePath.Data.ByteString.Short.Decode (decodeUtf8With, lenientDecode)
38+
import System.OsString.Internal.Types
39+
import qualified Data.ByteString.Short as B
40+
41+
-- |'getEnv' looks up a variable in the environment.
42+
43+
getEnv ::
44+
PosixString {- ^ variable name -} ->
45+
IO (Maybe PosixString) {- ^ variable value -}
46+
getEnv (PS name) = do
47+
litstring <- B.useAsCString name c_getenv
48+
if litstring /= nullPtr
49+
then (Just . PS) <$> B.packCString litstring
50+
else return Nothing
51+
52+
-- |'getEnvDefault' is a wrapper around 'getEnv' where the
53+
-- programmer can specify a fallback as the second argument, which will be
54+
-- used if the variable is not found in the environment.
55+
56+
getEnvDefault ::
57+
PosixString {- ^ variable name -} ->
58+
PosixString {- ^ fallback value -} ->
59+
IO PosixString {- ^ 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 [PosixString]
66+
getEnvironmentPrim = do
67+
c_environ <- getCEnviron
68+
arr <- peekArray0 nullPtr c_environ
69+
mapM (fmap PS . B.packCString) arr
70+
71+
getCEnviron :: IO (Ptr CString)
72+
#if HAVE__NSGETENVIRON
73+
-- You should not access @char **environ@ directly on Darwin in a bundle/shared library.
74+
-- See #2458 and http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html
75+
getCEnviron = nsGetEnviron >>= peek
76+
77+
foreign import ccall unsafe "_NSGetEnviron"
78+
nsGetEnviron :: IO (Ptr (Ptr CString))
79+
#else
80+
getCEnviron = peek c_environ_p
81+
82+
foreign import ccall unsafe "&environ"
83+
c_environ_p :: Ptr (Ptr CString)
84+
#endif
85+
86+
-- |'getEnvironment' retrieves the entire environment as a
87+
-- list of @(key,value)@ pairs.
88+
89+
getEnvironment :: IO [(PosixString,PosixString)] {- ^ @[(key,value)]@ -}
90+
getEnvironment = do
91+
env <- getEnvironmentPrim
92+
return $ map (dropEq . (B.break ((==) _equal)) . unPFP) env
93+
where
94+
dropEq (x,y)
95+
| B.head y == _equal = (PS x, PS (B.tail y))
96+
| otherwise = error $ "getEnvironment: insane variable " ++ _toStr x
97+
98+
-- |The 'unsetEnv' function deletes all instances of the variable name
99+
-- from the environment.
100+
101+
unsetEnv :: PosixString {- ^ variable name -} -> IO ()
102+
#if HAVE_UNSETENV
103+
# if !UNSETENV_RETURNS_VOID
104+
unsetEnv (PS name) = B.useAsCString name $ \ s ->
105+
throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s)
106+
107+
-- POSIX.1-2001 compliant unsetenv(3)
108+
foreign import capi unsafe "HsUnix.h unsetenv"
109+
c_unsetenv :: CString -> IO CInt
110+
# else
111+
unsetEnv name = B.useAsCString name c_unsetenv
112+
113+
-- pre-POSIX unsetenv(3) returning @void@
114+
foreign import capi unsafe "HsUnix.h unsetenv"
115+
c_unsetenv :: CString -> IO ()
116+
# endif
117+
#else
118+
unsetEnv name = putEnv (name ++ "=")
119+
#endif
120+
121+
-- |'putEnv' function takes an argument of the form @name=value@
122+
-- and is equivalent to @setEnv(key,value,True{-overwrite-})@.
123+
124+
putEnv :: PosixString {- ^ "key=value" -} -> IO ()
125+
putEnv (PS keyvalue) = B.useAsCString keyvalue $ \s ->
126+
throwErrnoIfMinus1_ "putenv" (c_putenv s)
127+
128+
foreign import ccall unsafe "putenv"
129+
c_putenv :: CString -> IO CInt
130+
131+
{- |The 'setEnv' function inserts or resets the environment variable name in
132+
the current environment list. If the variable @name@ does not exist in the
133+
list, it is inserted with the given value. If the variable does exist,
134+
the argument @overwrite@ is tested; if @overwrite@ is @False@, the variable is
135+
not reset, otherwise it is reset to the given value.
136+
-}
137+
138+
setEnv ::
139+
PosixString {- ^ variable name -} ->
140+
PosixString {- ^ variable value -} ->
141+
Bool {- ^ overwrite -} ->
142+
IO ()
143+
#ifdef HAVE_SETENV
144+
setEnv (PS key) (PS value) ovrwrt = do
145+
B.useAsCString key $ \ keyP ->
146+
B.useAsCString value $ \ valueP ->
147+
throwErrnoIfMinus1_ "setenv" $
148+
c_setenv keyP valueP (fromIntegral (fromEnum ovrwrt))
149+
150+
foreign import ccall unsafe "setenv"
151+
c_setenv :: CString -> CString -> CInt -> IO CInt
152+
#else
153+
setEnv key value True = putEnv (key++"="++value)
154+
setEnv key value False = do
155+
res <- getEnv key
156+
case res of
157+
Just _ -> return ()
158+
Nothing -> putEnv (key++"="++value)
159+
#endif
160+
161+
-- | Computation 'getArgs' returns a list of the program's command
162+
-- line arguments (not including the program name), as 'PosixString's.
163+
--
164+
-- Unlike 'System.Environment.getArgs', this function does no Unicode
165+
-- decoding of the arguments; you get the exact bytes that were passed
166+
-- to the program by the OS. To interpret the arguments as text, some
167+
-- Unicode decoding should be applied.
168+
--
169+
getArgs :: IO [PosixString]
170+
getArgs =
171+
alloca $ \ p_argc ->
172+
alloca $ \ p_argv -> do
173+
getProgArgv p_argc p_argv
174+
p <- fromIntegral <$> peek p_argc
175+
argv <- peek p_argv
176+
peekArray (p - 1) (advancePtr argv 1) >>= mapM (fmap PS . B.packCString)
177+
178+
foreign import ccall unsafe "getProgArgv"
179+
getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
180+
181+
_equal :: Word8
182+
_equal = 0x3d
183+
184+
_toStr :: B.ShortByteString -> String
185+
_toStr = decodeUtf8With lenientDecode
186+

0 commit comments

Comments
 (0)