System/Environment.hs

    {-# LANGUAGE Safe #-}
    {-# LANGUAGE CPP #-}

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  System.Environment
    -- Copyright   :  (c) The University of Glasgow 2001
    -- License     :  BSD-style (see the file libraries/base/LICENSE)
    --
    -- Maintainer  :  libraries@haskell.org
    -- Stability   :  provisional
    -- Portability :  portable
    --
    -- Miscellaneous information about the system environment.
    --
    -----------------------------------------------------------------------------

    module System.Environment
        (
          getArgs,
          getProgName,
          getExecutablePath,
          getEnv,
          lookupEnv,
          setEnv,
          unsetEnv,
          withArgs,
          withProgName,
          getEnvironment,
      ) where

    import Foreign
    import Foreign.C
    import System.IO.Error (mkIOError)
    import Control.Exception.Base (bracket_, throwIO)
    #ifdef mingw32_HOST_OS
    import Control.Exception.Base (bracket)
    #endif
    -- import GHC.IO
    import GHC.IO.Exception
    import GHC.IO.Encoding (getFileSystemEncoding)
    import qualified GHC.Foreign as GHC
    import Control.Monad
    #ifdef mingw32_HOST_OS
    import GHC.Environment
    import GHC.Windows
    #else
    import System.Posix.Internals (withFilePath)
    #endif

    import System.Environment.ExecutablePath

    #ifdef 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"

    -- ---------------------------------------------------------------------------
    -- getArgs, getProgName, getEnv

    #ifdef mingw32_HOST_OS

    {-
    Note [Ignore hs_init argv]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
    Ignore the arguments to hs_init on Windows for the sake of Unicode compat

    Instead on Windows we get the list of arguments from getCommandLineW and
    filter out arguments which the RTS would not have passed along.

    This is done to ensure we get the arguments in proper Unicode Encoding which
    the RTS at this moment does not seem provide. The filtering has to match the
    one done by the RTS to avoid inconsistencies like #13287.
    -}

    getWin32ProgArgv_certainly :: IO [String]
    getWin32ProgArgv_certainly = do
            mb_argv <- getWin32ProgArgv
            case mb_argv of
              -- see Note [Ignore hs_init argv]
              Nothing   -> fmap dropRTSArgs getFullArgs
              Just argv -> return argv

    withWin32ProgArgv :: [String] -> IO a -> IO a
    withWin32ProgArgv argv act = bracket begin setWin32ProgArgv (\_ -> act)
      where
        begin = do
              mb_old_argv <- getWin32ProgArgv
              setWin32ProgArgv (Just argv)
              return mb_old_argv

    getWin32ProgArgv :: IO (Maybe [String])
    getWin32ProgArgv = alloca $ \p_argc -> alloca $ \p_argv -> do
            c_getWin32ProgArgv p_argc p_argv
            argc <- peek p_argc
            argv_p <- peek p_argv
            if argv_p == nullPtr
             then return Nothing
             else do
              argv_ps <- peekArray (fromIntegral argc) argv_p
              fmap Just $ mapM peekCWString argv_ps

    setWin32ProgArgv :: Maybe [String] -> IO ()
    setWin32ProgArgv Nothing = c_setWin32ProgArgv 0 nullPtr
    setWin32ProgArgv (Just argv) = withMany withCWString argv $ \argv_ps -> withArrayLen argv_ps $ \argc argv_p -> do
            c_setWin32ProgArgv (fromIntegral argc) argv_p

    foreign import ccall unsafe "getWin32ProgArgv"
      c_getWin32ProgArgv :: Ptr CInt -> Ptr (Ptr CWString) -> IO ()

    foreign import ccall unsafe "setWin32ProgArgv"
      c_setWin32ProgArgv :: CInt -> Ptr CWString -> IO ()

    -- See Note [Ignore hs_init argv]
    dropRTSArgs :: [String] -> [String]
    dropRTSArgs []             = []
    dropRTSArgs rest@("--":_)  = rest
    dropRTSArgs ("+RTS":rest)  = dropRTSArgs (dropWhile (/= "-RTS") rest)
    dropRTSArgs ("--RTS":rest) = rest
    dropRTSArgs ("-RTS":rest)  = dropRTSArgs rest
    dropRTSArgs (arg:rest)     = arg : dropRTSArgs rest

    #endif

    -- | Computation 'getArgs' returns a list of the program's command
    -- line arguments (not including the program name).
    getArgs :: IO [String]

    #ifdef mingw32_HOST_OS
    getArgs =  fmap tail getWin32ProgArgv_certainly
    #else
    getArgs =
      alloca $ \ p_argc ->
      alloca $ \ p_argv -> do
       getProgArgv p_argc p_argv
       p    <- fromIntegral `liftM` peek p_argc
       argv <- peek p_argv
       enc <- getFileSystemEncoding
       peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString enc)

    foreign import ccall unsafe "getProgArgv"
      getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
    #endif

    {-|
    Computation 'getProgName' returns the name of the program as it was
    invoked.

    However, this is hard-to-impossible to implement on some non-Unix
    OSes, so instead, for maximum portability, we just return the leafname
    of the program as invoked. Even then there are some differences
    between platforms: on Windows, for example, a program invoked as foo
    is probably really @FOO.EXE@, and that is what 'getProgName' will return.
    -}
    getProgName :: IO String
    #ifdef mingw32_HOST_OS
    -- Ignore the arguments to hs_init on Windows for the sake of Unicode compat
    getProgName = fmap (basename . head) getWin32ProgArgv_certainly
    #else
    getProgName =
      alloca $ \ p_argc ->
      alloca $ \ p_argv -> do
         getProgArgv p_argc p_argv
         argv <- peek p_argv
         unpackProgName argv

    unpackProgName  :: Ptr (Ptr CChar) -> IO String   -- argv[0]
    unpackProgName argv = do
      enc <- getFileSystemEncoding
      s <- peekElemOff argv 0 >>= GHC.peekCString enc
      return (basename s)
    #endif

    basename :: FilePath -> FilePath
    basename f = go f f
     where
      go acc [] = acc
      go acc (x:xs)
        | isPathSeparator x = go xs xs
        | otherwise         = go acc xs

      isPathSeparator :: Char -> Bool
      isPathSeparator '/'  = True
    #ifdef mingw32_HOST_OS
      isPathSeparator '\\' = True
    #endif
      isPathSeparator _    = False

    -- | Computation 'getEnv' @var@ returns the value
    -- of the environment variable @var@. For the inverse, POSIX users
    -- can use 'System.Posix.Env.putEnv'.
    --
    -- This computation may fail with:
    --
    --  * 'System.IO.Error.isDoesNotExistError' if the environment variable
    --    does not exist.

    getEnv :: String -> IO String
    getEnv name = lookupEnv name >>= maybe handleError return
      where
    #ifdef mingw32_HOST_OS
        handleError = do
            err <- c_GetLastError
            if err == eRROR_ENVVAR_NOT_FOUND
                then ioe_missingEnvVar name
                else throwGetLastError "getEnv"

    eRROR_ENVVAR_NOT_FOUND :: DWORD
    eRROR_ENVVAR_NOT_FOUND = 203

    foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"
      c_GetLastError:: IO DWORD

    #else
        handleError = ioe_missingEnvVar name
    #endif

    -- | Return the value of the environment variable @var@, or @Nothing@ if
    -- there is no such value.
    --
    -- For POSIX users, this is equivalent to 'System.Posix.Env.getEnv'.
    --
    -- @since 4.6.0.0
    lookupEnv :: String -> IO (Maybe String)
    #ifdef mingw32_HOST_OS
    lookupEnv name = withCWString name $ \s -> try_size s 256
      where
        try_size s size = allocaArray (fromIntegral size) $ \p_value -> do
          res <- c_GetEnvironmentVariable s p_value size
          case res of
            0 -> return Nothing
            _ | res > size -> try_size s res -- Rare: size increased between calls to GetEnvironmentVariable
              | otherwise  -> peekCWString p_value >>= return . Just

    foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentVariableW"
      c_GetEnvironmentVariable :: LPWSTR -> LPWSTR -> DWORD -> IO DWORD
    #else
    lookupEnv name =
        withCString name $ \s -> do
          litstring <- c_getenv s
          if litstring /= nullPtr
            then do enc <- getFileSystemEncoding
                    result <- GHC.peekCString enc litstring
                    return $ Just result
            else return Nothing

    foreign import ccall unsafe "getenv"
       c_getenv :: CString -> IO (Ptr CChar)
    #endif

    ioe_missingEnvVar :: String -> IO a
    ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv"
        "no environment variable" Nothing (Just name))

    -- | @setEnv name value@ sets the specified environment variable to @value@.
    --
    -- On Windows setting an environment variable to the /empty string/ removes
    -- that environment variable from the environment.  For the sake of
    -- compatibility we adopt that behavior.  In particular
    --
    -- @
    -- setEnv name \"\"
    -- @
    --
    -- has the same effect as
    --
    -- @
    -- `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.
    --
    -- Throws `Control.Exception.IOException` if @name@ is the empty string or
    -- contains an equals sign.
    --
    -- @since 4.7.0.0
    setEnv :: String -> String -> IO ()
    setEnv key_ value_
      | null key       = throwIO (mkIOError InvalidArgument "setEnv" Nothing Nothing)
      | '=' `elem` key = throwIO (mkIOError InvalidArgument "setEnv" Nothing Nothing)
      | null value     = unsetEnv key
      | otherwise      = setEnv_ key value
      where
        key   = takeWhile (/= '\NUL') key_
        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")

    foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"
      c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool
    #else

    -- NOTE: The 'setenv()' function is not available on all systems, hence we use
    -- 'putenv()'.  This leaks memory, but so do common implementations of
    -- 'setenv()' (AFAIK).
    setEnv_ k v = putEnv (k ++ "=" ++ v)

    putEnv :: String -> IO ()
    putEnv keyvalue = do
      s <- getFileSystemEncoding >>= (`GHC.newCString` keyvalue)
      -- IMPORTANT: Do not free `s` after calling putenv!
      --
      -- According to SUSv2, the string passed to putenv becomes part of the
      -- environment.
      throwErrnoIf_ (/= 0) "putenv" (c_putenv s)

    foreign import ccall unsafe "putenv" c_putenv :: CString -> IO CInt
    #endif

    -- | @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"
    #else

    #ifdef HAVE_UNSETENV
    unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv)
    foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> IO CInt
    #else
    unsetEnv key = setEnv_ key ""
    #endif

    #endif

    {-|
    'withArgs' @args act@ - while executing action @act@, have 'getArgs'
    return @args@.
    -}
    withArgs :: [String] -> IO a -> IO a
    withArgs xs act = do
       p <- System.Environment.getProgName
       withArgv (p:xs) act

    {-|
    'withProgName' @name act@ - while executing action @act@,
    have 'getProgName' return @name@.
    -}
    withProgName :: String -> IO a -> IO a
    withProgName nm act = do
       xs <- System.Environment.getArgs
       withArgv (nm:xs) act

    -- Worker routine which marshals and replaces an argv vector for
    -- the duration of an action.

    withArgv :: [String] -> IO a -> IO a

    #ifdef mingw32_HOST_OS
    -- We have to reflect the updated arguments in the RTS-side variables as
    -- well, because the RTS still consults them for error messages and the like.
    -- If we don't do this then ghc-e005 fails.
    withArgv new_args act = withWin32ProgArgv new_args $ withProgArgv new_args act
    #else
    withArgv = withProgArgv
    #endif

    withProgArgv :: [String] -> IO a -> IO a
    withProgArgv new_args act = do
      pName <- System.Environment.getProgName
      existing_args <- System.Environment.getArgs
      bracket_ (setProgArgv new_args)
               (setProgArgv (pName:existing_args))
               act

    setProgArgv :: [String] -> IO ()
    setProgArgv argv = do
      enc <- getFileSystemEncoding
      GHC.withCStringsLen enc argv $ \len css ->
        c_setProgArgv (fromIntegral len) css

    -- setProgArgv copies the arguments
    foreign import ccall unsafe "setProgArgv"
      c_setProgArgv  :: CInt -> Ptr CString -> IO ()

    -- |'getEnvironment' retrieves the entire environment as a
    -- list of @(key,value)@ pairs.
    --
    -- If an environment entry does not contain an @\'=\'@ character,
    -- the @key@ is the whole entry and the @value@ is the empty string.
    getEnvironment :: IO [(String, String)]

    #ifdef mingw32_HOST_OS
    getEnvironment = bracket c_GetEnvironmentStrings c_FreeEnvironmentStrings $ \pBlock ->
        if pBlock == nullPtr then return []
         else go pBlock
      where
        go pBlock = do
            -- The block is terminated by a null byte where there
            -- should be an environment variable of the form X=Y
            c <- peek pBlock
            if c == 0 then return []
             else do
              -- Seek the next pair (or terminating null):
              pBlock' <- seekNull pBlock False
              -- We now know the length in bytes, but ignore it when
              -- getting the actual String:
              str <- peekCWString pBlock
              fmap (divvy str :) $ go pBlock'

        -- Returns pointer to the byte *after* the next null
        seekNull pBlock done = do
            let pBlock' = pBlock `plusPtr` sizeOf (undefined :: CWchar)
            if done then return pBlock'
             else do
               c <- peek pBlock'
               seekNull pBlock' (c == (0 :: Word8 ))

    foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentStringsW"
      c_GetEnvironmentStrings :: IO (Ptr CWchar)

    foreign import WINDOWS_CCONV unsafe "windows.h FreeEnvironmentStringsW"
      c_FreeEnvironmentStrings :: Ptr CWchar -> IO Bool
    #else
    getEnvironment = do
       pBlock <- getEnvBlock
       if pBlock == nullPtr then return []
        else do
          enc <- getFileSystemEncoding
          stuff <- peekArray0 nullPtr pBlock >>= mapM (GHC.peekCString enc)
          return (map divvy stuff)

    foreign import ccall unsafe "__hscore_environ"
      getEnvBlock :: IO (Ptr CString)
    #endif

    divvy :: String -> (String, String)
    divvy str =
      case break (=='=') str of
        (xs,[])        -> (xs,[]) -- don't barf (like Posix.getEnvironment)
        (name,_:value) -> (name,value)