Skip to content

Commit 17570df

Browse files
hasufellhasufell
committed
Add PosixFilePath and friends support (for AFPP)
1 parent d2fe3cd commit 17570df

13 files changed

+1615
-3
lines changed

‎System/Posix/Directory/PosixPath.hsc

+166
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,166 @@
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 : [email protected]
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+
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.OsPath.Types
55+
import GHC.IO.Encoding.UTF8 ( mkUTF8 )
56+
import GHC.IO.Encoding.Failure ( CodingFailureMode(..) )
57+
import System.OsPath.Posix
58+
import System.Posix.Directory hiding (createDirectory, openDirStream, readDirStream, getWorkingDirectory, changeWorkingDirectory, removeDirectory)
59+
import qualified System.Posix.Directory.Common as Common
60+
import System.Posix.PosixPath.FilePath
61+
62+
-- | @createDirectory dir mode@ calls @mkdir@ to
63+
-- create a new directory, @dir@, with permissions based on
64+
-- @mode@.
65+
createDirectory :: PosixPath -> 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 :: PosixPath -> IO DirStream
78+
openDirStream name =
79+
withFilePath name $ \s -> do
80+
dirp <- throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s
81+
return (Common.DirStream dirp)
82+
83+
foreign import capi unsafe "HsUnix.h opendir"
84+
c_opendir :: CString -> IO (Ptr Common.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+
readDirStream :: DirStream -> IO PosixPath
91+
readDirStream (Common.DirStream dirp) = alloca $ \ptr_dEnt -> loop ptr_dEnt
92+
where
93+
loop ptr_dEnt = do
94+
resetErrno
95+
r <- c_readdir dirp ptr_dEnt
96+
if (r == 0)
97+
then do dEnt <- peek ptr_dEnt
98+
if (dEnt == nullPtr)
99+
then return mempty
100+
else do
101+
entry <- (d_name dEnt >>= peekFilePath)
102+
c_freeDirEnt dEnt
103+
return entry
104+
else do errno <- getErrno
105+
if (errno == eINTR) then loop ptr_dEnt else do
106+
let (Errno eo) = errno
107+
if (eo == 0)
108+
then return mempty
109+
else throwErrno "readDirStream"
110+
111+
-- traversing directories
112+
foreign import ccall unsafe "__hscore_readdir"
113+
c_readdir :: Ptr Common.CDir -> Ptr (Ptr Common.CDirent) -> IO CInt
114+
115+
foreign import ccall unsafe "__hscore_free_dirent"
116+
c_freeDirEnt :: Ptr Common.CDirent -> IO ()
117+
118+
foreign import ccall unsafe "__hscore_d_name"
119+
d_name :: Ptr Common.CDirent -> IO CString
120+
121+
122+
-- | @getWorkingDirectory@ calls @getcwd@ to obtain the name
123+
-- of the current working directory.
124+
getWorkingDirectory :: IO PosixPath
125+
getWorkingDirectory = go (#const PATH_MAX)
126+
where
127+
go bytes = do
128+
r <- allocaBytes bytes $ \buf -> do
129+
buf' <- c_getcwd buf (fromIntegral bytes)
130+
if buf' /= nullPtr
131+
then do s <- peekFilePath buf
132+
return (Just s)
133+
else do errno <- getErrno
134+
if errno == eRANGE
135+
-- we use Nothing to indicate that we should
136+
-- try again with a bigger buffer
137+
then return Nothing
138+
else throwErrno "getWorkingDirectory"
139+
maybe (go (2 * bytes)) return r
140+
141+
foreign import ccall unsafe "getcwd"
142+
c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar)
143+
144+
-- | @changeWorkingDirectory dir@ calls @chdir@ to change
145+
-- the current working directory to @dir@.
146+
changeWorkingDirectory :: PosixPath -> IO ()
147+
changeWorkingDirectory path =
148+
modifyIOError (`ioeSetFileName` (_toStr path)) $
149+
withFilePath path $ \s ->
150+
throwErrnoIfMinus1Retry_ "changeWorkingDirectory" (c_chdir s)
151+
152+
foreign import ccall unsafe "chdir"
153+
c_chdir :: CString -> IO CInt
154+
155+
removeDirectory :: PosixPath -> IO ()
156+
removeDirectory path =
157+
modifyIOError (`ioeSetFileName` _toStr path) $
158+
withFilePath path $ \s ->
159+
throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s)
160+
161+
foreign import ccall unsafe "rmdir"
162+
c_rmdir :: CString -> IO CInt
163+
164+
_toStr :: PosixPath -> String
165+
_toStr fp = either (error . show) id $ decodeWith (mkUTF8 TransliterateCodingFailure) fp
166+

‎System/Posix/Env/PosixString.hsc

