Cabal/src/Distribution/Compat/Environment.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE RankNTypes #-}
   4 {-# OPTIONS_HADDOCK hide #-}
   5
   6 module Distribution.Compat.Environment (getEnvironment, lookupEnv, setEnv, unsetEnv)
   7 where
   8
   9 import Distribution.Compat.Prelude
  10 import Prelude ()
  11 import qualified Prelude
  12
  13 import System.Environment (lookupEnv, unsetEnv)
  14 import qualified System.Environment as System
  15
  16 import Distribution.Compat.Stack
  17
  18 #ifdef mingw32_HOST_OS
  19 import Foreign.C
  20 import GHC.Windows
  21 #else
  22 import Foreign.C.Types
  23 import Foreign.C.String
  24 import Foreign.C.Error (throwErrnoIfMinus1_)
  25 import System.Posix.Internals ( withFilePath )
  26 #endif /* mingw32_HOST_OS */
  27
  28 getEnvironment :: IO [(String, String)]
  29 #ifdef mingw32_HOST_OS
  30 -- On Windows, the names of environment variables are case-insensitive, but are
  31 -- often given in mixed-case (e.g. "PATH" is "Path"), so we have to normalise
  32 -- them.
  33 getEnvironment = fmap upcaseVars System.getEnvironment
  34   where
  35     upcaseVars = map upcaseVar
  36     upcaseVar (var, val) = (map toUpper var, val)
  37 #else
  38 getEnvironment = System.getEnvironment
  39 #endif
  40
  41 -- | @setEnv name value@ sets the specified environment variable to @value@.
  42 --
  43 -- Throws `Control.Exception.IOException` if either @name@ or @value@ is the
  44 -- empty string or contains an equals sign.
  45 setEnv :: String -> String -> IO ()
  46 setEnv key value_ = setEnv_ key value
  47   where
  48     -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We
  49     -- still strip it manually so that the null check above succeeds if a value
  50     -- starts with NUL.
  51     value = takeWhile (/= '\NUL') value_
  52
  53 setEnv_ :: String -> String -> IO ()
  54
  55 #ifdef mingw32_HOST_OS
  56
  57 setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do
  58   success <- c_SetEnvironmentVariable k v
  59   unless success (throwGetLastError "setEnv")
  60  where
  61   _ = callStack -- TODO: attach CallStack to exception
  62
  63 {- FOURMOLU_DISABLE -}
  64 # if defined(i386_HOST_ARCH)
  65 #  define WINDOWS_CCONV stdcall
  66 # elif defined(x86_64_HOST_ARCH)
  67 #  define WINDOWS_CCONV ccall
  68 # else
  69 #  error Unknown mingw32 arch
  70 # endif /* i386_HOST_ARCH */
  71
  72 foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"
  73   c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> Prelude.IO Bool
  74 #else
  75 setEnv_ key value = do
  76   withFilePath key $ \ keyP ->
  77     withFilePath value $ \ valueP ->
  78       throwErrnoIfMinus1_ "setenv" $
  79         c_setenv keyP valueP (fromIntegral (fromEnum True))
  80  where
  81   _ = callStack -- TODO: attach CallStack to exception
  82
  83 foreign import ccall unsafe "setenv"
  84    c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt
  85 #endif /* mingw32_HOST_OS */
  86 {- FOURMOLU_ENABLE -}