Skip to content

Commit 41e1843

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

File tree

14 files changed

+1638
-5
lines changed

14 files changed

+1638
-5
lines changed

‎System/Posix/Directory/PosixPath.hsc

Lines changed: 166 additions & 0 deletions
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 : 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+
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

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

0 commit comments

Comments
 (0)