Backpack'ify System.Posix.Env.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

impls/Str/ByteString.hs

+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

impls/Str/String.hs

+{-# 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

unix-indef/Str.hsig

+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

System/Posix/Env.hsc → unix-indef/System/Posix/Env.hsc

+{-# 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

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