{-|
Module      : PostgREST.Middleware
Description : Sets CORS policy. Also the PostgreSQL GUCs, role, search_path and pre-request function.
-}
{-# LANGUAGE RecordWildCards #-}
module PostgREST.Middleware
  ( runPgLocals
  , pgrstFormat
  , pgrstMiddleware
  , defaultCorsPolicy
  , corsPolicy
  , optionalRollback
  ) where

import qualified Data.Aeson                           as JSON
import qualified Data.ByteString.Char8                as BS
import qualified Data.CaseInsensitive                 as CI
import qualified Data.HashMap.Strict                  as M
import qualified Data.Text                            as T
import qualified Hasql.Decoders                       as HD
import qualified Hasql.DynamicStatements.Snippet      as H hiding
                                                           (sql)
import qualified Hasql.DynamicStatements.Statement    as H
import qualified Hasql.Transaction                    as H
import qualified Network.HTTP.Types.Header            as HTTP
import qualified Network.Wai                          as Wai
import qualified Network.Wai.Logger                   as Wai
import qualified Network.Wai.Middleware.Cors          as Wai
import qualified Network.Wai.Middleware.Gzip          as Wai
import qualified Network.Wai.Middleware.RequestLogger as Wai
import qualified Network.Wai.Middleware.Static        as Wai

import Data.Function             (id)
import Data.List                 (lookup)
import Data.Scientific           (FPFormat (..), formatScientific,
                                  isInteger)
import Network.HTTP.Types.Status (Status, status400, status500,
                                  statusCode)
import System.IO.Unsafe          (unsafePerformIO)
import System.Log.FastLogger     (toLogStr)

import PostgREST.Config             (AppConfig (..), LogLevel (..))
import PostgREST.Error              (Error, errorResponseFor)
import PostgREST.GucHeader          (addHeadersIfNotIncluded)
import PostgREST.Query.SqlFragment  (fromQi, intercalateSnippet,
                                     unknownEncoder)
import PostgREST.Request.ApiRequest (ApiRequest (..), Target (..))

import PostgREST.Request.Preferences

import Protolude      hiding (head, toS)
import Protolude.Conv (toS)

-- | Runs local(transaction scoped) GUCs for every request, plus the pre-request function
runPgLocals :: AppConfig   -> M.HashMap Text JSON.Value ->
               (ApiRequest -> ExceptT Error H.Transaction Wai.Response) ->
               ApiRequest  -> ByteString -> ExceptT Error H.Transaction Wai.Response
runPgLocals :: AppConfig
-> HashMap Text Value
-> (ApiRequest -> ExceptT Error Transaction Response)
-> ApiRequest
-> ByteString
-> ExceptT Error Transaction Response
runPgLocals AppConfig
conf HashMap Text Value
claims ApiRequest -> ExceptT Error Transaction Response
app ApiRequest
req ByteString
jsonDbS = do
  Transaction () -> ExceptT Error Transaction ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction () -> ExceptT Error Transaction ())
-> Transaction () -> ExceptT Error Transaction ()
forall a b. (a -> b) -> a -> b
$ () -> Statement () () -> Transaction ()
forall a b. a -> Statement a b -> Transaction b
H.statement ()
forall a. Monoid a => a
mempty (Statement () () -> Transaction ())
-> Statement () () -> Transaction ()
forall a b. (a -> b) -> a -> b
$ Snippet -> Result () -> Bool -> Statement () ()
forall result.
Snippet -> Result result -> Bool -> Statement () result
H.dynamicallyParameterized
    (Snippet
"select " Snippet -> Snippet -> Snippet
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Snippet] -> Snippet
intercalateSnippet ByteString
", " (Snippet
searchPathSql Snippet -> [Snippet] -> [Snippet]
forall a. a -> [a] -> [a]
: [Snippet]
roleSql [Snippet] -> [Snippet] -> [Snippet]
forall a. [a] -> [a] -> [a]
++ [Snippet]
claimsSql [Snippet] -> [Snippet] -> [Snippet]
forall a. [a] -> [a] -> [a]
++ [Snippet
methodSql, Snippet
pathSql] [Snippet] -> [Snippet] -> [Snippet]
forall a. [a] -> [a] -> [a]
++ [Snippet]
headersSql [Snippet] -> [Snippet] -> [Snippet]
forall a. [a] -> [a] -> [a]
++ [Snippet]
cookiesSql [Snippet] -> [Snippet] -> [Snippet]
forall a. [a] -> [a] -> [a]
++ [Snippet]
appSettingsSql [Snippet] -> [Snippet] -> [Snippet]
forall a. [a] -> [a] -> [a]
++ [Snippet]
specSql))
    Result ()
