{-# 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.

== Example

@
import IncludeEnv.TH (includeEnv)

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

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

-}
module IncludeEnv.TH (includeEnv) where

import System.Environment (lookupEnv)

-- template-haskell
import Language.Haskell.TH (runIO, runQ)
import Language.Haskell.TH.Syntax (Q, Exp(..), Dec(..), Pat(..), Name, mkName, Body(..), Lit(..))
import Language.Haskell.TH.Lib (valD)


-- | Include the value of an environment variable at compile time
--
-- A fresh variable is declared each time this is computation is evaluated
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))