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

import qualified Data.Aeson                        as JSON
import qualified Data.ByteString.Lazy.Char8        as LBS
import qualified Data.HashMap.Strict               as M
import qualified Data.Text                         as T
import qualified Data.Text.Encoding                as T
import qualified Hasql.Decoders                    as HD
import qualified Hasql.DynamicStatements.Snippet   as SQL hiding (sql)
import qualified Hasql.DynamicStatements.Statement as SQL
import qualified Hasql.Transaction                 as SQL
import qualified Network.Wai                       as Wai

import Control.Arrow ((***))

import Data.Scientific (FPFormat (..), formatScientific, isInteger)

import PostgREST.Config             (AppConfig (..))
import PostgREST.Config.PgVersion   (PgVersion (..), pgVersion140)
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

-- | Runs local(transaction scoped) GUCs for every request, plus the pre-request function
runPgLocals :: AppConfig   -> M.HashMap Text JSON.Value ->
               (ApiRequest -> ExceptT Error SQL.Transaction Wai.Response) ->
               ApiRequest  -> ByteString -> PgVersion -> ExceptT Error SQL.Transaction Wai.Response
runPgLocals :: AppConfig
-> HashMap Text Value
-> (ApiRequest -> ExceptT Error Transaction Response)
-> ApiRequest
-> ByteString
-> PgVersion
-> ExceptT Error Transaction Response
runPgLocals AppConfig
conf HashMap Text Value
claims ApiRequest -> ExceptT Error Transaction Response
app ApiRequest
req ByteString
jsonDbS PgVersion
actualPgVersion = 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
SQL.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
SQL.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 ()
SQL.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 = if Bool
usesLegacyGucs
                   then 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
                   else ByteString -> [(ByteString, ByteString)] -> [Snippet]
setConfigLocalJson ByteString
"request.headers" (ApiRequest -> [(ByteString, ByteString)]
iHeaders ApiRequest
req)
    cookiesSql :: [Snippet]
cookiesSql = if Bool
usesLegacyGucs
                   then 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
                   else ByteString -> [(ByteString, ByteString)] -> [Snippet]
setConfigLocalJson ByteString
"request.cookies" (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. ConvertText 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 = if Bool
usesLegacyGucs
                  then 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. ConvertText a Text => a -> ByteString
toUtf8 Text
c, Text -> ByteString
forall a. ConvertText a Text => a -> ByteString
toUtf8 (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]
                  else [ByteString -> (ByteString, ByteString) -> Snippet
setConfigLocal ByteString
forall a. Monoid a => a
mempty (ByteString
"request.jwt.claims", ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HashMap Text Value -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode 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. ConvertText a Text => a -> ByteString
toUtf8 (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. ConvertText a Text => a -> ByteString
toUtf8 ((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. ConvertText a Text => a -> ByteString
toUtf8 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
    usesLegacyGucs :: Bool
usesLegacyGucs = AppConfig -> Bool
configDbUseLegacyGucs AppConfig
conf Bool -> Bool -> Bool
&& PgVersion
actualPgVersion PgVersion -> PgVersion -> Bool
forall a. Ord a => a -> a -> Bool
< PgVersion
pgVersion140

    unquoted :: JSON.Value -> Text
    unquoted :: Value -> Text
unquoted (JSON.String Text
t) = Text
t
    unquoted (JSON.Number Scientific
n) =
      String -> Text
forall a b. ConvertText 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, StringConv String b) => a -> b
show Bool
b
    unquoted Value
v = ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict (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 SQL.Transaction Wai.Response
  -> ExceptT Error SQL.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
configDbUseLegacyGucs :: Bool
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)]
configDbUseLegacyGucs :: AppConfig -> Bool
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 Payload
NonnegRange
ByteString
Text
HashMap Text 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 Payload
iTopLevelRange :: ApiRequest -> NonnegRange
iRange :: ApiRequest -> HashMap Text 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 Payload
iTarget :: Target
iTopLevelRange :: NonnegRange
iRange :: HashMap Text 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)) (ExceptT Error Transaction () -> ExceptT Error Transaction ())
-> ExceptT Error Transaction () -> ExceptT Error Transaction ()
forall a b. (a -> b) -> a -> b
$ Transaction () -> ExceptT Error Transaction ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift do
    ByteString -> Transaction ()
SQL.sql ByteString
"SET CONSTRAINTS ALL IMMEDIATE"
    Transaction ()
SQL.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
$ (ResponseHeaders -> ResponseHeaders) -> Response -> Response
Wai.mapResponseHeaders ResponseHeaders -> ResponseHeaders
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 :: ResponseHeaders -> ResponseHeaders
preferenceApplied
      | Bool
shouldCommit =
          ResponseHeaders -> ResponseHeaders -> ResponseHeaders
addHeadersIfNotIncluded
            [PreferTransaction -> Header
forall a. ToAppliedHeader a => a -> Header
toAppliedHeader PreferTransaction
Commit]
      | Bool
shouldRollback =
          ResponseHeaders -> ResponseHeaders -> ResponseHeaders
addHeadersIfNotIncluded
            [PreferTransaction -> Header
forall a. ToAppliedHeader a => a -> Header
toAppliedHeader PreferTransaction
Rollback]
      | Bool
otherwise =
          ResponseHeaders -> ResponseHeaders
forall a. a -> a
identity

-- | Do a pg set_config(setting, value, true) call. This is equivalent to a SET LOCAL.
setConfigLocal :: ByteString -> (ByteString, ByteString) -> SQL.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)"

-- | Starting from PostgreSQL v14, some characters are not allowed for config names (mostly affecting headers with "-").
-- | A JSON format string is used to avoid this problem. See https://github.com/PostgREST/postgrest/issues/1857
setConfigLocalJson :: ByteString -> [(ByteString, ByteString)] -> [SQL.Snippet]
setConfigLocalJson :: ByteString -> [(ByteString, ByteString)] -> [Snippet]
setConfigLocalJson ByteString
prefix [(ByteString, ByteString)]
keyVals = [ByteString -> (ByteString, ByteString) -> Snippet
setConfigLocal ByteString
forall a. Monoid a => a
mempty (ByteString
prefix, [(ByteString, ByteString)] -> ByteString
gucJsonVal [(ByteString, ByteString)]
keyVals)]
  where
    gucJsonVal :: [(ByteString, ByteString)] -> ByteString
    gucJsonVal :: [(ByteString, ByteString)] -> ByteString
gucJsonVal = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> ([(ByteString, ByteString)] -> ByteString)
-> [(ByteString, ByteString)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text Text -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode (HashMap Text Text -> ByteString)
-> ([(ByteString, ByteString)] -> HashMap Text Text)
-> [(ByteString, ByteString)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Text)] -> HashMap Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(Text, Text)] -> HashMap Text Text)
-> ([(ByteString, ByteString)] -> [(Text, Text)])
-> [(ByteString, ByteString)]
-> HashMap Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ByteString, ByteString)] -> [(Text, Text)]
arrayByteStringToText
    arrayByteStringToText :: [(ByteString, ByteString)] -> [(Text,Text)]
    arrayByteStringToText :: [(ByteString, ByteString)] -> [(Text, Text)]
arrayByteStringToText [(ByteString, ByteString)]
keyVal = (ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> (ByteString -> Text) -> (ByteString, ByteString) -> (Text, Text)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> Text
T.decodeUtf8) ((ByteString, ByteString) -> (Text, Text))
-> [(ByteString, ByteString)] -> [(Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ByteString, ByteString)]
keyVal