HD.noResult (AppConfig -> Bool
configDbPreparedStatements AppConfig
conf)
  Transaction () -> ExceptT Error Transaction ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction () -> ExceptT Error Transaction ())
-> Transaction () -> ExceptT Error Transaction ()
forall a b. (a -> b) -> a -> b
$ (ByteString -> Transaction ())
-> Maybe ByteString -> Transaction ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ByteString -> Transaction ()
H.sql Maybe ByteString
preReqSql
  ApiRequest -> ExceptT Error Transaction Response
app ApiRequest
req
  where
    methodSql :: Snippet
methodSql = ByteString -> (ByteString, ByteString) -> Snippet
setConfigLocal ByteString
forall a. Monoid a => a
mempty (ByteString
"request.method", ApiRequest -> ByteString
iMethod ApiRequest
req)
    pathSql :: Snippet
pathSql = ByteString -> (ByteString, ByteString) -> Snippet
setConfigLocal ByteString
forall a. Monoid a => a
mempty (ByteString
"request.path", ApiRequest -> ByteString
iPath ApiRequest
req)
    headersSql :: [Snippet]
headersSql = ByteString -> (ByteString, ByteString) -> Snippet
setConfigLocal ByteString
"request.header." ((ByteString, ByteString) -> Snippet)
-> [(ByteString, ByteString)] -> [Snippet]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ApiRequest -> [(ByteString, ByteString)]
iHeaders ApiRequest
req
    cookiesSql :: [Snippet]
cookiesSql = ByteString -> (ByteString, ByteString) -> Snippet
setConfigLocal ByteString
"request.cookie." ((ByteString, ByteString) -> Snippet)
-> [(ByteString, ByteString)] -> [Snippet]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ApiRequest -> [(ByteString, ByteString)]
iCookies ApiRequest
req
    claimsWithRole :: HashMap Text Value
claimsWithRole =
      let anon :: Value
anon = Text -> Value
JSON.String (Text -> Value) -> (Text -> Text) -> Text -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
forall a b. StringConv a b => a -> b
toS (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ AppConfig -> Text
configDbAnonRole AppConfig
conf in -- role claim defaults to anon if not specified in jwt
      HashMap Text Value -> HashMap Text Value -> HashMap Text Value
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
M.union HashMap Text Value
claims (Text -> Value -> HashMap Text Value
forall k v. Hashable k => k -> v -> HashMap k v
M.singleton Text
"role" Value
anon)
    claimsSql :: [Snippet]
claimsSql = ByteString -> (ByteString, ByteString) -> Snippet
setConfigLocal ByteString
"request.jwt.claim." ((ByteString, ByteString) -> Snippet)
-> [(ByteString, ByteString)] -> [Snippet]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text -> ByteString
forall a b. StringConv a b => a -> b
toS Text
c, Text -> ByteString
forall a b. StringConv a b => a -> b
toS (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> Text
unquoted Value
v) | (Text
c,Value
v) <- HashMap Text Value -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
M.toList HashMap Text Value
claimsWithRole]
    roleSql :: [Snippet]
roleSql = Maybe Snippet -> [Snippet]
forall a. Maybe a -> [a]
maybeToList (Maybe Snippet -> [Snippet]) -> Maybe Snippet -> [Snippet]
forall a b. (a -> b) -> a -> b
$ (\Value
x -> ByteString -> (ByteString, ByteString) -> Snippet
setConfigLocal ByteString
forall a. Monoid a => a
mempty (ByteString
"role", Text -> ByteString
forall a b. StringConv a b => a -> b
toS (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> Text
unquoted Value
x)) (Value -> Snippet) -> Maybe Value -> Maybe Snippet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Text
"role" HashMap Text Value
claimsWithRole
    appSettingsSql :: [Snippet]
appSettingsSql = ByteString -> (ByteString, ByteString) -> Snippet
setConfigLocal ByteString
forall a. Monoid a => a
mempty ((ByteString, ByteString) -> Snippet)
-> [(ByteString, ByteString)] -> [Snippet]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((Text -> ByteString)
 -> (Text -> ByteString)
 -> (Text, Text)
 -> (ByteString, ByteString))
-> (Text -> ByteString) -> (Text, Text) -> (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Text -> ByteString)
-> (Text -> ByteString) -> (Text, Text) -> (ByteString, ByteString)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> ByteString
forall a b. StringConv a b => a -> b
toS ((Text, Text) -> (ByteString, ByteString))
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppConfig -> [(Text, Text)]
configAppSettings AppConfig
conf)
    searchPathSql :: Snippet
