src/Distribution/Compat/Environment.hs

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE RankNTypes #-}
    {-# OPTIONS_HADDOCK hide #-}

    module Distribution.Compat.Environment
           ( getEnvironment, lookupEnv, setEnv, unsetEnv )
           where

    import Prelude ()
    import qualified Prelude
    import Distribution.Compat.Prelude

    #ifndef mingw32_HOST_OS
    #if __GLASGOW_HASKELL__ < 708
    import Foreign.C.Error (throwErrnoIf_)
    #endif
    #endif

    import qualified System.Environment as System
    import System.Environment (lookupEnv)
    #if __GLASGOW_HASKELL__ >= 708
    import System.Environment (unsetEnv)
    #endif

    import Distribution.Compat.Stack

    #ifdef mingw32_HOST_OS
    import Foreign.C
    #if __GLASGOW_HASKELL__ < 708
    import Foreign.Ptr (nullPtr)
    #endif
    import GHC.Windows
    #else
    import Foreign.C.Types
    import Foreign.C.String
    import Foreign.C.Error (throwErrnoIfMinus1_)
    import System.Posix.Internals ( withFilePath )
    #endif /* mingw32_HOST_OS */

    getEnvironment :: IO [(String, String)]
    #ifdef mingw32_HOST_OS
    -- On Windows, the names of environment variables are case-insensitive, but are
    -- often given in mixed-case (e.g. "PATH" is "Path"), so we have to normalise
    -- them.
    getEnvironment = fmap upcaseVars System.getEnvironment
      where
        upcaseVars = map upcaseVar
        upcaseVar (var, val) = (map toUpper var, val)
    #else
    getEnvironment = System.getEnvironment
    #endif

    -- | @setEnv name value@ sets the specified environment variable to @value@.
    --
    -- Throws `Control.Exception.IOException` if either @name@ or @value@ is the
    -- empty string or contains an equals sign.
    setEnv :: String -> String -> IO ()
    setEnv key value_ = setEnv_ key value
      where
        -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We
        -- still strip it manually so that the null check above succeeds if a value
        -- starts with NUL.
        value = takeWhile (/= '\NUL') value_

    setEnv_ :: String -> String -> IO ()

    #ifdef mingw32_HOST_OS

    setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do
      success <- c_SetEnvironmentVariable k v
      unless success (throwGetLastError "setEnv")
     where
      _ = callStack -- TODO: attach CallStack to exception

    # if defined(i386_HOST_ARCH)
    #  define WINDOWS_CCONV stdcall
    # elif defined(x86_64_HOST_ARCH)
    #  define WINDOWS_CCONV ccall
    # else
    #  error Unknown mingw32 arch
    # endif /* i386_HOST_ARCH */

    foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"
      c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> Prelude.IO Bool
    #else
    setEnv_ key value = do
      withFilePath key $ \ keyP ->
        withFilePath value $ \ valueP ->
          throwErrnoIfMinus1_ "setenv" $
            c_setenv keyP valueP (fromIntegral (fromEnum True))
     where
      _ = callStack -- TODO: attach CallStack to exception

    foreign import ccall unsafe "setenv"
       c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt
    #endif /* mingw32_HOST_OS */

    #if __GLASGOW_HASKELL__ < 708

    -- | @unsetEnv name@ removes the specified environment variable from the
    -- environment of the current process.
    --
    -- Throws `Control.Exception.IOException` if @name@ is the empty string or
    -- contains an equals sign.
    --
    -- @since 4.7.0.0
    unsetEnv :: String -> IO ()
    #ifdef mingw32_HOST_OS
    unsetEnv key = withCWString key $ \k -> do
      success <- c_SetEnvironmentVariable k nullPtr
      unless success $ do
        -- We consider unsetting an environment variable that does not exist not as
        -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND.
        err <- c_GetLastError
        unless (err == eRROR_ENVVAR_NOT_FOUND) $ do
          throwGetLastError "unsetEnv"

    eRROR_ENVVAR_NOT_FOUND :: DWORD
    eRROR_ENVVAR_NOT_FOUND = 203

    foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"
        c_GetLastError:: IO DWORD
    #else
    unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv)
    #if __GLASGOW_HASKELL__ > 706
    foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> Prelude.IO CInt
    #else
    -- HACK: We hope very hard that !UNSETENV_RETURNS_VOID
    foreign import ccall unsafe "unsetenv" c_unsetenv :: CString -> Prelude.IO CInt
    #endif
    #endif

    #endif