Make HTTP headers available as GUCs #800 (#849)

src/PostgREST/Middleware.hs

@@ -1,5 +1,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module PostgREST.Middleware where
 
@@ -15,10 +16,11 @@ import           Network.Wai.Middleware.Gzip   (def, gzip)
 import           Network.Wai.Middleware.Static (only, staticPolicy)
 
 import           PostgREST.ApiRequest          (ApiRequest(..))
-import           PostgREST.Auth                (claimsToSQL, JWTAttempt(..))
+import           PostgREST.Auth                (JWTAttempt(..))
 import           PostgREST.Config              (AppConfig (..), corsPolicy)
 import           PostgREST.Error               (simpleError)
 import           PostgREST.Types               (ContentType (..), toHeader)
+import           PostgREST.QueryBuilder        (pgFmtLit, unquoted, pgFmtEnvVar)
 
 import           Protolude                     hiding (concat, null)
 
@@ -31,14 +33,20 @@ runWithClaims conf eClaims app req =
     JWTInvalid -> return $ unauthed "JWT invalid"
     JWTMissingSecret -> return $ simpleError status500 "Server lacks JWT secret"
     JWTClaims claims -> do
-      -- role claim defaults to anon if not specified in jwt
-      let setClaims = claimsToSQL (M.union claims (M.singleton "role" anon))
-      H.sql $ mconcat setClaims
+      H.sql $ toS.mconcat $ setRoleSql ++ claimsSql ++ headersSql ++ cookiesSql
       mapM_ H.sql customReqCheck
       app req
+      where
+        headersSql = map (pgFmtEnvVar "request.header.") $ iHeaders req
+        cookiesSql = map (pgFmtEnvVar "request.cookie.") $ iCookies req
+        claimsSql = map (pgFmtEnvVar "request.jwt.claim.") [(c,unquoted v) | (c,v) <- M.toList claimsWithRole]
+        setRoleSql = maybeToList $
+          (\r -> "set local role " <> r <> ";") . toS . pgFmtLit . unquoted <$> M.lookup "role" claimsWithRole
+        -- role claim defaults to anon if not specified in jwt
+        claimsWithRole = M.union claims (M.singleton "role" anon)
+        anon = String . toS $ configAnonRole conf
+        customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf
   where
-    anon = String . toS $ configAnonRole conf
-    customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf
     unauthed message = responseLBS unauthorized401
       [ toHeader CTApplicationJSON
       , ( "WWW-Authenticate"