searchPathSql =
      let schemas :: Text
schemas = Text -> [Text] -> Text
T.intercalate Text
", " (ApiRequest -> Text
iSchema ApiRequest
req Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: AppConfig -> [Text]
configDbExtraSearchPath AppConfig
conf) in
      ByteString -> (ByteString, ByteString) -> Snippet
setConfigLocal ByteString
forall a. Monoid a => a
mempty (ByteString
"search_path", Text -> ByteString
forall a b. StringConv a b => a -> b
toS Text
schemas)
    preReqSql :: Maybe ByteString
preReqSql = (\QualifiedIdentifier
f -> ByteString
"select " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> QualifiedIdentifier -> ByteString
fromQi QualifiedIdentifier
f ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"();") (QualifiedIdentifier -> ByteString)
-> Maybe QualifiedIdentifier -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppConfig -> Maybe QualifiedIdentifier
configDbPreRequest AppConfig
conf
    specSql :: [Snippet]
specSql = case ApiRequest -> Target
iTarget ApiRequest
req of
      TargetProc{tpIsRootSpec :: Target -> Bool
tpIsRootSpec=Bool
True} -> [ByteString -> (ByteString, ByteString) -> Snippet
setConfigLocal ByteString
forall a. Monoid a => a
mempty (ByteString
"request.spec", ByteString
jsonDbS)]
      Target
_                             -> [Snippet]
forall a. Monoid a => a
mempty
    -- | Do a pg set_config(setting, value, true) call. This is equivalent to a SET LOCAL.
    setConfigLocal :: ByteString -> (ByteString, ByteString) -> H.Snippet
    setConfigLocal :: ByteString -> (ByteString, ByteString) -> Snippet
setConfigLocal ByteString
prefix (ByteString
k, ByteString
v) =
      Snippet
"set_config(" Snippet -> Snippet -> Snippet
forall a. Semigroup a => a -> a -> a
<> ByteString -> Snippet
unknownEncoder (ByteString
prefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
k) Snippet -> Snippet -> Snippet
forall a. Semigroup a => a -> a -> a
<> Snippet
", " Snippet -> Snippet -> Snippet
forall a. Semigroup a => a -> a -> a
<> ByteString -> Snippet
unknownEncoder ByteString
v Snippet -> Snippet -> Snippet
forall a. Semigroup a => a -> a -> a
<> Snippet
", true)"

-- | Log in apache format. Only requests that have a status greater than minStatus are logged.
-- | There's no way to filter logs in the apache format on wai-extra: https://hackage.haskell.org/package/wai-extra-3.0.29.2/docs/Network-Wai-Middleware-RequestLogger.html#t:OutputFormat.
-- | So here we copy wai-logger apacheLogStr function: https://github.com/kazu-yamamoto/logger/blob/a4f51b909a099c51af7a3f75cf16e19a06f9e257/wai-logger/Network/Wai/Logger/Apache.hs#L45
-- | TODO: Add the ability to filter apache logs on wai-extra and remove this function.
pgrstFormat :: Status -> Wai.OutputFormatter
pgrstFormat :: Status -> OutputFormatter
pgrstFormat Status
minStatus ByteString
date Request
req Status
status Maybe Integer
responseSize =
  if Status
status Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
< Status
minStatus
    then LogStr
forall a. Monoid a => a
mempty
  else ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Request -> ByteString