+188
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,188 @@
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 GHC.IO.Encoding.UTF8 ( mkUTF8 )
38+
import GHC.IO.Encoding.Failure ( CodingFailureMode(..) )
39+
import System.OsPath.Posix
40+
import System.OsString.Internal.Types
41+
import qualified System.OsPath.Data.ByteString.Short as B
42+
43+
-- |'getEnv' looks up a variable in the environment.
44+
45+
getEnv ::
46+
PosixString {- ^ variable name -} ->
47+
IO (Maybe PosixString) {- ^ variable value -}
48+
getEnv (PS name) = do
49+
litstring <- B.useAsCString name c_getenv
50+
if litstring /= nullPtr
51+
then (Just . PS) <$> B.packCString litstring
52+
else return Nothing
53+
54+
-- |'getEnvDefault' is a wrapper around 'getEnv' where the
55+
-- programmer can specify a fallback as the second argument, which will be
56+
-- used if the variable is not found in the environment.
57+
58+
getEnvDefault ::
59+
PosixString {- ^ variable name -} ->
60+
PosixString {- ^ fallback value -} ->
61+
IO PosixString {- ^ variable value or fallback value -}
62+
getEnvDefault name fallback = fromMaybe fallback <$> getEnv name
63+
64+
foreign import ccall unsafe "getenv"
65+
c_getenv :: CString -> IO CString
66+
67+
getEnvironmentPrim :: IO [PosixString]
68+
getEnvironmentPrim = do
69+
c_environ <- getCEnviron
70+
arr <- peekArray0 nullPtr c_environ
71+
mapM (fmap PS . B.packCString) arr
72+
73+
getCEnviron :: IO (Ptr CString)
74+
#if HAVE__NSGETENVIRON
75+
-- You should not access @char **environ@ directly on Darwin in a bundle/shared library.
76+
-- See #2458 and http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html
77+
getCEnviron = nsGetEnviron >>= peek
78+
79+
foreign import ccall unsafe "_NSGetEnviron"
80+
nsGetEnviron :: IO (Ptr (Ptr CString))
81+
#else
82+
getCEnviron = peek c_environ_p
83+
84+
foreign import ccall unsafe "&environ"
85+
c_environ_p :: Ptr (Ptr CString)
86+
#endif
87+
88+
-- |'getEnvironment' retrieves the entire environment as a
89+
-- list of @(key,value)@ pairs.
90+
91+
getEnvironment :: IO [(PosixString,PosixString)] {- ^ @[(key,value)]@ -}
92+
getEnvironment = do
93+
env <- getEnvironmentPrim
94+
return $ map (dropEq . (B.break ((==) _equal)) . getPosixString) env
95+
where
96+
dropEq (x,y)
97+
| B.head y == _equal = (PS x, PS (B.tail y))
98+
| otherwise = error $ "getEnvironment: insane variable " ++ _toStr x
99+
100+
-- |The 'unsetEnv' function deletes all instances of the variable name
101+
-- from the environment.
102+
103+
unsetEnv :: PosixString {- ^ variable name -} -> IO ()
104+
#if HAVE_UNSETENV
105+
# if !UNSETENV_RETURNS_VOID
106+
unsetEnv (PS 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 (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 :: PosixString {- ^ "key=value" -} -> IO ()
127+
putEnv (PS keyvalue) = B.useAsCString keyvalue $ \s ->
128+
throwErrnoIfMinus1_ "putenv" (c_putenv s)
129+
130+
foreign import ccall unsafe "putenv"
131+
c_putenv :: CString -> IO CInt
132+
133+
{- |The 'setEnv' function inserts or resets the environment variable name in
134+
the current environment list. If the variable @name@ does not exist in the
135+
list, it is inserted with the given value. If the variable does exist,
136+
the argument @overwrite@ is tested; if @overwrite@ is @False@, the variable is
137+
not reset, otherwise it is reset to the given value.
138+
-}
139+
140+
setEnv ::
141+
PosixString {- ^ variable name -} ->
142+
PosixString {- ^ variable value -} ->
143+
Bool {- ^ overwrite -} ->
144+
IO ()
145+
#ifdef HAVE_SETENV
146+
setEnv (PS key) (PS value) ovrwrt = do
147+
B.useAsCString key $ \ keyP ->
148+
B.useAsCString value $ \ valueP ->
149+
throwErrnoIfMinus1_ "setenv" $
150+
c_setenv keyP valueP (fromIntegral (fromEnum ovrwrt))
151+
152+
foreign import ccall unsafe "setenv"
153+
c_setenv :: CString -> CString -> CInt -> IO CInt
154+
#else
155+
setEnv key value True = putEnv (key++"="++value)
156+
setEnv key value False = do
157+
res <- getEnv key
158+
case res of
159+
Just _ -> return ()
160+
Nothing -> putEnv (key++"="++value)
161+
#endif
162+
163+
-- | Computation 'getArgs' returns a list of the program's command
164+
-- line arguments (not including the program name), as 'PosixString's.
165+
--
166+
-- Unlike 'System.Environment.getArgs', this function does no Unicode
167+
-- decoding of the arguments; you get the exact bytes that were passed
168+
-- to the program by the OS. To interpret the arguments as text, some
169+
-- Unicode decoding should be applied.
170+
--
171+
getArgs :: IO [PosixString]
172+
getArgs =
173+
alloca $ \ p_argc ->
174+
alloca $ \ p_argv -> do
175+
getProgArgv p_argc p_argv
176+
p <- fromIntegral <$> peek p_argc
177+
argv <- peek p_argv
178+
peekArray (p - 1) (advancePtr argv 1) >>= mapM (fmap PS . B.packCString)
179+
180+
foreign import ccall unsafe "getProgArgv"
181+
getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
182+
183+
_equal :: Word8
184+
_equal = 0x3d
185+
186+
_toStr :: B.ShortByteString -> String
187+
_toStr = either (error . show) id . decodeWith (mkUTF8 TransliterateCodingFailure) . PosixString
188+

0 commit comments

Comments
 (0)