Skip to content

Commit be2f725

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

File tree

13 files changed

+1628
-3
lines changed

13 files changed

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

0 commit comments

Comments
 (0)