getSourceFromSocket Request
req)
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" - - ["
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr ByteString
date
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"] \""
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Request -> ByteString
Wai.requestMethod Request
req)
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" "
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Request -> ByteString
Wai.rawPathInfo Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
Wai.rawQueryString Request
req)
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" "
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (HttpVersion -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (Request -> HttpVersion
Wai.httpVersion Request
req)::Text)
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\" "
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Int -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (Status -> Int
statusCode Status
status)::Text)
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" "
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Text -> (Integer -> Text) -> Maybe Integer -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"-" Integer -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show Maybe Integer
responseSize::Text)
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" \""
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
forall a. Monoid a => a
mempty (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> Maybe ByteString
Wai.requestHeaderReferer Request
req)
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\" \""
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
forall a. Monoid a => a
mempty (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> Maybe ByteString
Wai.requestHeaderUserAgent Request
req)
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\"\n"
  where
    getSourceFromSocket :: Request -> ByteString
getSourceFromSocket = String -> ByteString
BS.pack (String -> ByteString)
-> (Request -> String) -> Request -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SockAddr -> String
Wai.showSockAddr (SockAddr -> String) -> (Request -> SockAddr) -> Request -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> SockAddr
Wai.remoteHost

pgrstMiddleware :: LogLevel -> Wai.Application -> Wai.Application
pgrstMiddleware :: LogLevel -> Application -> Application
pgrstMiddleware LogLevel
logLevel =
    Application -> Application
logger
  (Application -> Application)
-> (Application -> Application) -> Application -> Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Request -> Maybe CorsResourcePolicy) -> Application -> Application
Wai.cors Request -> Maybe CorsResourcePolicy
corsPolicy
  (Application -> Application)
-> (Application -> Application) -> Application -> Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Policy -> Application -> Application
Wai.staticPolicy ([(String, String)] -> Policy
Wai.only [(String
"favicon.ico", String
"static/favicon.ico")])
  where
    logger :: Application -> Application
logger = case LogLevel
logLevel of
      LogLevel
LogCrit  -> Application -> Application
forall a. a -> a
id
      LogLevel
LogError -> IO (Application -> Application) -> Application -> Application
forall a. IO a -> a
unsafePerformIO (IO (Application -> Application) -> Application -> Application)
-> IO (Application -> Application) -> Application -> Application
forall a b. (a -> b) -> a -> b
$ RequestLoggerSettings -> IO (Application -> Application)
Wai.mkRequestLogger RequestLoggerSettings
forall a. Default a => a
Wai.def { outputFormat :: OutputFormat
Wai.outputFormat = OutputFormatter -> OutputFormat
Wai.CustomOutputFormat (OutputFormatter -> OutputFormat)
-> OutputFormatter -> OutputFormat
forall a b. (a -> b) -> a -> b
$ Status -> OutputFormatter
pgrstFormat Status
status500}
      LogLevel
LogWarn  -> IO (Application -> Application) -> Application -> Application
forall a. IO a -> a
unsafePerformIO (IO (Application -> Application) -> Application -> Application)
-> IO (Application -> Application) -> Application -> Application
forall a b. (a -> b) -> a -> b
$ RequestLoggerSettings -> IO (Application -> Application)
Wai.mkRequestLogger RequestLoggerSettings
forall a. Default a => a
Wai.def { outputFormat :: OutputFormat
Wai.outputFormat = OutputFormatter -> OutputFormat
Wai.CustomOutputFormat (OutputFormatter -> OutputFormat)
-> OutputFormatter -> OutputFormat
forall a b. (a -> b) -> a -> b
$ Status -> OutputFormatter
pgrstFormat Status
status400}
      LogLevel
LogInfo  -> Application -> Application
Wai.logStdout

defaultCorsPolicy :: Wai.CorsResourcePolicy
defaultCorsPolicy :: CorsResourcePolicy
defaultCorsPolicy =  Maybe ([ByteString], Bool)
-> [ByteString]
-> [HeaderName]
-> Maybe [HeaderName]
-> Maybe Int
-> Bool
-> Bool
-> Bool
-> CorsResourcePolicy
Wai.CorsResourcePolicy Maybe ([ByteString], Bool)
forall a. Maybe a
Nothing
  [ByteString
"GET", ByteString
"POST", ByteString
"PATCH", ByteString
"PUT", ByteString
"DELETE", ByteString
"OPTIONS"] [HeaderName
"Authorization"] Maybe [HeaderName]
forall a. Maybe a
Nothing
  (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
60Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
60Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
24) Bool
False Bool
False Bool
True

