Allow Windows to set blank environment variables
authorHabib Alamin <ha.alamin@gmail.com>
Mon, 31 Jul 2017 04:48:43 +0000 (05:48 +0100)
committerTamar Christina <tamar@zhox.com>
Mon, 31 Jul 2017 04:50:52 +0000 (05:50 +0100)
Test Plan: ./validate on harbormaster

Reviewers: austin, hvr, bgamari, erikd, Phyx

Reviewed By: Phyx

Subscribers: Phyx, rwbarton, thomie

GHC Trac Issues: #12494

Differential Revision: https://phabricator.haskell.org/D3726

docs/users_guide/8.4.1-notes.rst
libraries/base/System/Environment.hs
libraries/base/System/Environment/Blank.hsc [new file with mode: 0644]
libraries/base/base.cabal
libraries/base/tests/T12494.hs [new file with mode: 0644]
libraries/base/tests/T12494.stdout [new file with mode: 0644]
libraries/base/tests/all.T

index 67cd7f0..d3cef24 100644 (file)
@@ -146,3 +146,9 @@ Template Haskell
       #endif
 
   can be used.
+
+``base`` library
+~~~~~~~~~~~~~~~~
+
+- Blank strings can now be used as values for environment variables using the
+  System.Environment.Blank module. See :ghc-ticket:`12494`
index ff08546..343b772 100644 (file)
@@ -190,9 +190,10 @@ ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv"
 
 -- | @setEnv name value@ sets the specified environment variable to @value@.
 --
--- On Windows setting an environment variable to the /empty string/ removes
+-- Early versions of this function operated under the mistaken belief that
+-- setting an environment variable to the /empty string/ on Windows removes
 -- that environment variable from the environment.  For the sake of
--- compatibility we adopt that behavior.  In particular
+-- compatibility, it adopted that behavior on POSIX.  In particular
 --
 -- @
 -- setEnv name \"\"
@@ -204,9 +205,8 @@ ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv"
 -- `unsetEnv` name
 -- @
 --
--- If you don't care about Windows support and want to set an environment
--- variable to the empty string use @System.Posix.Env.setEnv@ from the @unix@
--- package instead.
+-- If you'd like to be able to set environment variables to blank strings,
+-- use `System.Environment.Blank.setEnv`.
 --
 -- Throws `Control.Exception.IOException` if @name@ is the empty string or
 -- contains an equals sign.
diff --git a/libraries/base/System/Environment/Blank.hsc b/libraries/base/System/Environment/Blank.hsc
new file mode 100644 (file)
index 0000000..ebca1ef
--- /dev/null
@@ -0,0 +1,196 @@
+{-# LANGUAGE Safe #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE CApiFFI #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Environment.Blank
+-- Copyright   :  (c) Habib Alamin 2017
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- A setEnv implementation that allows blank environment variables. Mimics
+-- the `System.Posix.Env` module from the @unix@ package, but with support
+-- for Windows too.
+--
+-- The matrix of platforms that:
+--
+--   * support putenv("FOO") to unset environment variables,
+--   * support putenv("FOO=") to unset environment variables or set them
+--     to blank values,
+--   * support unsetenv to unset environment variables,
+--   * support setenv to set environment variables,
+--   * etc.
+--
+-- is very complicated. I think AIX is screwed, but we don't support it.
+-- The whole situation with setenv(3), unsetenv(3), and putenv(3) is not
+-- good. Even mingw32 adds its own crap to the pile, but luckily, we can
+-- just use Windows' native environment functions to sidestep the issue.
+--
+-- #12494
+--
+-----------------------------------------------------------------------------
+
+module System.Environment.Blank
+    (
+      module System.Environment,
+      getEnv,
+      getEnvDefault,
+      setEnv,
+      unsetEnv,
+  ) where
+
+import Foreign.C
+#ifdef mingw32_HOST_OS
+import Foreign.Ptr
+import GHC.Windows
+import Control.Monad
+#else
+import System.Posix.Internals
+#endif
+import GHC.IO.Exception
+import System.IO.Error
+import Control.Exception.Base
+import Data.Maybe
+
+import System.Environment
+    (
+      getArgs,
+      getProgName,
+      getExecutablePath,
+      withArgs,
+      withProgName,
+      getEnvironment
+  )
+#ifndef mingw32_HOST_OS
+import qualified System.Environment as Environment
+#endif
+
+-- TODO: include windows_cconv.h when it's merged, instead of duplicating
+-- this C macro block.
+#if defined(mingw32_HOST_OS)
+# 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
+#endif
+
+#include "HsBaseConfig.h"
+
+throwInvalidArgument :: String -> IO a
+throwInvalidArgument from =
+  throwIO (mkIOError InvalidArgument from Nothing Nothing)
+
+-- | `System.Environment.lookupEnv`.
+getEnv :: String -> IO (Maybe String)
+#ifdef mingw32_HOST_OS
+getEnv = (<$> getEnvironment) . lookup
+#else
+getEnv = Environment.lookupEnv
+#endif
+
+-- | Get an environment value or a default value.
+getEnvDefault ::
+  String    {- ^ variable name                    -} ->
+  String    {- ^ fallback value                   -} ->
+  IO String {- ^ variable value or fallback value -}
+getEnvDefault name fallback = fromMaybe fallback <$> getEnv name
+
+-- | Like `System.Environment.setEnv`, but allows blank environment values
+-- and mimics the function signature of `System.Posix.Env.setEnv` from the
+-- @unix@ package.
+setEnv ::
+  String {- ^ variable name  -} ->
+  String {- ^ variable value -} ->
+  Bool   {- ^ overwrite      -} ->
+  IO ()
+setEnv key_ value_ overwrite
+  | null key       = throwInvalidArgument "setEnv"
+  | '=' `elem` key = throwInvalidArgument "setEnv"
+  | otherwise      =
+    if overwrite
+    then setEnv_ key value
+    else do
+      env_var <- getEnv key
+      case env_var of
+          Just _  -> return ()
+          Nothing -> setEnv_ key value
+  where
+    key   = takeWhile (/= '\NUL') key_
+    value = takeWhile (/= '\NUL') value_
+
+setEnv_ :: String -> String -> IO ()
+#if defined(mingw32_HOST_OS)
+setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do
+  success <- c_SetEnvironmentVariable k v
+  unless success (throwGetLastError "setEnv")
+
+foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"
+  c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool
+#else
+setEnv_ key value =
+  withFilePath key $ \ keyP ->
+    withFilePath value $ \ valueP ->
+      throwErrnoIfMinus1_ "setenv" $
+        c_setenv keyP valueP (fromIntegral (fromEnum True))
+
+foreign import ccall unsafe "setenv"
+   c_setenv :: CString -> CString -> CInt -> IO CInt
+#endif
+
+-- | Like `System.Environment.unsetEnv`, but allows for the removal of
+-- blank environment variables.
+unsetEnv :: String -> IO ()
+#if defined(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
+#elif HAVE_UNSETENV
+# if !UNSETENV_RETURNS_VOID
+unsetEnv name = withFilePath name $ \ s ->
+  throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s)
+
+-- POSIX.1-2001 compliant unsetenv(3)
+foreign import capi unsafe "HsBase.h unsetenv"
+   c_unsetenv :: CString -> IO CInt
+# else
+unsetEnv name = withFilePath name c_unsetenv
+
+-- pre-POSIX unsetenv(3) returning @void@
+foreign import capi unsafe "HsBase.h unsetenv"
+   c_unsetenv :: CString -> IO ()
+# endif
+#else
+unsetEnv name =
+  if '=' `elem` name
+  then throwInvalidArgument "unsetEnv"
+  else putEnv name
+
+putEnv :: String -> IO ()
+putEnv keyvalue = do
+  s <- getFileSystemEncoding >>= (`newCString` keyvalue)
+  -- IMPORTANT: Do not free `s` after calling putenv!
+  --
+  -- According to SUSv2, the string passed to putenv becomes part of the
+  -- environment. #7342
+  throwErrnoIf_ (/= 0) "putenv" (c_putenv s)
+
+foreign import ccall unsafe "putenv" c_putenv :: CString -> IO CInt
+#endif
index 9429de0..4bbe2f2 100644 (file)
@@ -289,6 +289,7 @@ Library
         System.CPUTime
         System.Console.GetOpt
         System.Environment
