66 lines
2.4 KiB
Haskell
66 lines
2.4 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module PostgREST.Middleware where
|
|
|
|
import Data.Maybe (fromMaybe, isNothing)
|
|
import Data.Text
|
|
import Data.String.Conversions (cs)
|
|
import qualified Hasql as H
|
|
import qualified Hasql.Postgres as P
|
|
|
|
import Network.HTTP.Types.Header (hAccept, hAuthorization)
|
|
import Network.HTTP.Types.Status (status415)
|
|
import Network.Wai (Application, Request (..), Response,
|
|
requestHeaders, responseLBS)
|
|
import Network.Wai.Middleware.Cors (cors)
|
|
import Network.Wai.Middleware.Gzip (def, gzip)
|
|
import Network.Wai.Middleware.Static (only, staticPolicy)
|
|
|
|
import PostgREST.App (contentTypeForAccept)
|
|
import PostgREST.Auth (setRole, jwtClaims, claimsToSQL)
|
|
import PostgREST.Config (AppConfig (..), corsPolicy)
|
|
|
|
import Prelude hiding(concat)
|
|
|
|
import qualified Data.Vector as V
|
|
import qualified Hasql.Backend as B
|
|
import qualified Data.Map.Lazy as M
|
|
|
|
runWithClaims :: forall s. AppConfig ->
|
|
(Request -> H.Tx P.Postgres s Response) ->
|
|
Request -> H.Tx P.Postgres s Response
|
|
runWithClaims conf app req = do
|
|
mapM_ H.unitEx $ stmt <$> env
|
|
app req
|
|
where
|
|
stmt = (flip $ flip B.Stmt V.empty) True
|
|
hdrs = requestHeaders req
|
|
jwtSecret = (cs $ configJwtSecret conf) :: Text
|
|
auth = fromMaybe "" $ lookup hAuthorization hdrs
|
|
anon = cs $ configAnonRole conf
|
|
claims =
|
|
fromMaybe (M.fromList []) $
|
|
case split (==' ') (cs auth) of
|
|
("Bearer" : jwt : _) -> jwtClaims jwtSecret jwt
|
|
_ -> Nothing
|
|
env = if M.member "role" claims
|
|
then jwtEnv
|
|
else setRole anon : jwtEnv
|
|
jwtEnv = claimsToSQL claims
|
|
|
|
unsupportedAccept :: Application -> Application
|
|
unsupportedAccept app req respond = do
|
|
let
|
|
accept = lookup hAccept $ requestHeaders req
|
|
if isNothing $ contentTypeForAccept accept
|
|
then respond $ responseLBS status415 [] "Unsupported Accept header, try: application/json"
|
|
else app req respond
|
|
|
|
defaultMiddle :: Application -> Application
|
|
defaultMiddle =
|
|
gzip def
|
|
. cors corsPolicy
|
|
. staticPolicy (only [("favicon.ico", "static/favicon.ico")])
|
|
. unsupportedAccept
|