diff --git a/impls/Str/ByteString.hs b/impls/Str/ByteString.hs new file mode 100644 index 0000000000000000000000000000000000000000..bbcbbbda14c99660c0ba1747f7b74b53b54e0e3b --- /dev/null +++ b/impls/Str/ByteString.hs @@ -0,0 +1,67 @@ +module Str.ByteString ( + Str, + useAsOSString, + newOSString, + packOSString, + module Data.ByteString.Char8 +) where + +import Foreign.C.String (CString) +import Data.Word (Word8) +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils +import Foreign.Storable +import Data.ByteString.Char8 +import Data.ByteString.Unsafe + +type Str = ByteString + +-- NB: I copypasted this from Str.hsig + +-- | Marshal a 'Str' into a NUL terminated C string using temporary +-- storage. +-- +-- * if 'Str' is Unicode, it is encoded to bytes using PEP 383 +-- ('GHC.IO.Encoding.getFileSystemEncoding'), which will interpret +-- special use of surrogates as otherwise unrepresentable bytes. +-- +-- * the 'Str' may /not/ contain any NUL characters. However, it may +-- optionally be NUL terminated. +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +useAsOSString :: Str -> (CString -> IO a) -> IO a + +-- | Marshal a 'Str' into a NUL terminated C string. However, it may +-- optionally be NUL terminated. +-- +-- * if 'Str' is Unicode, it is encoded to bytes using PEP 383 +-- ('GHC.IO.Encoding.getFileSystemEncoding'), which will interpret +-- special use of surrogates as otherwise unrepresentable bytes. +-- +-- * the 'Str' may /not/ contain any NUL characters +-- +-- * new storage is allocated for the C string and must be +-- explicitly freed using 'Foreign.Marshal.Alloc.free' or +-- 'Foreign.Marshal.Alloc.finalizerFree'. +-- +newOSString :: Str -> IO CString + +-- | Marshal a NUL terminated C string into a 'Str'. +-- +-- * if 'Str' is Unicode, we will decode using PEP 383 +-- ('GHC.IO.Encoding.getFileSystemEncoding'), which decode +-- otherwise uninterpretable bytes as surrogate sequences, +-- which can be round-tripped back. +-- +packOSString :: CString -> IO Str + +useAsOSString = useAsCString +newOSString s = unsafeUseAsCStringLen s $ \(c,l) -> do + p <- mallocBytes (l+1) + copyBytes p c (fromIntegral l) + pokeByteOff p l (0::Word8) + return p +packOSString = packCString diff --git a/impls/Str/String.hs b/impls/Str/String.hs new file mode 100644 index 0000000000000000000000000000000000000000..f24068531a2059a5281e63acf43cc0caf5dd29de --- /dev/null +++ b/impls/Str/String.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE CPP #-} +module Str.String ( + Str, + useAsOSString, + newOSString, + packOSString, + break, + tail, + head, + unpack, + append, + pack +) where + +import Prelude hiding (break, head, tail) +import qualified Prelude as P +import Foreign.C.String +import System.Posix.Internals +import qualified GHC.Foreign as GHC +import GHC.IO.Encoding (getFileSystemEncoding) + +type Str = String + +-- NB: I copypasted this from Str.hsig + +-- | Marshal a 'Str' into a NUL terminated C string using temporary +-- storage. +-- +-- * if 'Str' is Unicode, it is encoded to bytes using PEP 383 +-- ('GHC.IO.Encoding.getFileSystemEncoding'), which will interpret +-- special use of surrogates as otherwise unrepresentable bytes. +-- +-- * the 'Str' may /not/ contain any NUL characters. However, it may +-- optionally be NUL terminated. +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +useAsOSString :: Str -> (CString -> IO a) -> IO a + +-- | Marshal a 'Str' into a NUL terminated C string. However, it may +-- optionally be NUL terminated. +-- +-- * if 'Str' is Unicode, it is encoded to bytes using PEP 383 +-- ('GHC.IO.Encoding.getFileSystemEncoding'), which will interpret +-- special use of surrogates as otherwise unrepresentable bytes. +-- +-- * the 'Str' may /not/ contain any NUL characters +-- +-- * new storage is allocated for the C string and must be +-- explicitly freed using 'Foreign.Marshal.Alloc.free' or +-- 'Foreign.Marshal.Alloc.finalizerFree'. +-- +newOSString :: Str -> IO CString + +-- | Marshal a NUL terminated C string into a 'Str'. +-- +-- * if 'Str' is Unicode, we will decode using PEP 383 +-- ('GHC.IO.Encoding.getFileSystemEncoding'), which decode +-- otherwise uninterpretable bytes as surrogate sequences, +-- which can be round-tripped back. +-- +packOSString :: CString -> IO Str + +break :: (Char -> Bool) -> Str -> (Str, Str) +tail :: Str -> Str +head :: Str -> Char +unpack :: Str -> String -- or call this toString? +append :: Str -> Str -> Str +pack :: String -> Str + +useAsOSString = withFilePath +newOSString = newFilePath +packOSString = peekFilePath + +break = P.break +tail = P.tail +head = P.head +unpack = id +append = (++) +pack = id + +-- Some internal backwards-compatibility goo. + +newFilePath' :: FilePath -> IO CString +newFilePath' fp = getFileSystemEncoding >>= \enc -> GHC.newCString enc fp + +#if !MIN_VERSION_base(4,7,0) +newFilePath :: FilePath -> IO CString +newFilePath = newFilePath' +#endif diff --git a/unix-indef/Str.hsig b/unix-indef/Str.hsig new file mode 100644 index 0000000000000000000000000000000000000000..1f13425e4d0f04483f3e3d200ed2e4eb8463ea77 --- /dev/null +++ b/unix-indef/Str.hsig @@ -0,0 +1,59 @@ +signature Str where + +import Foreign.C.String (CString) + +-- | An abstract, string-like type. It may or may not be Unicode +-- encoded. +data Str + +-- Note, all occurrences of 'CString' here are assumed to have +-- the locale 'GHC.IO.Encoding.getFileSystemEncoding'; +-- i.e., when decoding into Unicode, it uses PEP 383 to represent otherwise +-- unrepresentable byte sequences. + +-- | Marshal a 'Str' into a NUL terminated C string using temporary +-- storage. +-- +-- * if 'Str' is Unicode, it is encoded to bytes using PEP 383 +-- ('GHC.IO.Encoding.getFileSystemEncoding'), which will interpret +-- special use of surrogates as otherwise unrepresentable bytes. +-- +-- * the 'Str' may /not/ contain any NUL characters. However, it may +-- optionally be NUL terminated. +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +useAsOSString :: Str -> (CString -> IO a) -> IO a + +-- | Marshal a 'Str' into a NUL terminated C string. However, it may +-- optionally be NUL terminated. +-- +-- * if 'Str' is Unicode, it is encoded to bytes using PEP 383 +-- ('GHC.IO.Encoding.getFileSystemEncoding'), which will interpret +-- special use of surrogates as otherwise unrepresentable bytes. +-- +-- * the 'Str' may /not/ contain any NUL characters +-- +-- * new storage is allocated for the C string and must be +-- explicitly freed using 'Foreign.Marshal.Alloc.free' or +-- 'Foreign.Marshal.Alloc.finalizerFree'. +-- +newOSString :: Str -> IO CString + +-- | Marshal a NUL terminated C string into a 'Str'. +-- +-- * if 'Str' is Unicode, we will decode using PEP 383 +-- ('GHC.IO.Encoding.getFileSystemEncoding'), which decode +-- otherwise uninterpretable bytes as surrogate sequences, +-- which can be round-tripped back. +-- +packOSString :: CString -> IO Str + +break :: (Char -> Bool) -> Str -> (Str, Str) +tail :: Str -> Str +head :: Str -> Char +unpack :: Str -> String -- or call this toString? +append :: Str -> Str -> Str +pack :: String -> Str diff --git a/System/Posix/Env.hsc b/unix-indef/System/Posix/Env.hsc similarity index 54% rename from System/Posix/Env.hsc rename to unix-indef/System/Posix/Env.hsc index 7d5f04cb6f544a440ceb0743e5edbfd0859d5d70..eab2ed3ec2e873cb24781a022f466b83559ce984 100644 --- a/System/Posix/Env.hsc +++ b/unix-indef/System/Posix/Env.hsc @@ -1,3 +1,4 @@ +{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE CApiFFI #-} #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-} @@ -14,7 +15,8 @@ -- Stability : provisional -- Portability : non-portable (requires POSIX) -- --- POSIX environment support +-- POSIX environment support. Warning: 'setEnvironment' and 'setEnv' are +-- NOT thread-safe. -- ----------------------------------------------------------------------------- @@ -32,42 +34,40 @@ module System.Posix.Env ( #include "HsUnix.h" +import Prelude hiding (break, head, tail) +import Str + import Foreign.C.Error (throwErrnoIfMinus1_) import Foreign.C.Types -import Foreign.C.String +import Foreign.C.String (CString) import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable import Control.Monad import Data.Maybe (fromMaybe) -import System.Posix.Internals -#if !MIN_VERSION_base(4,7,0) --- needed for backported local 'newFilePath' binding in 'putEnv' -import GHC.IO.Encoding (getFileSystemEncoding) -import qualified GHC.Foreign as GHC (newCString) -#endif +type OSString = CString -- |'getEnv' looks up a variable in the environment. -getEnv :: String -> IO (Maybe String) +getEnv :: Str -> IO (Maybe Str) getEnv name = do - litstring <- withFilePath name c_getenv + litstring <- useAsOSString name c_getenv if litstring /= nullPtr - then liftM Just $ peekFilePath litstring + then liftM Just $ packOSString litstring else return Nothing -- |'getEnvDefault' is a wrapper around 'getEnv' where the -- programmer can specify a fallback if the variable is not found -- in the environment. -getEnvDefault :: String -> String -> IO String +getEnvDefault :: Str -> Str -> IO Str getEnvDefault name fallback = liftM (fromMaybe fallback) (getEnv name) foreign import ccall unsafe "getenv" - c_getenv :: CString -> IO CString + c_getenv :: OSString -> IO OSString -getEnvironmentPrim :: IO [String] +getEnvironmentPrim :: IO [Str] getEnvironmentPrim = do c_environ <- getCEnviron -- environ can be NULL @@ -75,82 +75,107 @@ getEnvironmentPrim = do then return [] else do arr <- peekArray0 nullPtr c_environ - mapM peekFilePath arr + mapM packOSString arr -getCEnviron :: IO (Ptr CString) -#if HAVE__NSGETENVIRON --- You should not access @char **environ@ directly on Darwin in a bundle/shared library. --- See #2458 and http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html -getCEnviron = nsGetEnviron >>= peek +haveNsGetEnviron :: Bool +nsGetEnviron :: IO (Ptr (Ptr OSString)) +c_environ_p :: Ptr (Ptr OSString) +#if HAVE__NSGETENVIRON +haveNsGetEnviron = True +nsGetEnviron = nsGetEnviron' +c_environ_p = error "c_environ_p: HAVE__NSGETENVIRON" foreign import ccall unsafe "_NSGetEnviron" - nsGetEnviron :: IO (Ptr (Ptr CString)) + nsGetEnviron' :: IO (Ptr (Ptr OSString)) #else -getCEnviron = peek c_environ_p +haveNsGetEnviron = False +nsGetEnviron = error "nsGetEnviron: !HAVE__NSGETENVIRON" +c_environ_p = c_environ_p' foreign import ccall unsafe "&environ" - c_environ_p :: Ptr (Ptr CString) + c_environ_p' :: Ptr (Ptr OSString) #endif +getCEnviron :: IO (Ptr OSString) +-- You should not access @char **environ@ directly on Darwin in a bundle/shared library. +-- See #2458 and http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html +getCEnviron | haveNsGetEnviron = nsGetEnviron >>= peek + | otherwise = peek c_environ_p + -- |'getEnvironment' retrieves the entire environment as a -- list of @(key,value)@ pairs. -getEnvironment :: IO [(String,String)] +getEnvironment :: IO [(Str,Str)] getEnvironment = do env <- getEnvironmentPrim return $ map (dropEq.(break ((==) '='))) env where - dropEq (x,'=':ys) = (x,ys) - dropEq (x,_) = error $ "getEnvironment: insane variable " ++ x + dropEq (x,y) + | head y == '=' = (x,tail y) + | otherwise = error $ "getEnvironment: insane variable " ++ unpack x -- |'setEnvironment' resets the entire environment to the given list of -- @(key,value)@ pairs. -setEnvironment :: [(String,String)] -> IO () +setEnvironment :: [(Str,Str)] -> IO () setEnvironment env = do clearEnv forM_ env $ \(key,value) -> setEnv key value True {-overwrite-} --- |The 'unsetEnv' function deletes all instances of the variable name --- from the environment. +haveUnsetEnv :: Bool +unsetEnvReturnsVoid :: Bool +c_unsetenv :: OSString -> IO CInt +c_unsetenv_void :: OSString -> IO () -unsetEnv :: String -> IO () #if HAVE_UNSETENV +haveUnsetEnv = True # if !UNSETENV_RETURNS_VOID -unsetEnv name = withFilePath name $ \ s -> - throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s) - +unsetEnvReturnsVoid = False +c_unsetenv = c_unsetenv' +c_unsetenv_void = error "c_unsetenv_void: HAVE_UNSETENV && !UNSETENV_RETURNS_VOID" -- POSIX.1-2001 compliant unsetenv(3) foreign import capi unsafe "HsUnix.h unsetenv" - c_unsetenv :: CString -> IO CInt + c_unsetenv' :: OSString -> IO CInt # else -unsetEnv name = withFilePath name c_unsetenv - +unsetEnvReturnsVoid = True +c_unsetenv = error "c_unsetenv: HAVE_UNSETENV && UNSETENV_RETURNS_VOID" +c_unsetenv_void = c_unsetenv_void' -- pre-POSIX unsetenv(3) returning @void@ foreign import capi unsafe "HsUnix.h unsetenv" - c_unsetenv :: CString -> IO () + c_unsetenv_void' :: OSString -> IO () # endif #else -unsetEnv name = putEnv (name ++ "=") +haveUnsetEnv = False +unsetEnvReturnsVoid = False +c_unsetenv = error "c_unsetenv: !HAVE_UNSETENV" +c_unsetenv_void = error "c_unsetenv_void: !HAVE_UNSETENV" #endif +-- |The 'unsetEnv' function deletes all instances of the variable name +-- from the environment. + +unsetEnv :: Str -> IO () +unsetEnv name + | haveUnsetEnv && not unsetEnvReturnsVoid + = useAsOSString name $ \ s -> + throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s) + | haveUnsetEnv && unsetEnvReturnsVoid + = useAsOSString name c_unsetenv_void + | otherwise + = putEnv (append name (pack "=")) + -- |'putEnv' function takes an argument of the form @name=value@ -- and is equivalent to @setEnv(key,value,True{-overwrite-})@. -putEnv :: String -> IO () -putEnv keyvalue = do s <- newFilePath keyvalue +putEnv :: Str -> IO () +putEnv keyvalue = do s <- newOSString keyvalue -- Do not free `s` after calling putenv. -- According to SUSv2, the string passed to putenv -- becomes part of the environment. #7342 throwErrnoIfMinus1_ "putenv" (c_putenv s) -#if !MIN_VERSION_base(4,7,0) - where - newFilePath :: FilePath -> IO CString - newFilePath fp = getFileSystemEncoding >>= \enc -> GHC.newCString enc fp -#endif foreign import ccall unsafe "putenv" - c_putenv :: CString -> IO CInt + c_putenv :: OSString -> IO CInt {- |The 'setEnv' function inserts or resets the environment variable name in the current environment list. If the variable @name@ does not exist in the @@ -159,36 +184,51 @@ foreign import ccall unsafe "putenv" not reset, otherwise it is reset to the given value. -} -setEnv :: String -> String -> Bool {-overwrite-} -> IO () +haveSetEnv :: Bool +c_setenv :: OSString -> OSString -> CInt -> IO CInt #ifdef HAVE_SETENV -setEnv key value ovrwrt = do - withFilePath key $ \ keyP -> - withFilePath value $ \ valueP -> - throwErrnoIfMinus1_ "setenv" $ - c_setenv keyP valueP (fromIntegral (fromEnum ovrwrt)) - +haveSetEnv = True +c_setenv = c_setenv' foreign import ccall unsafe "setenv" - c_setenv :: CString -> CString -> CInt -> IO CInt + c_setenv' :: OSString -> OSString -> CInt -> IO CInt #else -setEnv key value True = putEnv (key++"="++value) -setEnv key value False = do - res <- getEnv key - case res of - Just _ -> return () - Nothing -> putEnv (key++"="++value) +haveSetEnv = False +c_setenv = error "c_setenv: !HAVE_SETENV" #endif --- |The 'clearEnv' function clears the environment of all name-value pairs. -clearEnv :: IO () +setEnv :: Str -> Str -> Bool {-overwrite-} -> IO () +setEnv key value ovrwrt + | haveSetEnv = do + useAsOSString key $ \ keyP -> + useAsOSString value $ \ valueP -> + throwErrnoIfMinus1_ "setenv" $ + c_setenv keyP valueP (fromIntegral (fromEnum ovrwrt)) + | otherwise = + case ovrwrt of + True -> putEnv (key `append` pack "=" `append` value) + False -> do + res <- getEnv key + case res of + Just _ -> return () + Nothing -> putEnv (key `append` pack "=" `append` value) + +haveClearEnv :: Bool +c_clearenv :: IO Int #if HAVE_CLEARENV -clearEnv = void c_clearenv - +haveClearEnv = True +c_clearenv = c_clearenv' foreign import ccall unsafe "clearenv" - c_clearenv :: IO Int + c_clearenv' :: IO Int #else +haveClearEnv = False +c_clearenv = error "c_clearenv: !HAVE_CLEARENV" +#endif + +-- |The 'clearEnv' function clears the environment of all name-value pairs. +clearEnv :: IO () +clearEnv | haveClearEnv = void c_clearenv -- Fallback to 'environ[0] = NULL'. -clearEnv = do + | otherwise = do c_environ <- getCEnviron unless (c_environ == nullPtr) $ poke c_environ nullPtr -#endif diff --git a/unix.cabal b/unix.cabal index 02d583e33165f1375477858cc95d2e55a72c2a7c..3f93edca4669fe5a85976b6e3169eb7e26c5003e 100644 --- a/unix.cabal +++ b/unix.cabal @@ -42,6 +42,42 @@ source-repository head type: git location: https://github.com/haskell/unix.git +library impls + default-language: Haskell2010 + build-depends: + base >= 4.5 && < 4.10, + time >= 1.2 && < 1.7, + bytestring >= 0.9.2 && < 0.11 + hs-source-dirs: impls + exposed-modules: + Str.String + Str.ByteString + +library unix-indef + ghc-options: -Wall + build-depends: + base >= 4.5 && < 4.10, + time >= 1.2 && < 1.7 + exposed-modules: + System.Posix.Env + hs-source-dirs: unix-indef + required-signatures: + Str + include-dirs: include + includes: + HsUnix.h + execvpe.h + other-extensions: + CApiFFI + CPP + DeriveDataTypeable + InterruptibleFFI + NondecreasingIndentation + RankNTypes + RecordWildCards + Safe + Trustworthy + library default-language: Haskell2010 other-extensions: @@ -64,7 +100,15 @@ library build-depends: base >= 4.5 && < 4.10, bytestring >= 0.9.2 && < 0.11, - time >= 1.2 && < 1.7 + time >= 1.2 && < 1.7, + impls, + unix-indef + + backpack-includes: + impls, + unix-indef requires (Str as Str.String), + unix-indef (System.Posix.Env as System.Posix.Env.ByteString) + requires (Str as Str.ByteString) exposed-modules: System.Posix @@ -97,9 +141,6 @@ library System.Posix.IO System.Posix.IO.ByteString - System.Posix.Env - System.Posix.Env.ByteString - System.Posix.Fcntl System.Posix.Process @@ -120,6 +161,10 @@ library System.Posix.Process.Common System.Posix.Terminal.Common + reexported-modules: + System.Posix.Env, + System.Posix.Env.ByteString + ghc-options: -Wall include-dirs: include