-- | CORS policy to be used in by Wai Cors middleware
corsPolicy :: Wai.Request -> Maybe Wai.CorsResourcePolicy
corsPolicy :: Request -> Maybe CorsResourcePolicy
corsPolicy Request
req = case HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"origin" [(HeaderName, ByteString)]
headers of
  Just ByteString
origin -> CorsResourcePolicy -> Maybe CorsResourcePolicy
forall a. a -> Maybe a
Just CorsResourcePolicy
defaultCorsPolicy {
      corsOrigins :: Maybe ([ByteString], Bool)
Wai.corsOrigins = ([ByteString], Bool) -> Maybe ([ByteString], Bool)
forall a. a -> Maybe a
Just ([ByteString
origin], Bool
True)
    , corsRequestHeaders :: [HeaderName]
Wai.corsRequestHeaders = HeaderName
"Authentication" HeaderName -> [HeaderName] -> [HeaderName]
forall a. a -> [a] -> [a]
: [HeaderName]
accHeaders
    , corsExposedHeaders :: Maybe [HeaderName]
Wai.corsExposedHeaders = [HeaderName] -> Maybe [HeaderName]
forall a. a -> Maybe a
Just [
        HeaderName
"Content-Encoding", HeaderName
"Content-Location", HeaderName
"Content-Range", HeaderName
"Content-Type"
      , HeaderName
"Date", HeaderName
"Location", HeaderName
"Server", HeaderName
"Transfer-Encoding", HeaderName
"Range-Unit"
      ]
    }
  Maybe ByteString
Nothing -> Maybe CorsResourcePolicy
forall a. Maybe a
Nothing
  where
    headers :: [(HeaderName, ByteString)]
headers = Request -> [(HeaderName, ByteString)]
Wai.requestHeaders Request
req
    accHeaders :: [HeaderName]
accHeaders = case HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"access-control-request-headers" [(HeaderName, ByteString)]
headers of
      Just ByteString
hdrs -> (ByteString -> HeaderName) -> [ByteString] -> [HeaderName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> HeaderName)
-> (ByteString -> ByteString) -> ByteString -> HeaderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. StringConv a b => a -> b
toS (Text -> ByteString)
-> (ByteString -> Text) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
forall a b. StringConv a b => a -> b
toS) ([ByteString] -> [HeaderName]) -> [ByteString] -> [HeaderName]
forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> [ByteString]
BS.split Char
',' ByteString
hdrs
      Maybe ByteString
Nothing -> []

unquoted :: JSON.Value -> Text
unquoted :: Value -> Text
unquoted (JSON.String Text
t) = Text
t
unquoted (JSON.Number Scientific
n) =
  String -> Text