+        System.Environment.Blank
         System.Exit
         System.IO
         System.IO.Error
diff --git a/libraries/base/tests/T12494.hs b/libraries/base/tests/T12494.hs
new file mode 100644 (file)
index 0000000..544f5ed
--- /dev/null
@@ -0,0 +1,36 @@
+import System.Environment.Blank
+
+main = do
+  let envVar = "AN_ENVIRONMENT_VARIABLE"
+
+  valueBeforeSettingVariable <- getEnv envVar
+  print valueBeforeSettingVariable -- Nothing
+
+  valueWithDefaultBeforeSetting <- getEnvDefault envVar "DEFAULT"
+  print valueWithDefaultBeforeSetting -- "DEFAULT"
+
+  setEnv envVar "" False
+
+  valueAfterSettingVariable <- getEnv envVar
+  print valueAfterSettingVariable -- Just ""
+
+  valueWithDefaultAfterSetting <- getEnvDefault envVar "DEFAULT"
+  print valueWithDefaultAfterSetting -- ""
+
+  valueFromGetEnvironment <- lookup envVar <$> getEnvironment
+  print valueFromGetEnvironment -- Just ""
+
+  setEnv envVar "NO_OVERRIDE" False
+
+  valueAfterSettingWithExistingValueAndOverrideFalse <- getEnv envVar
+  print valueAfterSettingWithExistingValueAndOverrideFalse -- Just ""
+
+  setEnv envVar "OVERRIDE" True
+
+  valueAfterSettingWithExistingValueAndOverrideTrue <- getEnv envVar
+  print valueAfterSettingWithExistingValueAndOverrideTrue -- Just "OVERRIDE"
+
+  unsetEnv envVar
+
+  valueAfterUnsettingVariable <- getEnv envVar
+  print valueAfterUnsettingVariable -- Nothing
diff --git a/libraries/base/tests/T12494.stdout b/libraries/base/tests/T12494.stdout
new file mode 100644 (file)
index 0000000..a3b77cc
--- /dev/null
@@ -0,0 +1,8 @@
+Nothing
+"DEFAULT"
+Just ""
+""
+Just ""
+Just ""
+Just "OVERRIDE"
+Nothing
index b52a5d9..d97d79a 100644 (file)
@@ -201,6 +201,7 @@ test('T9848',
 test('T10149', normal, compile_and_run, [''])
 test('T11334a', normal, compile_and_run, [''])
 test('T11555', normal, compile_and_run, [''])
+test('T12494', normal, compile_and_run, [''])
 test('T12852', when(opsys('mingw32'), skip), compile_and_run, [''])
 test('lazySTexamples', normal, compile_and_run, [''])
 test('T11760', normal, compile_and_run, ['-threaded -with-rtsopts=-N2'])