{-# language TemplateHaskell #-}
{-# options_ghc -Wno-unused-imports #-}
{-|
Include the value of an environment variable in the binary at compile time.

== Rationale
Users might want to embed secrets (e.g. API keys, database connection strings) inside production artifacts without checking these into the repository.

== Examples

NB : all library functions require the `TemplateHaskell` language extension.

=== Include a single variable

In this case, the name of the user's current shell) :

@
import IncludeEnv.TH (includeEnv)

$(`includeEnv` \"SHELL\" "shl")
shl :: String

main :: IO ()
main = putStrLn $ unwords ["your current shell :", shl]
@

=== Include a group of variables as a name-value map

@
import IncludeEnv.TH (includeEnvMap)

env = $(`includeEnvMap` [\"TERM\", \"USER\"])
@

@
>>> env
fromList [(\"TERM\","dumb"),(\"USER\","marco")]
@

-}
module IncludeEnv.TH (
  includeEnv
  , includeEnvLenient
  , includeEnvMaybe
  -- * containers
  , includeEnvMap
  ) where

import Control.Monad (foldM)

import System.Environment (lookupEnv)

-- containers
import qualified Data.Map.Strict as M (Map, lookup, insert, fromList)
-- template-haskell
import Language.Haskell.TH (runIO, runQ)
import Language.Haskell.TH.Syntax (Q, Exp(..), Dec(..), Pat(..), Name, mkName, Body(..), Lit(..), reportWarning)
import Language.Haskell.TH.Lib (valD)
-- th-lift-instances
import Instances.TH.Lift


-- | Include the value of an environment variable at compile time.
--
-- A fresh variable of type `String` is declared each time this is computation is evaluated.
--
-- Note : will crash with `error` if the environment variable is not found.
includeEnv :: String -- ^ name of environment variable to be looked up
           -> String -- ^ name of new value
           -> Q [Dec]
includeEnv :: String -> String -> Q [Dec]
includeEnv String
e String
varname = do
  Maybe String
mstr <- IO (Maybe String) -> Q (Maybe String)
forall a. IO a -> Q a
runIO (IO (Maybe String) -> Q (Maybe String))
-> IO (Maybe String) -> Q (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
e
  case Maybe String
mstr of
    Just String
str -> String -> String -> Q [Dec]
decl String
varname String
str
    Maybe String
Nothing -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"Cannot find variable", String
e, String
"in the environment."]
    where
      decl :: String -> String -> Q [Dec]
      decl :: String -> String -> Q [Dec]
decl String
n String
x = [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
dq] where
        dq :: Dec
dq = Pat -> Body -> [Dec] -> Dec
ValD Pat
qpat Body
qbody []
        qpat :: Pat
qpat = Name -> Pat
VarP (String -> Name
mkName String
n)
        qbody :: Body
qbody = Exp -> Body
NormalB (Lit -> Exp
LitE (String -> Lit
StringL String
x))

-- | Like 'includeEnv' but only prints a warning if the environment variable cannot be found.
--
-- NB : If the lookup fails, the declared value will contain an _empty string_ .
includeEnvLenient :: String -- ^ name of environment variable to be looked up
                  -> String -- ^ name of new value
                  -> Q [Dec]
includeEnvLenient :: String -> String -> Q [Dec]
includeEnvLenient String
e String
varname = do
  Maybe String
mstr <- IO (Maybe String) -> Q (Maybe String)
forall a. IO a -> Q a
runIO (IO (Maybe String) -> Q (Maybe String))
-> IO (Maybe String) -> Q (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
e
  case Maybe String
mstr of
    Just String
str -> String -> String -> Q [Dec]
decl String
varname String
str
    Maybe String
Nothing -> do
      String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"*** WARNING : Cannot find variable", String
e, String
"in the environment."]
      String -> String -> Q [Dec]
decl String
varname String
""
    where
      decl :: String -> String -> Q [Dec]
      decl :: String -> String -> Q [Dec]
decl String
n String
x = [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
dq] where
        dq :: Dec
dq = Pat -> Body -> [Dec] -> Dec
ValD Pat
qpat Body
qbody []
        qpat :: Pat
qpat = Name -> Pat
VarP (String -> Name
mkName String
n)
        qbody :: Body
qbody = Exp -> Body
NormalB (Lit -> Exp
LitE (String -> Lit
StringL String
x))

-- | Like 'includeEnv' but produces a 'Maybe String'
--
-- Use case : The program needs to be compiled against two different environments that may have different sets of environment variables. 'includeEnvMaybe' lets you account for the results of multiple such lookups at runtime.
--
-- @since 0.4.0.0
includeEnvMaybe :: String -- ^ name of environment variable to be looked up
                -> Q Exp
includeEnvMaybe :: String -> Q Exp
includeEnvMaybe String
e = do
  Maybe String
mstr <- IO (Maybe String) -> Q (Maybe String)
forall a. IO a -> Q a
runIO (IO (Maybe String) -> Q (Maybe String))
-> IO (Maybe String) -> Q (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
e
  [| mstr |]

-- | Lookup a number of environment variables and populate a 'M.Map' with the result
--
-- NB: if a variable name cannot be found, the corresponding entry will be missing
--
-- @since 0.5.0.0
includeEnvMap :: Foldable t =>
                 t String -- ^ names of environment variable to be looked up
              -> Q Exp
includeEnvMap :: t String -> Q Exp
includeEnvMap t String
es = do
  Map String String
mm <- (Map String String -> String -> Q (Map String String))
-> Map String String -> t String -> Q (Map String String)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map String String -> String -> Q (Map String String)
insf Map String String
forall a. Monoid a => a
mempty t String
es
  [| mm |]
  where
    insf :: Map String String -> String -> Q (Map String String)
insf Map String String
acc String
k = do
      Maybe String
mv <- IO (Maybe String) -> Q (Maybe String)
forall a. IO a -> Q a
runIO (IO (Maybe String) -> Q (Maybe String))
-> IO (Maybe String) -> Q (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
k
      case Maybe String
mv of
        Maybe String
Nothing -> Map String String -> Q (Map String String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map String String
acc
        Just String
v -> Map String String -> Q (Map String String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map String String -> Q (Map String String))
-> Map String String -> Q (Map String String)
forall a b. (a -> b) -> a -> b
$ String -> String -> Map String String -> Map String String
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
k String
v Map String String
acc