forall a b. StringConv a b => a -> b
toS (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ FPFormat -> Maybe Int -> Scientific -> String
formatScientific FPFormat
Fixed (if Scientific -> Bool
isInteger Scientific
n then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0 else Maybe Int
forall a. Maybe a
Nothing) Scientific
n
unquoted (JSON.Bool Bool
b) = Bool -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show Bool
b
unquoted Value
v = ByteString -> Text
forall a b. StringConv a b => a -> b
toS (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode Value
v

-- | Set a transaction to eventually roll back if requested and set respective
-- headers on the response.
optionalRollback
  :: AppConfig
  -> ApiRequest
  -> ExceptT Error H.Transaction Wai.Response
  -> ExceptT Error H.Transaction Wai.Response
optionalRollback :: AppConfig
-> ApiRequest
-> ExceptT Error Transaction Response
-> ExceptT Error Transaction Response
optionalRollback AppConfig{Bool
Int
[(Text, Text)]
[ByteString]
[Text]
JSPath
Maybe Integer
Maybe String
Maybe ByteString
Maybe Text
Maybe StringOrURI
Maybe JWKSet
Maybe QualifiedIdentifier
Text
FileMode
NonEmpty Text
NominalDiffTime
OpenAPIMode
LogLevel
configServerUnixSocketMode :: AppConfig -> FileMode
configServerUnixSocket :: AppConfig -> Maybe String
configServerPort :: AppConfig -> Int
configServerHost :: AppConfig -> Text
configRawMediaTypes :: AppConfig -> [ByteString]
configOpenApiServerProxyUri :: AppConfig -> Maybe Text
configOpenApiMode :: AppConfig -> OpenAPIMode
configLogLevel :: AppConfig -> LogLevel
configJwtSecretIsBase64 :: AppConfig -> Bool
configJwtSecret :: AppConfig -> Maybe ByteString
configJwtRoleClaimKey :: AppConfig -> JSPath
configJwtAudience :: AppConfig -> Maybe StringOrURI
configJWKS :: AppConfig -> Maybe JWKSet
configFilePath :: AppConfig -> Maybe String
configDbUri :: AppConfig -> Text
configDbTxRollbackAll :: AppConfig -> Bool
configDbTxAllowOverride :: AppConfig -> Bool
configDbConfig :: AppConfig -> Bool
configDbSchemas :: AppConfig -> NonEmpty Text
configDbRootSpec :: AppConfig -> Maybe QualifiedIdentifier
configDbPoolTimeout :: AppConfig -> NominalDiffTime
configDbPoolSize :: AppConfig -> Int
configDbMaxRows :: AppConfig -> Maybe Integer
configDbChannelEnabled :: AppConfig -> Bool
configDbChannel :: AppConfig -> Text
configServerUnixSocketMode :: FileMode
configServerUnixSocket :: Maybe String
configServerPort :: Int
configServerHost :: Text
configRawMediaTypes :: [ByteString]
configOpenApiServerProxyUri :: Maybe Text
configOpenApiMode :: OpenAPIMode
configLogLevel :: LogLevel
configJwtSecretIsBase64 :: Bool
configJwtSecret :: Maybe ByteString
configJwtRoleClaimKey :: JSPath
configJwtAudience :: Maybe StringOrURI
configJWKS :: Maybe JWKSet
configFilePath :: Maybe String
configDbUri :: Text
configDbTxRollbackAll :: Bool
configDbTxAllowOverride :: Bool
configDbConfig :: Bool
configDbSchemas :: NonEmpty Text
configDbRootSpec :: Maybe QualifiedIdentifier
configDbPreparedStatements :: Bool
configDbPreRequest :: Maybe QualifiedIdentifier
configDbPoolTimeout :: NominalDiffTime
configDbPoolSize :: Int
configDbMaxRows :: Maybe Integer
configDbExtraSearchPath :: [Text]
configDbChannelEnabled :: Bool
configDbChannel :: Text
configDbAnonRole :: Text
configAppSettings :: [(Text, Text)]
configDbPreRequest :: AppConfig -> Maybe QualifiedIdentifier
configDbExtraSearchPath :: AppConfig -> [Text]
configAppSettings :: AppConfig -> [(Text, Text)]
configDbAnonRole :: AppConfig -> Text
configDbPreparedStatements :: AppConfig -> Bool
..} ApiRequest{[(ByteString, ByteString)]
[(Text, Text)]
Maybe Text
Maybe PreferTransaction
Maybe PreferCount
Maybe PreferParameters
Maybe PreferResolution
Maybe PayloadJSON
NonnegRange
ByteString
Text
HashMap ByteString NonnegRange
Set Text
ContentType
PreferRepresentation
Target
Action
iAcceptContentType :: ApiRequest -> ContentType
iProfile :: ApiRequest -> Maybe Text
iJWT :: ApiRequest -> Text
iCanonicalQS :: ApiRequest -> ByteString
iOrder :: ApiRequest -> [(Text, Text)]
iColumns :: ApiRequest -> Set Text
iOnConflict :: ApiRequest -> Maybe Text
iSelect :: ApiRequest -> Maybe Text
iLogic :: ApiRequest -> [(Text, Text)]
iFilters :: ApiRequest -> [(Text, Text)]
iPreferTransaction :: ApiRequest -> Maybe PreferTransaction
iPreferResolution :: ApiRequest -> Maybe PreferResolution
iPreferCount :: ApiRequest -> Maybe PreferCount
iPreferParameters :: ApiRequest -> Maybe PreferParameters
iPreferRepresentation :: ApiRequest -> PreferRepresentation
iPayload :: ApiRequest -> Maybe PayloadJSON
iTopLevelRange :: ApiRequest -> NonnegRange
iRange :: ApiRequest -> HashMap ByteString NonnegRange
iAction :: ApiRequest -> Action
iAcceptContentType :: ContentType
iSchema :: Text
iProfile :: Maybe Text
iMethod :: ByteString
iPath :: ByteString
iCookies :: [(ByteString, ByteString)]
iHeaders :: [(ByteString, ByteString)]
iJWT :: Text
iCanonicalQS :: ByteString
iOrder :: [(Text, Text)]
iColumns :: Set Text
iOnConflict :: Maybe Text
iSelect :: Maybe Text
iLogic :: [(Text, Text)]
iFilters :: [(Text, Text)]
iPreferTransaction :: Maybe PreferTransaction
iPreferResolution :: Maybe PreferResolution
iPreferCount :: Maybe PreferCount
iPreferParameters :: Maybe PreferParameters
iPreferRepresentation :: PreferRepresentation
iPayload :: Maybe PayloadJSON
iTarget :: Target
iTopLevelRange :: NonnegRange
iRange :: HashMap ByteString NonnegRange
iAction :: Action
iTarget :: ApiRequest -> Target
iSchema :: ApiRequest -> Text
iCookies :: ApiRequest -> [(ByteString, ByteString)]
iHeaders :: ApiRequest -> [(ByteString, ByteString)]
iPath :: ApiRequest -> ByteString
iMethod :: ApiRequest -> ByteString
..} ExceptT Error Transaction Response
transaction = do
  Response
resp <- ExceptT Error Transaction Response
-> (Error -> ExceptT Error Transaction Response)
-> ExceptT Error Transaction Response
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ExceptT Error Transaction Response
transaction ((Error -> ExceptT Error Transaction Response)
 -> ExceptT Error Transaction Response)
-> (Error -> ExceptT Error Transaction Response)
-> ExceptT Error Transaction Response
forall a b. (a -> b) -> a -> b
$ Response -> ExceptT Error Transaction Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> ExceptT Error Transaction Response)
-> (Error -> Response)
-> Error
-> ExceptT Error Transaction Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Response
forall a. PgrstError a => a -> Response
errorResponseFor
  Bool
-> ExceptT Error Transaction () -> ExceptT Error Transaction ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
shouldRollback Bool -> Bool -> Bool
|| (Bool
configDbTxRollbackAll Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
shouldCommit))
    (Transaction () -> ExceptT Error Transaction ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Transaction ()
H.condemn)
  Response -> ExceptT Error Transaction Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> ExceptT Error Transaction Response)
-> Response -> ExceptT Error Transaction Response
forall a b. (a -> b) -> a -> b
$ ([(HeaderName, ByteString)] -> [(HeaderName, ByteString)])
-> Response -> Response
Wai.mapResponseHeaders [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
preferenceApplied Response
resp
  where
    shouldCommit :: Bool
shouldCommit =
      Bool
configDbTxAllowOverride Bool -> Bool -> Bool
&& Maybe PreferTransaction
iPreferTransaction Maybe PreferTransaction -> Maybe PreferTransaction -> Bool
forall a. Eq a => a -> a -> Bool
== PreferTransaction -> Maybe PreferTransaction
forall a. a -> Maybe a
Just PreferTransaction
Commit
    shouldRollback :: Bool
shouldRollback =
      Bool
configDbTxAllowOverride Bool -> Bool -> Bool
&& Maybe PreferTransaction
iPreferTransaction Maybe PreferTransaction -> Maybe PreferTransaction -> Bool
forall a. Eq a => a -> a -> Bool
== PreferTransaction -> Maybe PreferTransaction
forall a. a -> Maybe a
Just PreferTransaction
Rollback
    preferenceApplied :: [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
preferenceApplied
      | Bool
shouldCommit =
          [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
addHeadersIfNotIncluded
            [(HeaderName
HTTP.hPreferenceApplied, String -> ByteString
BS.pack (PreferTransaction -> String
forall a b. (Show a, ConvertText String b) => a -> b
show PreferTransaction
Commit))]
      | Bool
shouldRollback =
          [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
addHeadersIfNotIncluded
            [(HeaderName
HTTP.hPreferenceApplied, String -> ByteString
BS.pack (PreferTransaction -> String
forall a b. (Show a, ConvertText String b) => a -> b
show PreferTransaction
Rollback))]
      | Bool
otherwise =
          [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> a
identity