{-|
Module      : PostgREST.App
Description : PostgREST main application

This module is in charge of mapping HTTP requests to PostgreSQL queries.
Some of its functionality includes:

- Mapping HTTP request methods to proper SQL statements. For example, a GET request is translated to executing a SELECT query in a read-only TRANSACTION.
- Producing HTTP Headers according to RFCs.
- Content Negotiation
-}
{-# LANGUAGE RecordWildCards #-}
module PostgREST.App
  ( SignalHandlerInstaller
  , SocketRunner
  , postgrest
  , run
  ) where

import Control.Monad.Except     (liftEither)
import Data.Either.Combinators  (mapLeft)
import Data.List                (union)
import Data.String              (IsString (..))
import Data.Time.Clock          (UTCTime)
import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort,
                                 setServerName)
import System.Posix.Types       (FileMode)

import qualified Data.ByteString.Char8           as BS8
import qualified Data.ByteString.Lazy            as LBS
import qualified Data.HashMap.Strict             as Map
import qualified Data.Set                        as Set
import qualified Hasql.DynamicStatements.Snippet as SQL
import qualified Hasql.Pool                      as SQL
import qualified Hasql.Transaction               as SQL
import qualified Hasql.Transaction.Sessions      as SQL
import qualified Network.HTTP.Types.Header       as HTTP
import qualified Network.HTTP.Types.Status       as HTTP
import qualified Network.HTTP.Types.URI          as HTTP
import qualified Network.Wai                     as Wai
import qualified Network.Wai.Handler.Warp        as Warp

import qualified PostgREST.AppState                 as AppState
import qualified PostgREST.Auth                     as Auth
import qualified PostgREST.DbStructure              as DbStructure
import qualified PostgREST.Error                    as Error
import qualified PostgREST.Middleware               as Middleware
import qualified PostgREST.OpenAPI                  as OpenAPI
import qualified PostgREST.Query.QueryBuilder       as QueryBuilder
import qualified PostgREST.Query.Statements         as Statements
import qualified PostgREST.RangeQuery               as RangeQuery
import qualified PostgREST.Request.ApiRequest       as ApiRequest
import qualified PostgREST.Request.DbRequestBuilder as ReqBuilder

import PostgREST.AppState                (AppState)
import PostgREST.Config                  (AppConfig (..),
                                          LogLevel (..),
                                          OpenAPIMode (..))
import PostgREST.Config.PgVersion        (PgVersion (..))
import PostgREST.ContentType             (ContentType (..))
import PostgREST.DbStructure             (DbStructure (..),
                                          tablePKCols)
import PostgREST.DbStructure.Identifiers (FieldName,
                                          QualifiedIdentifier (..),
                                          Schema)
import PostgREST.DbStructure.Proc        (ProcDescription (..),
                                          ProcVolatility (..))
import PostgREST.DbStructure.Table       (Table (..))
import PostgREST.Error                   (Error)
import PostgREST.GucHeader               (GucHeader,
                                          addHeadersIfNotIncluded,
                                          unwrapGucHeader)
import PostgREST.Request.ApiRequest      (Action (..),
                                          ApiRequest (..),
                                          InvokeMethod (..),
                                          Target (..))
import PostgREST.Request.Preferences     (PreferCount (..),
                                          PreferParameters (..),
                                          PreferRepresentation (..))
import PostgREST.Request.Types           (ReadRequest, fstFieldNames)
import PostgREST.Version                 (prettyVersion)
import PostgREST.Workers                 (connectionWorker, listener)

import qualified PostgREST.ContentType      as ContentType
import qualified PostgREST.DbStructure.Proc as Proc

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


data RequestContext = RequestContext
  { RequestContext -> AppConfig
ctxConfig      :: AppConfig
  , RequestContext -> DbStructure
ctxDbStructure :: DbStructure
  , RequestContext -> ApiRequest
ctxApiRequest  :: ApiRequest
  , RequestContext -> PgVersion
ctxPgVersion   :: PgVersion
  }

type Handler = ExceptT Error

type DbHandler = Handler SQL.Transaction

type SignalHandlerInstaller = AppState -> IO()

type SocketRunner = Warp.Settings -> Wai.Application -> FileMode -> FilePath -> IO()


run :: SignalHandlerInstaller -> Maybe SocketRunner -> AppState -> IO ()
run :: SignalHandlerInstaller
-> Maybe SocketRunner -> SignalHandlerInstaller
run SignalHandlerInstaller
installHandlers Maybe SocketRunner
maybeRunWithSocket AppState
appState = do
  conf :: AppConfig
conf@AppConfig{Bool
Int
[(Text, Text)]
[ByteString]
[Text]
JSPath
Maybe Integer
Maybe FilePath
Maybe ByteString
Maybe Text
Maybe StringOrURI
Maybe JWKSet
Maybe QualifiedIdentifier
Text
FileMode
NonEmpty Text
NominalDiffTime
OpenAPIMode
LogLevel
configServerUnixSocketMode :: AppConfig -> FileMode
configServerUnixSocket :: AppConfig -> Maybe FilePath
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 FilePath
configDbUri :: AppConfig -> Text
configDbTxRollbackAll :: AppConfig -> Bool
configDbTxAllowOverride :: AppConfig -> Bool
configDbConfig :: AppConfig -> Bool
configDbSchemas :: AppConfig -> NonEmpty Text
configDbRootSpec :: AppConfig -> Maybe QualifiedIdentifier
configDbPreparedStatements :: AppConfig -> Bool
configDbPreRequest :: AppConfig -> Maybe QualifiedIdentifier
configDbPoolTimeout :: AppConfig -> NominalDiffTime
configDbPoolSize :: AppConfig -> Int
configDbMaxRows :: AppConfig -> Maybe Integer
configDbExtraSearchPath :: AppConfig -> [Text]
configDbChannelEnabled :: AppConfig -> Bool
configDbChannel :: AppConfig -> Text
configDbAnonRole :: AppConfig -> Text
configAppSettings :: AppConfig -> [(Text, Text)]
configServerUnixSocketMode :: FileMode
configServerUnixSocket :: Maybe FilePath
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 FilePath
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)]
..} <- AppState -> IO AppConfig
AppState.getConfig AppState
appState
  SignalHandlerInstaller
connectionWorker AppState
appState -- Loads the initial DbStructure
  SignalHandlerInstaller
installHandlers AppState
appState
  -- reload schema cache + config on NOTIFY
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
configDbChannelEnabled (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SignalHandlerInstaller
listener AppState
appState

  let app :: Application
app = LogLevel -> AppState -> IO () -> Application
postgrest LogLevel
configLogLevel AppState
appState (SignalHandlerInstaller
connectionWorker AppState
appState)

  case Maybe FilePath
configServerUnixSocket of
    Just FilePath
socket ->
      -- run the postgrest application with user defined socket. Only for UNIX systems
      case Maybe SocketRunner
maybeRunWithSocket of
        Just SocketRunner
runWithSocket -> do
          AppState -> Text -> IO ()
AppState.logWithZTime AppState
appState (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Listening on unix socket " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show FilePath
socket
          SocketRunner
runWithSocket (AppConfig -> Settings
serverSettings AppConfig
conf) Application
app FileMode
configServerUnixSocketMode FilePath
socket
        Maybe SocketRunner
Nothing ->
          Text -> IO ()
forall a. HasCallStack => Text -> a
panic Text
"Cannot run with socket on non-unix plattforms."
    Maybe FilePath
Nothing ->
      do
        AppState -> Text -> IO ()
AppState.logWithZTime AppState
appState (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Listening on port " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show Int
configServerPort
        Settings -> Application -> IO ()
Warp.runSettings (AppConfig -> Settings
serverSettings AppConfig
conf) Application
app

serverSettings :: AppConfig -> Warp.Settings
serverSettings :: AppConfig -> Settings
serverSettings AppConfig{Bool
Int
[(Text, Text)]
[ByteString]
[Text]
JSPath
Maybe Integer
Maybe FilePath
Maybe ByteString
Maybe Text
Maybe StringOrURI
Maybe JWKSet
Maybe QualifiedIdentifier
Text
FileMode
NonEmpty Text
NominalDiffTime
OpenAPIMode
LogLevel
configServerUnixSocketMode :: FileMode
configServerUnixSocket :: Maybe FilePath
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 FilePath
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)]
configServerUnixSocketMode :: AppConfig -> FileMode
configServerUnixSocket :: AppConfig -> Maybe FilePath
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 FilePath
configDbUri :: AppConfig -> Text
configDbTxRollbackAll :: AppConfig -> Bool
configDbTxAllowOverride :: AppConfig -> Bool
configDbConfig :: AppConfig -> Bool
configDbSchemas :: AppConfig -> NonEmpty Text
configDbRootSpec :: AppConfig -> Maybe QualifiedIdentifier
configDbPreparedStatements :: AppConfig -> Bool
configDbPreRequest :: AppConfig -> Maybe QualifiedIdentifier
configDbPoolTimeout :: AppConfig -> NominalDiffTime
configDbPoolSize :: AppConfig -> Int
configDbMaxRows :: AppConfig -> Maybe Integer
configDbExtraSearchPath :: AppConfig -> [Text]
configDbChannelEnabled :: AppConfig -> Bool
configDbChannel :: AppConfig -> Text
configDbAnonRole :: AppConfig -> Text
configAppSettings :: AppConfig -> [(Text, Text)]
..} =
  Settings
defaultSettings
    Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& HostPreference -> Settings -> Settings
setHost (FilePath -> HostPreference
forall a. IsString a => FilePath -> a
fromString (FilePath -> HostPreference) -> FilePath -> HostPreference
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
forall a b. StringConv a b => a -> b
toS Text
configServerHost)
    Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& Int -> Settings -> Settings
setPort Int
configServerPort
    Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& ByteString -> Settings -> Settings
setServerName (Text -> ByteString
forall a b. StringConv a b => a -> b
toS (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text
"postgrest/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prettyVersion)

-- | PostgREST application
postgrest :: LogLevel -> AppState.AppState -> IO () -> Wai.Application
postgrest :: LogLevel -> AppState -> IO () -> Application
postgrest LogLevel
logLev AppState
appState IO ()
connWorker =
  LogLevel -> Application -> Application
Middleware.pgrstMiddleware LogLevel
logLev (Application -> Application) -> Application -> Application
forall a b. (a -> b) -> a -> b
$
    \Request
req Response -> IO ResponseReceived
respond -> do
      UTCTime
time <- AppState -> IO UTCTime
AppState.getTime AppState
appState
      AppConfig
conf <- AppState -> IO AppConfig
AppState.getConfig AppState
appState
      Maybe DbStructure
maybeDbStructure <- AppState -> IO (Maybe DbStructure)
AppState.getDbStructure AppState
appState
      PgVersion
pgVer <- AppState -> IO PgVersion
AppState.getPgVersion AppState
appState
      ByteString
jsonDbS <- AppState -> IO ByteString
AppState.getJsonDbS AppState
appState

      let
        eitherResponse :: IO (Either Error Wai.Response)
        eitherResponse :: IO (Either Error Response)
eitherResponse =
          ExceptT Error IO Response -> IO (Either Error Response)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Error IO Response -> IO (Either Error Response))
-> ExceptT Error IO Response -> IO (Either Error Response)
forall a b. (a -> b) -> a -> b
$ AppConfig
-> Maybe DbStructure
-> ByteString
-> PgVersion
-> Pool
-> UTCTime
-> Request
-> ExceptT Error IO Response
postgrestResponse AppConfig
conf Maybe DbStructure
maybeDbStructure ByteString
jsonDbS PgVersion
pgVer (AppState -> Pool
AppState.getPool AppState
appState) UTCTime
time Request
req

      Response
response <- (Error -> Response)
-> (Response -> Response) -> Either Error Response -> Response
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Error -> Response
forall a. PgrstError a => a -> Response
Error.errorResponseFor Response -> Response
forall a. a -> a
identity (Either Error Response -> Response)
-> IO (Either Error Response) -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either Error Response)
eitherResponse

      -- Launch the connWorker when the connection is down.  The postgrest
      -- function can respond successfully (with a stale schema cache) before
      -- the connWorker is done.
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Response -> Status
Wai.responseStatus Response
response Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
HTTP.status503) IO ()
connWorker

      Response -> IO ResponseReceived
respond Response
response

postgrestResponse
  :: AppConfig
  -> Maybe DbStructure
  -> ByteString
  -> PgVersion
  -> SQL.Pool
  -> UTCTime
  -> Wai.Request
  -> Handler IO Wai.Response
postgrestResponse :: AppConfig
-> Maybe DbStructure
-> ByteString
-> PgVersion
-> Pool
-> UTCTime
-> Request
-> ExceptT Error IO Response
postgrestResponse AppConfig
conf Maybe DbStructure
maybeDbStructure ByteString
jsonDbS PgVersion
pgVer Pool
pool UTCTime
time Request
req = do
  ByteString
body <- IO ByteString -> ExceptT Error IO ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO ByteString -> ExceptT Error IO ByteString)
-> IO ByteString -> ExceptT Error IO ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
Wai.strictRequestBody Request
req

  DbStructure
dbStructure <-
    case Maybe DbStructure
maybeDbStructure of
      Just DbStructure
dbStructure ->
        DbStructure -> ExceptT Error IO DbStructure
forall (m :: * -> *) a. Monad m => a -> m a
return DbStructure
dbStructure
      Maybe DbStructure
Nothing ->
        Error -> ExceptT Error IO DbStructure
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
Error.ConnectionLostError

  apiRequest :: ApiRequest
apiRequest@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
iSchema :: ApiRequest -> Text
iProfile :: ApiRequest -> Maybe Text
iMethod :: ApiRequest -> ByteString
iPath :: ApiRequest -> ByteString
iCookies :: ApiRequest -> [(ByteString, ByteString)]
iHeaders :: ApiRequest -> [(ByteString, ByteString)]
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
iTarget :: ApiRequest -> Target
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
..} <-
    Either Error ApiRequest -> ExceptT Error IO ApiRequest
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Error ApiRequest -> ExceptT Error IO ApiRequest)
-> (Either ApiRequestError ApiRequest -> Either Error ApiRequest)
-> Either ApiRequestError ApiRequest
-> ExceptT Error IO ApiRequest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ApiRequestError -> Error)
-> Either ApiRequestError ApiRequest -> Either Error ApiRequest
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft ApiRequestError -> Error
Error.ApiRequestError (Either ApiRequestError ApiRequest -> ExceptT Error IO ApiRequest)
-> Either ApiRequestError ApiRequest -> ExceptT Error IO ApiRequest
forall a b. (a -> b) -> a -> b
$
      AppConfig
-> DbStructure
-> Request
-> ByteString
-> Either ApiRequestError ApiRequest
ApiRequest.userApiRequest AppConfig
conf DbStructure
dbStructure Request
req ByteString
body

  -- The JWT must be checked before touching the db
  JWTClaims
jwtClaims <- AppConfig -> ByteString -> UTCTime -> ExceptT Error IO JWTClaims
forall (m :: * -> *).
Monad m =>
AppConfig -> ByteString -> UTCTime -> ExceptT Error m JWTClaims
Auth.jwtClaims AppConfig
conf (Text -> ByteString
forall a b. StringConv a b => a -> b
toS Text
iJWT) UTCTime
time

  let
    handleReq :: ApiRequest -> DbHandler Response
handleReq ApiRequest
apiReq =
      RequestContext -> DbHandler Response
handleRequest (RequestContext -> DbHandler Response)
-> RequestContext -> DbHandler Response
forall a b. (a -> b) -> a -> b
$ AppConfig
-> DbStructure -> ApiRequest -> PgVersion -> RequestContext
RequestContext AppConfig
conf DbStructure
dbStructure ApiRequest
apiReq PgVersion
pgVer

  Pool
-> Mode
-> JWTClaims
-> Bool
-> DbHandler Response
-> ExceptT Error IO Response
forall a.
Pool -> Mode -> JWTClaims -> Bool -> DbHandler a -> Handler IO a
runDbHandler Pool
pool (ApiRequest -> Mode
txMode ApiRequest
apiRequest) JWTClaims
jwtClaims (AppConfig -> Bool
configDbPreparedStatements AppConfig
conf) (DbHandler Response -> ExceptT Error IO Response)
-> (DbHandler Response -> DbHandler Response)
-> DbHandler Response
-> ExceptT Error IO Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    AppConfig -> ApiRequest -> DbHandler Response -> DbHandler Response
Middleware.optionalRollback AppConfig
conf ApiRequest
apiRequest (DbHandler Response -> ExceptT Error IO Response)
-> DbHandler Response -> ExceptT Error IO Response
forall a b. (a -> b) -> a -> b
$
      AppConfig
-> JWTClaims
-> (ApiRequest -> DbHandler Response)
-> ApiRequest
-> ByteString
-> DbHandler Response
Middleware.runPgLocals AppConfig
conf JWTClaims
jwtClaims ApiRequest -> DbHandler Response
handleReq ApiRequest
apiRequest ByteString
jsonDbS

runDbHandler :: SQL.Pool -> SQL.Mode -> Auth.JWTClaims -> Bool -> DbHandler a -> Handler IO a
runDbHandler :: Pool -> Mode -> JWTClaims -> Bool -> DbHandler a -> Handler IO a
runDbHandler Pool
pool Mode
mode JWTClaims
jwtClaims Bool
prepared DbHandler a
handler = do
  Either UsageError (Either Error a)
dbResp <-
    let transaction :: IsolationLevel -> Mode -> Transaction a -> Session a
transaction = if Bool
prepared then IsolationLevel -> Mode -> Transaction a -> Session a
forall a. IsolationLevel -> Mode -> Transaction a -> Session a
SQL.transaction else IsolationLevel -> Mode -> Transaction a -> Session a
forall a. IsolationLevel -> Mode -> Transaction a -> Session a
SQL.unpreparedTransaction in
    IO (Either UsageError (Either Error a))
-> ExceptT Error IO (Either UsageError (Either Error a))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either UsageError (Either Error a))
 -> ExceptT Error IO (Either UsageError (Either Error a)))
-> (Transaction (Either Error a)
    -> IO (Either UsageError (Either Error a)))
-> Transaction (Either Error a)
-> ExceptT Error IO (Either UsageError (Either Error a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool
-> Session (Either Error a)
-> IO (Either UsageError (Either Error a))
forall a. Pool -> Session a -> IO (Either UsageError a)
SQL.use Pool
pool (Session (Either Error a)
 -> IO (Either UsageError (Either Error a)))
-> (Transaction (Either Error a) -> Session (Either Error a))
-> Transaction (Either Error a)
-> IO (Either UsageError (Either Error a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsolationLevel
-> Mode -> Transaction (Either Error a) -> Session (Either Error a)
forall a. IsolationLevel -> Mode -> Transaction a -> Session a
transaction IsolationLevel
SQL.ReadCommitted Mode
mode (Transaction (Either Error a)
 -> ExceptT Error IO (Either UsageError (Either Error a)))
-> Transaction (Either Error a)
-> ExceptT Error IO (Either UsageError (Either Error a))
forall a b. (a -> b) -> a -> b
$ DbHandler a -> Transaction (Either Error a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT DbHandler a
handler

  Either Error a
resp <-
    Either Error (Either Error a) -> ExceptT Error IO (Either Error a)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Error (Either Error a)
 -> ExceptT Error IO (Either Error a))
-> (Either PgError (Either Error a)
    -> Either Error (Either Error a))
-> Either PgError (Either Error a)
-> ExceptT Error IO (Either Error a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PgError -> Error)
-> Either PgError (Either Error a) -> Either Error (Either Error a)
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft PgError -> Error
Error.PgErr (Either PgError (Either Error a)
 -> ExceptT Error IO (Either Error a))
-> Either PgError (Either Error a)
-> ExceptT Error IO (Either Error a)
forall a b. (a -> b) -> a -> b
$
      (UsageError -> PgError)
-> Either UsageError (Either Error a)
-> Either PgError (Either Error a)
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft (Bool -> UsageError -> PgError
Error.PgError (Bool -> UsageError -> PgError) -> Bool -> UsageError -> PgError
forall a b. (a -> b) -> a -> b
$ JWTClaims -> Bool
Auth.containsRole JWTClaims
jwtClaims) Either UsageError (Either Error a)
dbResp

  Either Error a -> Handler IO a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither Either Error a
resp

handleRequest :: RequestContext -> DbHandler Wai.Response
handleRequest :: RequestContext -> DbHandler Response
handleRequest context :: RequestContext
context@(RequestContext AppConfig
_ DbStructure
_ 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 :: 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
iAcceptContentType :: ApiRequest -> ContentType
iSchema :: ApiRequest -> Text
iProfile :: ApiRequest -> Maybe Text
iMethod :: ApiRequest -> ByteString
iPath :: ApiRequest -> ByteString
iCookies :: ApiRequest -> [(ByteString, ByteString)]
iHeaders :: ApiRequest -> [(ByteString, ByteString)]
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
iTarget :: ApiRequest -> Target
iTopLevelRange :: ApiRequest -> NonnegRange
iRange :: ApiRequest -> HashMap ByteString NonnegRange
iAction :: ApiRequest -> Action
..} PgVersion
_) =
  case (Action
iAction, Target
iTarget) of
    (ActionRead Bool
headersOnly, TargetIdent QualifiedIdentifier
identifier) ->
      Bool -> QualifiedIdentifier -> RequestContext -> DbHandler Response
handleRead Bool
headersOnly QualifiedIdentifier
identifier RequestContext
context
    (Action
ActionCreate, TargetIdent QualifiedIdentifier
identifier) ->
      QualifiedIdentifier -> RequestContext -> DbHandler Response
handleCreate QualifiedIdentifier
identifier RequestContext
context
    (Action
ActionUpdate, TargetIdent QualifiedIdentifier
identifier) ->
      QualifiedIdentifier -> RequestContext -> DbHandler Response
handleUpdate QualifiedIdentifier
identifier RequestContext
context
    (Action
ActionSingleUpsert, TargetIdent QualifiedIdentifier
identifier) ->
      QualifiedIdentifier -> RequestContext -> DbHandler Response
handleSingleUpsert QualifiedIdentifier
identifier RequestContext
context
    (Action
ActionDelete, TargetIdent QualifiedIdentifier
identifier) ->
      QualifiedIdentifier -> RequestContext -> DbHandler Response
handleDelete QualifiedIdentifier
identifier RequestContext
context
    (Action
ActionInfo, TargetIdent QualifiedIdentifier
identifier) ->
      QualifiedIdentifier -> RequestContext -> DbHandler Response
forall (m :: * -> *).
Monad m =>
QualifiedIdentifier -> RequestContext -> Handler m Response
handleInfo QualifiedIdentifier
identifier RequestContext
context
    (ActionInvoke InvokeMethod
invMethod, TargetProc ProcDescription
proc Bool
_) ->
      InvokeMethod
-> ProcDescription -> RequestContext -> DbHandler Response
handleInvoke InvokeMethod
invMethod ProcDescription
proc RequestContext
context
    (ActionInspect Bool
headersOnly, TargetDefaultSpec Text
tSchema) ->
      Bool -> Text -> RequestContext -> DbHandler Response
handleOpenApi Bool
headersOnly Text
tSchema RequestContext
context
    (Action, Target)
_ ->
      Error -> DbHandler Response
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
Error.NotFound

handleRead :: Bool -> QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
handleRead :: Bool -> QualifiedIdentifier -> RequestContext -> DbHandler Response
handleRead Bool
headersOnly QualifiedIdentifier
identifier context :: RequestContext
context@RequestContext{PgVersion
AppConfig
DbStructure
ApiRequest
ctxPgVersion :: PgVersion
ctxApiRequest :: ApiRequest
ctxDbStructure :: DbStructure
ctxConfig :: AppConfig
ctxPgVersion :: RequestContext -> PgVersion
ctxApiRequest :: RequestContext -> ApiRequest
ctxDbStructure :: RequestContext -> DbStructure
ctxConfig :: RequestContext -> AppConfig
..} = do
  ReadRequest
req <- QualifiedIdentifier
-> RequestContext -> Handler Transaction ReadRequest
forall (m :: * -> *).
Monad m =>
QualifiedIdentifier -> RequestContext -> Handler m ReadRequest
readRequest QualifiedIdentifier
identifier RequestContext
context
  Maybe Text
bField <- RequestContext -> ReadRequest -> Handler Transaction (Maybe Text)
forall (m :: * -> *).
Monad m =>
RequestContext -> ReadRequest -> Handler m (Maybe Text)
binaryField RequestContext
context ReadRequest
req

  let
    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 :: 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
iAcceptContentType :: ApiRequest -> ContentType
iSchema :: ApiRequest -> Text
iProfile :: ApiRequest -> Maybe Text
iMethod :: ApiRequest -> ByteString
iPath :: ApiRequest -> ByteString
iCookies :: ApiRequest -> [(ByteString, ByteString)]
iHeaders :: ApiRequest -> [(ByteString, ByteString)]
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
iTarget :: ApiRequest -> Target
iTopLevelRange :: ApiRequest -> NonnegRange
iRange :: ApiRequest -> HashMap ByteString NonnegRange
iAction :: ApiRequest -> Action
..} = ApiRequest
ctxApiRequest
    AppConfig{Bool
Int
[(Text, Text)]
[ByteString]
[Text]
JSPath
Maybe Integer
Maybe FilePath
Maybe ByteString
Maybe Text
Maybe StringOrURI
Maybe JWKSet
Maybe QualifiedIdentifier
Text
FileMode
NonEmpty Text
NominalDiffTime
OpenAPIMode
LogLevel
configServerUnixSocketMode :: FileMode
configServerUnixSocket :: Maybe FilePath
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 FilePath
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)]
configServerUnixSocketMode :: AppConfig -> FileMode
configServerUnixSocket :: AppConfig -> Maybe FilePath
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 FilePath
configDbUri :: AppConfig -> Text
configDbTxRollbackAll :: AppConfig -> Bool
configDbTxAllowOverride :: AppConfig -> Bool
configDbConfig :: AppConfig -> Bool
configDbSchemas :: AppConfig -> NonEmpty Text
configDbRootSpec :: AppConfig -> Maybe QualifiedIdentifier
configDbPreparedStatements :: AppConfig -> Bool
configDbPreRequest :: AppConfig -> Maybe QualifiedIdentifier
configDbPoolTimeout :: AppConfig -> NominalDiffTime
configDbPoolSize :: AppConfig -> Int
configDbMaxRows :: AppConfig -> Maybe Integer
configDbExtraSearchPath :: AppConfig -> [Text]
configDbChannelEnabled :: AppConfig -> Bool
configDbChannel :: AppConfig -> Text
configDbAnonRole :: AppConfig -> Text
configAppSettings :: AppConfig -> [(Text, Text)]
..} = AppConfig
ctxConfig
    countQuery :: Snippet
countQuery = ReadRequest -> Snippet
QueryBuilder.readRequestToCountQuery ReadRequest
req

  (Maybe Int64
tableTotal, Int64
queryTotal, [ByteString]
_ , ByteString
body, Either Error [GucHeader]
gucHeaders, Either Error (Maybe Status)
gucStatus) <-
    Transaction
  (Maybe Int64, Int64, [ByteString], ByteString,
   Either Error [GucHeader], Either Error (Maybe Status))
-> ExceptT
     Error
     Transaction
     (Maybe Int64, Int64, [ByteString], ByteString,
      Either Error [GucHeader], Either Error (Maybe Status))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction
   (Maybe Int64, Int64, [ByteString], ByteString,
    Either Error [GucHeader], Either Error (Maybe Status))
 -> ExceptT
      Error
      Transaction
      (Maybe Int64, Int64, [ByteString], ByteString,
       Either Error [GucHeader], Either Error (Maybe Status)))
-> (Statement
      ()
      (Maybe Int64, Int64, [ByteString], ByteString,
       Either Error [GucHeader], Either Error (Maybe Status))
    -> Transaction
         (Maybe Int64, Int64, [ByteString], ByteString,
          Either Error [GucHeader], Either Error (Maybe Status)))
-> Statement
     ()
     (Maybe Int64, Int64, [ByteString], ByteString,
      Either Error [GucHeader], Either Error (Maybe Status))
-> ExceptT
     Error
     Transaction
     (Maybe Int64, Int64, [ByteString], ByteString,
      Either Error [GucHeader], Either Error (Maybe Status))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ()
-> Statement
     ()
     (Maybe Int64, Int64, [ByteString], ByteString,
      Either Error [GucHeader], Either Error (Maybe Status))
-> Transaction
     (Maybe Int64, Int64, [ByteString], ByteString,
      Either Error [GucHeader], Either Error (Maybe Status))
forall a b. a -> Statement a b -> Transaction b
SQL.statement ()
forall a. Monoid a => a
mempty (Statement
   ()
   (Maybe Int64, Int64, [ByteString], ByteString,
    Either Error [GucHeader], Either Error (Maybe Status))
 -> ExceptT
      Error
      Transaction
      (Maybe Int64, Int64, [ByteString], ByteString,
       Either Error [GucHeader], Either Error (Maybe Status)))
-> Statement
     ()
     (Maybe Int64, Int64, [ByteString], ByteString,
      Either Error [GucHeader], Either Error (Maybe Status))
-> ExceptT
     Error
     Transaction
     (Maybe Int64, Int64, [ByteString], ByteString,
      Either Error [GucHeader], Either Error (Maybe Status))
forall a b. (a -> b) -> a -> b
$
      Snippet
-> Snippet
-> Bool
-> Bool
-> Bool
-> Maybe Text
-> PgVersion
-> Bool
-> Statement
     ()
     (Maybe Int64, Int64, [ByteString], ByteString,
      Either Error [GucHeader], Either Error (Maybe Status))
Statements.createReadStatement
        (ReadRequest -> Snippet
QueryBuilder.readRequestToQuery ReadRequest
req)
        (if Maybe PreferCount
iPreferCount Maybe PreferCount -> Maybe PreferCount -> Bool
forall a. Eq a => a -> a -> Bool
== PreferCount -> Maybe PreferCount
forall a. a -> Maybe a
Just PreferCount
EstimatedCount then
           -- LIMIT maxRows + 1 so we can determine below that maxRows was surpassed
           Snippet -> Maybe Integer -> Snippet
QueryBuilder.limitedQuery Snippet
countQuery ((Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) (Integer -> Integer) -> Maybe Integer -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
configDbMaxRows)
         else
           Snippet
countQuery
        )
        (ContentType
iAcceptContentType ContentType -> ContentType -> Bool
forall a. Eq a => a -> a -> Bool
== ContentType
CTSingularJSON)
        (Maybe PreferCount -> Bool
shouldCount Maybe PreferCount
iPreferCount)
        (ContentType
iAcceptContentType ContentType -> ContentType -> Bool
forall a. Eq a => a -> a -> Bool
== ContentType
CTTextCSV)
        Maybe Text
bField
        PgVersion
ctxPgVersion
        Bool
configDbPreparedStatements

  Maybe Int64
total <- AppConfig
-> ApiRequest -> Maybe Int64 -> Snippet -> DbHandler (Maybe Int64)
readTotal AppConfig
ctxConfig ApiRequest
ctxApiRequest Maybe Int64
tableTotal Snippet
countQuery
  Status -> [Header] -> ByteString -> Response
response <- Either Error (Status -> [Header] -> ByteString -> Response)
-> ExceptT
     Error Transaction (Status -> [Header] -> ByteString -> Response)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Error (Status -> [Header] -> ByteString -> Response)
 -> ExceptT
      Error Transaction (Status -> [Header] -> ByteString -> Response))
-> Either Error (Status -> [Header] -> ByteString -> Response)
-> ExceptT
     Error Transaction (Status -> [Header] -> ByteString -> Response)
forall a b. (a -> b) -> a -> b
$ Maybe Status
-> [GucHeader] -> Status -> [Header] -> ByteString -> Response
gucResponse (Maybe Status
 -> [GucHeader] -> Status -> [Header] -> ByteString -> Response)
-> Either Error (Maybe Status)
-> Either
     Error ([GucHeader] -> Status -> [Header] -> ByteString -> Response)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error (Maybe Status)
gucStatus Either
  Error ([GucHeader] -> Status -> [Header] -> ByteString -> Response)
-> Either Error [GucHeader]
-> Either Error (Status -> [Header] -> ByteString -> Response)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either Error [GucHeader]
gucHeaders

  let
    (Status
status, Header
contentRange) = NonnegRange -> Int64 -> Maybe Int64 -> (Status, Header)
RangeQuery.rangeStatusHeader NonnegRange
iTopLevelRange Int64
queryTotal Maybe Int64
total
    headers :: [Header]
headers =
      [ Header
contentRange
      , ( HeaderName
"Content-Location"
        , ByteString
"/"
            ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall a b. StringConv a b => a -> b
toS (QualifiedIdentifier -> Text
qiName QualifiedIdentifier
identifier)
            ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> if ByteString -> Bool
BS8.null ByteString
iCanonicalQS then ByteString
forall a. Monoid a => a
mempty else ByteString
"?" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
forall a b. StringConv a b => a -> b
toS ByteString
iCanonicalQS
        )
      ]
      [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ RequestContext -> [Header]
contentTypeHeaders RequestContext
context

  ContentType -> Int64 -> Response -> DbHandler Response
failNotSingular ContentType
iAcceptContentType Int64
queryTotal (Response -> DbHandler Response)
-> (ByteString -> Response) -> ByteString -> DbHandler Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> [Header] -> ByteString -> Response
response Status
status [Header]
headers (ByteString -> DbHandler Response)
-> ByteString -> DbHandler Response
forall a b. (a -> b) -> a -> b
$
    if Bool
headersOnly then ByteString
forall a. Monoid a => a
mempty else ByteString -> ByteString
forall a b. StringConv a b => a -> b
toS ByteString
body

readTotal :: AppConfig -> ApiRequest -> Maybe Int64 -> SQL.Snippet -> DbHandler (Maybe Int64)
readTotal :: AppConfig
-> ApiRequest -> Maybe Int64 -> Snippet -> DbHandler (Maybe Int64)
readTotal AppConfig{Bool
Int
[(Text, Text)]
[ByteString]
[Text]
JSPath
Maybe Integer
Maybe FilePath
Maybe ByteString
Maybe Text
Maybe StringOrURI
Maybe JWKSet
Maybe QualifiedIdentifier
Text
FileMode
NonEmpty Text
NominalDiffTime
OpenAPIMode
LogLevel
configServerUnixSocketMode :: FileMode
configServerUnixSocket :: Maybe FilePath
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 FilePath
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)]
configServerUnixSocketMode :: AppConfig -> FileMode
configServerUnixSocket :: AppConfig -> Maybe FilePath
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 FilePath
configDbUri :: AppConfig -> Text
configDbTxRollbackAll :: AppConfig -> Bool
configDbTxAllowOverride :: AppConfig -> Bool
configDbConfig :: AppConfig -> Bool
configDbSchemas :: AppConfig -> NonEmpty Text
configDbRootSpec :: AppConfig -> Maybe QualifiedIdentifier
configDbPreparedStatements :: AppConfig -> Bool
configDbPreRequest :: AppConfig -> Maybe QualifiedIdentifier
configDbPoolTimeout :: AppConfig -> NominalDiffTime
configDbPoolSize :: AppConfig -> Int
configDbMaxRows :: AppConfig -> Maybe Integer
configDbExtraSearchPath :: AppConfig -> [Text]
configDbChannelEnabled :: AppConfig -> Bool
configDbChannel :: AppConfig -> Text
configDbAnonRole :: AppConfig -> Text
configAppSettings :: AppConfig -> [(Text, Text)]
..} 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 :: 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
iAcceptContentType :: ApiRequest -> ContentType
iSchema :: ApiRequest -> Text
iProfile :: ApiRequest -> Maybe Text
iMethod :: ApiRequest -> ByteString
iPath :: ApiRequest -> ByteString
iCookies :: ApiRequest -> [(ByteString, ByteString)]
iHeaders :: ApiRequest -> [(ByteString, ByteString)]
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
iTarget :: ApiRequest -> Target
iTopLevelRange :: ApiRequest -> NonnegRange
iRange :: ApiRequest -> HashMap ByteString NonnegRange
iAction :: ApiRequest -> Action
..} Maybe Int64
tableTotal Snippet
countQuery =
  case Maybe PreferCount
iPreferCount of
    Just PreferCount
PlannedCount ->
      DbHandler (Maybe Int64)
explain
    Just PreferCount
EstimatedCount ->
      if Maybe Int64
tableTotal Maybe Int64 -> Maybe Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int64) -> Maybe Integer -> Maybe Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
configDbMaxRows) then
        Maybe Int64 -> Maybe Int64 -> Maybe Int64
forall a. Ord a => a -> a -> a
max Maybe Int64
tableTotal (Maybe Int64 -> Maybe Int64)
-> DbHandler (Maybe Int64) -> DbHandler (Maybe Int64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DbHandler (Maybe Int64)
explain
      else
        Maybe Int64 -> DbHandler (Maybe Int64)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int64
tableTotal
    Maybe PreferCount
_ ->
      Maybe Int64 -> DbHandler (Maybe Int64)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int64
tableTotal
  where
    explain :: DbHandler (Maybe Int64)
explain =
      Transaction (Maybe Int64) -> DbHandler (Maybe Int64)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction (Maybe Int64) -> DbHandler (Maybe Int64))
-> (Bool -> Transaction (Maybe Int64))
-> Bool
-> DbHandler (Maybe Int64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Statement () (Maybe Int64) -> Transaction (Maybe Int64)
forall a b. a -> Statement a b -> Transaction b
SQL.statement ()
forall a. Monoid a => a
mempty (Statement () (Maybe Int64) -> Transaction (Maybe Int64))
-> (Bool -> Statement () (Maybe Int64))
-> Bool
-> Transaction (Maybe Int64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Snippet -> Bool -> Statement () (Maybe Int64)
Statements.createExplainStatement Snippet
countQuery (Bool -> DbHandler (Maybe Int64))
-> Bool -> DbHandler (Maybe Int64)
forall a b. (a -> b) -> a -> b
$
        Bool
configDbPreparedStatements

handleCreate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
handleCreate :: QualifiedIdentifier -> RequestContext -> DbHandler Response
handleCreate identifier :: QualifiedIdentifier
identifier@QualifiedIdentifier{Text
qiSchema :: QualifiedIdentifier -> Text
qiName :: Text
qiSchema :: Text
qiName :: QualifiedIdentifier -> Text
..} context :: RequestContext
context@RequestContext{PgVersion
AppConfig
DbStructure
ApiRequest
ctxPgVersion :: PgVersion
ctxApiRequest :: ApiRequest
ctxDbStructure :: DbStructure
ctxConfig :: AppConfig
ctxPgVersion :: RequestContext -> PgVersion
ctxApiRequest :: RequestContext -> ApiRequest
ctxDbStructure :: RequestContext -> DbStructure
ctxConfig :: RequestContext -> AppConfig
..} = do
  let
    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 :: 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
iAcceptContentType :: ApiRequest -> ContentType
iSchema :: ApiRequest -> Text
iProfile :: ApiRequest -> Maybe Text
iMethod :: ApiRequest -> ByteString
iPath :: ApiRequest -> ByteString
iCookies :: ApiRequest -> [(ByteString, ByteString)]
iHeaders :: ApiRequest -> [(ByteString, ByteString)]
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
iTarget :: ApiRequest -> Target
iTopLevelRange :: ApiRequest -> NonnegRange
iRange :: ApiRequest -> HashMap ByteString NonnegRange
iAction :: ApiRequest -> Action
..} = ApiRequest
ctxApiRequest
    pkCols :: [Text]
pkCols = DbStructure -> Text -> Text -> [Text]
tablePKCols DbStructure
ctxDbStructure Text
qiSchema Text
qiName

  WriteQueryResult{Int64
[ByteString]
[GucHeader]
Maybe Status
ByteString
resGucHeaders :: WriteQueryResult -> [GucHeader]
resGucStatus :: WriteQueryResult -> Maybe Status
resBody :: WriteQueryResult -> ByteString
resFields :: WriteQueryResult -> [ByteString]
resQueryTotal :: WriteQueryResult -> Int64
resGucHeaders :: [GucHeader]
resGucStatus :: Maybe Status
resBody :: ByteString
resFields :: [ByteString]
resQueryTotal :: Int64
..} <- QualifiedIdentifier
-> Bool -> [Text] -> RequestContext -> DbHandler WriteQueryResult
writeQuery QualifiedIdentifier
identifier Bool
True [Text]
pkCols RequestContext
context

  let
    response :: Status -> [Header] -> ByteString -> Response
response = Maybe Status
-> [GucHeader] -> Status -> [Header] -> ByteString -> Response
gucResponse Maybe Status
resGucStatus [GucHeader]
resGucHeaders
    headers :: [Header]
headers =
      [Maybe Header] -> [Header]
forall a. [Maybe a] -> [a]
catMaybes
        [ if [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
resFields then
            Maybe Header
forall a. Maybe a
Nothing
          else
            Header -> Maybe Header
forall a. a -> Maybe a
Just
              ( HeaderName
HTTP.hLocation
              , ByteString
"/"
                  ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall a b. StringConv a b => a -> b
toS Text
qiName
                  ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Bool -> [(ByteString, ByteString)] -> ByteString
HTTP.renderSimpleQuery Bool
True (ByteString -> (ByteString, ByteString)
splitKeyValue (ByteString -> (ByteString, ByteString))
-> [ByteString] -> [(ByteString, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString]
resFields)
              )
        , Header -> Maybe Header
forall a. a -> Maybe a
Just (Header -> Maybe Header)
-> (Maybe Int64 -> Header) -> Maybe Int64 -> Maybe Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int64 -> Maybe Int64 -> Header
forall a. (Integral a, Show a) => a -> a -> Maybe a -> Header
RangeQuery.contentRangeH Int64
1 Int64
0 (Maybe Int64 -> Maybe Header) -> Maybe Int64 -> Maybe Header
forall a b. (a -> b) -> a -> b
$
            if Maybe PreferCount -> Bool
shouldCount Maybe PreferCount
iPreferCount then Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
resQueryTotal else Maybe Int64
forall a. Maybe a
Nothing
        , if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
pkCols Bool -> Bool -> Bool
&& Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Text
iOnConflict then
            Maybe Header
forall a. Maybe a
Nothing
          else
            (\PreferResolution
x -> (HeaderName
"Preference-Applied", FilePath -> ByteString
BS8.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ PreferResolution -> FilePath
forall a b. (Show a, ConvertText FilePath b) => a -> b
show PreferResolution
x)) (PreferResolution -> Header)
-> Maybe PreferResolution -> Maybe Header
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PreferResolution
iPreferResolution
        ]

  ContentType -> Int64 -> Response -> DbHandler Response
failNotSingular ContentType
iAcceptContentType Int64
resQueryTotal (Response -> DbHandler Response) -> Response -> DbHandler Response
forall a b. (a -> b) -> a -> b
$
    if PreferRepresentation
iPreferRepresentation PreferRepresentation -> PreferRepresentation -> Bool
forall a. Eq a => a -> a -> Bool
== PreferRepresentation
Full then
      Status -> [Header] -> ByteString -> Response
response Status
HTTP.status201 ([Header]
headers [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ RequestContext -> [Header]
contentTypeHeaders RequestContext
context) (ByteString -> ByteString
forall a b. StringConv a b => a -> b
toS ByteString
resBody)
    else
      Status -> [Header] -> ByteString -> Response
response Status
HTTP.status201 [Header]
headers ByteString
forall a. Monoid a => a
mempty

handleUpdate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
handleUpdate :: QualifiedIdentifier -> RequestContext -> DbHandler Response
handleUpdate QualifiedIdentifier
identifier context :: RequestContext
context@(RequestContext AppConfig
_ DbStructure
_ 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 :: 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
iAcceptContentType :: ApiRequest -> ContentType
iSchema :: ApiRequest -> Text
iProfile :: ApiRequest -> Maybe Text
iMethod :: ApiRequest -> ByteString
iPath :: ApiRequest -> ByteString
iCookies :: ApiRequest -> [(ByteString, ByteString)]
iHeaders :: ApiRequest -> [(ByteString, ByteString)]
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
iTarget :: ApiRequest -> Target
iTopLevelRange :: ApiRequest -> NonnegRange
iRange :: ApiRequest -> HashMap ByteString NonnegRange
iAction :: ApiRequest -> Action
..} PgVersion
_) = do
  WriteQueryResult{Int64
[ByteString]
[GucHeader]
Maybe Status
ByteString
resGucHeaders :: [GucHeader]
resGucStatus :: Maybe Status
resBody :: ByteString
resFields :: [ByteString]
resQueryTotal :: Int64
resGucHeaders :: WriteQueryResult -> [GucHeader]
resGucStatus :: WriteQueryResult -> Maybe Status
resBody :: WriteQueryResult -> ByteString
resFields :: WriteQueryResult -> [ByteString]
resQueryTotal :: WriteQueryResult -> Int64
..} <- QualifiedIdentifier
-> Bool -> [Text] -> RequestContext -> DbHandler WriteQueryResult
writeQuery QualifiedIdentifier
identifier Bool
False [Text]
forall a. Monoid a => a
mempty RequestContext
context

  let
    response :: Status -> [Header] -> ByteString -> Response
response = Maybe Status
-> [GucHeader] -> Status -> [Header] -> ByteString -> Response
gucResponse Maybe Status
resGucStatus [GucHeader]
resGucHeaders
    fullRepr :: Bool
fullRepr = PreferRepresentation
iPreferRepresentation PreferRepresentation -> PreferRepresentation -> Bool
forall a. Eq a => a -> a -> Bool
== PreferRepresentation
Full
    updateIsNoOp :: Bool
updateIsNoOp = Set Text -> Bool
forall a. Set a -> Bool
Set.null Set Text
iColumns
    status :: Status
status
      | Int64
resQueryTotal Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
updateIsNoOp = Status
HTTP.status404
      | Bool
fullRepr = Status
HTTP.status200
      | Bool
otherwise = Status
HTTP.status204
    contentRangeHeader :: Header
contentRangeHeader =
      Int64 -> Int64 -> Maybe Int64 -> Header
forall a. (Integral a, Show a) => a -> a -> Maybe a -> Header
RangeQuery.contentRangeH Int64
0 (Int64
resQueryTotal Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
1) (Maybe Int64 -> Header) -> Maybe Int64 -> Header
forall a b. (a -> b) -> a -> b
$
        if Maybe PreferCount -> Bool
shouldCount Maybe PreferCount
iPreferCount then Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
resQueryTotal else Maybe Int64
forall a. Maybe a
Nothing

  ContentType -> Int64 -> Response -> DbHandler Response
failNotSingular ContentType
iAcceptContentType Int64
resQueryTotal (Response -> DbHandler Response) -> Response -> DbHandler Response
forall a b. (a -> b) -> a -> b
$
    if Bool
fullRepr then
      Status -> [Header] -> ByteString -> Response
response Status
status (RequestContext -> [Header]
contentTypeHeaders RequestContext
context [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [Header
contentRangeHeader]) (ByteString -> ByteString
forall a b. StringConv a b => a -> b
toS ByteString
resBody)
    else
      Status -> [Header] -> ByteString -> Response
response Status
status [Header
contentRangeHeader] ByteString
forall a. Monoid a => a
mempty

handleSingleUpsert :: QualifiedIdentifier -> RequestContext-> DbHandler Wai.Response
handleSingleUpsert :: QualifiedIdentifier -> RequestContext -> DbHandler Response
handleSingleUpsert QualifiedIdentifier
identifier context :: RequestContext
context@(RequestContext AppConfig
_ DbStructure
_ 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 :: 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
iAcceptContentType :: ApiRequest -> ContentType
iSchema :: ApiRequest -> Text
iProfile :: ApiRequest -> Maybe Text
iMethod :: ApiRequest -> ByteString
iPath :: ApiRequest -> ByteString
iCookies :: ApiRequest -> [(ByteString, ByteString)]
iHeaders :: ApiRequest -> [(ByteString, ByteString)]
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
iTarget :: ApiRequest -> Target
iTopLevelRange :: ApiRequest -> NonnegRange
iRange :: ApiRequest -> HashMap ByteString NonnegRange
iAction :: ApiRequest -> Action
..} PgVersion
_) = do
  Bool
-> ExceptT Error Transaction () -> ExceptT Error Transaction ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NonnegRange
iTopLevelRange NonnegRange -> NonnegRange -> Bool
forall a. Eq a => a -> a -> Bool
/= NonnegRange
RangeQuery.allRange) (ExceptT Error Transaction () -> ExceptT Error Transaction ())
-> ExceptT Error Transaction () -> ExceptT Error Transaction ()
forall a b. (a -> b) -> a -> b
$
    Error -> ExceptT Error Transaction ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
Error.PutRangeNotAllowedError

  WriteQueryResult{Int64
[ByteString]
[GucHeader]
Maybe Status
ByteString
resGucHeaders :: [GucHeader]
resGucStatus :: Maybe Status
resBody :: ByteString
resFields :: [ByteString]
resQueryTotal :: Int64
resGucHeaders :: WriteQueryResult -> [GucHeader]
resGucStatus :: WriteQueryResult -> Maybe Status
resBody :: WriteQueryResult -> ByteString
resFields :: WriteQueryResult -> [ByteString]
resQueryTotal :: WriteQueryResult -> Int64
..} <- QualifiedIdentifier
-> Bool -> [Text] -> RequestContext -> DbHandler WriteQueryResult
writeQuery QualifiedIdentifier
identifier Bool
False [Text]
forall a. Monoid a => a
mempty RequestContext
context

  let response :: Status -> [Header] -> ByteString -> Response
response = Maybe Status
-> [GucHeader] -> Status -> [Header] -> ByteString -> Response
gucResponse Maybe Status
resGucStatus [GucHeader]
resGucHeaders

  -- Makes sure the querystring pk matches the payload pk
  -- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted,
  -- PUT /items?id=eq.14 { "id" : 2, .. } is rejected.
  -- If this condition is not satisfied then nothing is inserted,
  -- check the WHERE for INSERT in QueryBuilder.hs to see how it's done
  Bool
-> ExceptT Error Transaction () -> ExceptT Error Transaction ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
resQueryTotal Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
1) (ExceptT Error Transaction () -> ExceptT Error Transaction ())
-> ExceptT Error Transaction () -> ExceptT Error Transaction ()
forall a b. (a -> b) -> a -> b
$ do
    Transaction () -> ExceptT Error Transaction ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Transaction ()
SQL.condemn
    Error -> ExceptT Error Transaction ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
Error.PutMatchingPkError

  Response -> DbHandler Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> DbHandler Response) -> Response -> DbHandler Response
forall a b. (a -> b) -> a -> b
$
    if PreferRepresentation
iPreferRepresentation PreferRepresentation -> PreferRepresentation -> Bool
forall a. Eq a => a -> a -> Bool
== PreferRepresentation
Full then
      Status -> [Header] -> ByteString -> Response
response Status
HTTP.status200 (RequestContext -> [Header]
contentTypeHeaders RequestContext
context) (ByteString -> ByteString
forall a b. StringConv a b => a -> b
toS ByteString
resBody)
    else
      Status -> [Header] -> ByteString -> Response
response Status
HTTP.status204 (RequestContext -> [Header]
contentTypeHeaders RequestContext
context) ByteString
forall a. Monoid a => a
mempty

handleDelete :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
handleDelete :: QualifiedIdentifier -> RequestContext -> DbHandler Response
handleDelete QualifiedIdentifier
identifier context :: RequestContext
context@(RequestContext AppConfig
_ DbStructure
_ 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 :: 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
iAcceptContentType :: ApiRequest -> ContentType
iSchema :: ApiRequest -> Text
iProfile :: ApiRequest -> Maybe Text
iMethod :: ApiRequest -> ByteString
iPath :: ApiRequest -> ByteString
iCookies :: ApiRequest -> [(ByteString, ByteString)]
iHeaders :: ApiRequest -> [(ByteString, ByteString)]
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
iTarget :: ApiRequest -> Target
iTopLevelRange :: ApiRequest -> NonnegRange
iRange :: ApiRequest -> HashMap ByteString NonnegRange
iAction :: ApiRequest -> Action
..} PgVersion
_) = do
  WriteQueryResult{Int64
[ByteString]
[GucHeader]
Maybe Status
ByteString
resGucHeaders :: [GucHeader]
resGucStatus :: Maybe Status
resBody :: ByteString
resFields :: [ByteString]
resQueryTotal :: Int64
resGucHeaders :: WriteQueryResult -> [GucHeader]
resGucStatus :: WriteQueryResult -> Maybe Status
resBody :: WriteQueryResult -> ByteString
resFields :: WriteQueryResult -> [ByteString]
resQueryTotal :: WriteQueryResult -> Int64
..} <- QualifiedIdentifier
-> Bool -> [Text] -> RequestContext -> DbHandler WriteQueryResult
writeQuery QualifiedIdentifier
identifier Bool
False [Text]
forall a. Monoid a => a
mempty RequestContext
context

  let
    response :: Status -> [Header] -> ByteString -> Response
response = Maybe Status
-> [GucHeader] -> Status -> [Header] -> ByteString -> Response
gucResponse Maybe Status
resGucStatus [GucHeader]
resGucHeaders
    contentRangeHeader :: Header
contentRangeHeader =
      Int64 -> Int64 -> Maybe Int64 -> Header
forall a. (Integral a, Show a) => a -> a -> Maybe a -> Header
RangeQuery.contentRangeH Int64
1 Int64
0 (Maybe Int64 -> Header) -> Maybe Int64 -> Header
forall a b. (a -> b) -> a -> b
$
        if Maybe PreferCount -> Bool
shouldCount Maybe PreferCount
iPreferCount then Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
resQueryTotal else Maybe Int64
forall a. Maybe a
Nothing

  ContentType -> Int64 -> Response -> DbHandler Response
failNotSingular ContentType
iAcceptContentType Int64
resQueryTotal (Response -> DbHandler Response) -> Response -> DbHandler Response
forall a b. (a -> b) -> a -> b
$
    if PreferRepresentation
iPreferRepresentation PreferRepresentation -> PreferRepresentation -> Bool
forall a. Eq a => a -> a -> Bool
== PreferRepresentation
Full then
      Status -> [Header] -> ByteString -> Response
response Status
HTTP.status200
        (RequestContext -> [Header]
contentTypeHeaders RequestContext
context [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [Header
contentRangeHeader])
        (ByteString -> ByteString
forall a b. StringConv a b => a -> b
toS ByteString
resBody)
    else
      Status -> [Header] -> ByteString -> Response
response Status
HTTP.status204 [Header
contentRangeHeader] ByteString
forall a. Monoid a => a
mempty

handleInfo :: Monad m => QualifiedIdentifier -> RequestContext -> Handler m Wai.Response
handleInfo :: QualifiedIdentifier -> RequestContext -> Handler m Response
handleInfo QualifiedIdentifier
identifier RequestContext{PgVersion
AppConfig
DbStructure
ApiRequest
ctxPgVersion :: PgVersion
ctxApiRequest :: ApiRequest
ctxDbStructure :: DbStructure
ctxConfig :: AppConfig
ctxPgVersion :: RequestContext -> PgVersion
ctxApiRequest :: RequestContext -> ApiRequest
ctxDbStructure :: RequestContext -> DbStructure
ctxConfig :: RequestContext -> AppConfig
..} =
  case (Table -> Bool) -> [Table] -> Maybe Table
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Table -> Bool
tableMatches ([Table] -> Maybe Table) -> [Table] -> Maybe Table
forall a b. (a -> b) -> a -> b
$ DbStructure -> [Table]
dbTables DbStructure
ctxDbStructure of
    Just Table
table ->
      Response -> Handler m Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> Handler m Response) -> Response -> Handler m Response
forall a b. (a -> b) -> a -> b
$ Status -> [Header] -> ByteString -> Response
Wai.responseLBS Status
HTTP.status200 [Header
allOrigins, Table -> Header
allowH Table
table] ByteString
forall a. Monoid a => a
mempty
    Maybe Table
Nothing ->
      Error -> Handler m Response
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
Error.NotFound
  where
    allOrigins :: Header
allOrigins = (HeaderName
"Access-Control-Allow-Origin", ByteString
"*")
    allowH :: Table -> Header
allowH Table
table =
      ( HeaderName
HTTP.hAllow
      , ByteString -> [ByteString] -> ByteString
BS8.intercalate ByteString
"," ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
          [ByteString
"OPTIONS,GET,HEAD"]
          [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
"POST" | Table -> Bool
tableInsertable Table
table]
          [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
"PUT" | Table -> Bool
tableInsertable Table
table Bool -> Bool -> Bool
&& Table -> Bool
tableUpdatable Table
table Bool -> Bool -> Bool
&& Bool
hasPK]
          [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
"PATCH" | Table -> Bool
tableUpdatable Table
table]
          [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
"DELETE" | Table -> Bool
tableDeletable Table
table]
      )
    tableMatches :: Table -> Bool
tableMatches Table
table =
      Table -> Text
tableName Table
table Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== QualifiedIdentifier -> Text
qiName QualifiedIdentifier
identifier
      Bool -> Bool -> Bool
&& Table -> Text
tableSchema Table
table Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== QualifiedIdentifier -> Text
qiSchema QualifiedIdentifier
identifier
    hasPK :: Bool
hasPK =
      Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$ DbStructure -> Text -> Text -> [Text]
tablePKCols DbStructure
ctxDbStructure (QualifiedIdentifier -> Text
qiSchema QualifiedIdentifier
identifier) (QualifiedIdentifier -> Text
qiName QualifiedIdentifier
identifier)

handleInvoke :: InvokeMethod -> ProcDescription -> RequestContext -> DbHandler Wai.Response
handleInvoke :: InvokeMethod
-> ProcDescription -> RequestContext -> DbHandler Response
handleInvoke InvokeMethod
invMethod ProcDescription
proc context :: RequestContext
context@RequestContext{PgVersion
AppConfig
DbStructure
ApiRequest
ctxPgVersion :: PgVersion
ctxApiRequest :: ApiRequest
ctxDbStructure :: DbStructure
ctxConfig :: AppConfig
ctxPgVersion :: RequestContext -> PgVersion
ctxApiRequest :: RequestContext -> ApiRequest
ctxDbStructure :: RequestContext -> DbStructure
ctxConfig :: RequestContext -> AppConfig
..} = do
  let
    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 :: 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
iAcceptContentType :: ApiRequest -> ContentType
iSchema :: ApiRequest -> Text
iProfile :: ApiRequest -> Maybe Text
iMethod :: ApiRequest -> ByteString
iPath :: ApiRequest -> ByteString
iCookies :: ApiRequest -> [(ByteString, ByteString)]
iHeaders :: ApiRequest -> [(ByteString, ByteString)]
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
iTarget :: ApiRequest -> Target
iTopLevelRange :: ApiRequest -> NonnegRange
iRange :: ApiRequest -> HashMap ByteString NonnegRange
iAction :: ApiRequest -> Action
..} = ApiRequest
ctxApiRequest

    identifier :: QualifiedIdentifier
identifier =
      Text -> Text -> QualifiedIdentifier
QualifiedIdentifier
        (ProcDescription -> Text
pdSchema ProcDescription
proc)
        (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (ProcDescription -> Text
pdName ProcDescription
proc) (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ ProcDescription -> Maybe Text
Proc.procTableName ProcDescription
proc)

    returnsSingle :: Target -> Bool
returnsSingle (ApiRequest.TargetProc ProcDescription
target Bool
_) = ProcDescription -> Bool
Proc.procReturnsSingle ProcDescription
target
    returnsSingle Target
_                                = Bool
False

  ReadRequest
req <- QualifiedIdentifier
-> RequestContext -> Handler Transaction ReadRequest
forall (m :: * -> *).
Monad m =>
QualifiedIdentifier -> RequestContext -> Handler m ReadRequest
readRequest QualifiedIdentifier
identifier RequestContext
context
  Maybe Text
bField <- RequestContext -> ReadRequest -> Handler Transaction (Maybe Text)
forall (m :: * -> *).
Monad m =>
RequestContext -> ReadRequest -> Handler m (Maybe Text)
binaryField RequestContext
context ReadRequest
req

  (Maybe Int64
tableTotal, Int64
queryTotal, ByteString
body, Either Error [GucHeader]
gucHeaders, Either Error (Maybe Status)
gucStatus) <-
    Transaction
  (Maybe Int64, Int64, ByteString, Either Error [GucHeader],
   Either Error (Maybe Status))
-> ExceptT
     Error
     Transaction
     (Maybe Int64, Int64, ByteString, Either Error [GucHeader],
      Either Error (Maybe Status))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction
   (Maybe Int64, Int64, ByteString, Either Error [GucHeader],
    Either Error (Maybe Status))
 -> ExceptT
      Error
      Transaction
      (Maybe Int64, Int64, ByteString, Either Error [GucHeader],
       Either Error (Maybe Status)))
-> (Statement
      ()
      (Maybe Int64, Int64, ByteString, Either Error [GucHeader],
       Either Error (Maybe Status))
    -> Transaction
         (Maybe Int64, Int64, ByteString, Either Error [GucHeader],
          Either Error (Maybe Status)))
-> Statement
     ()
     (Maybe Int64, Int64, ByteString, Either Error [GucHeader],
      Either Error (Maybe Status))
-> ExceptT
     Error
     Transaction
     (Maybe Int64, Int64, ByteString, Either Error [GucHeader],
      Either Error (Maybe Status))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ()
-> Statement
     ()
     (Maybe Int64, Int64, ByteString, Either Error [GucHeader],
      Either Error (Maybe Status))
-> Transaction
     (Maybe Int64, Int64, ByteString, Either Error [GucHeader],
      Either Error (Maybe Status))
forall a b. a -> Statement a b -> Transaction b
SQL.statement ()
forall a. Monoid a => a
mempty (Statement
   ()
   (Maybe Int64, Int64, ByteString, Either Error [GucHeader],
    Either Error (Maybe Status))
 -> ExceptT
      Error
      Transaction
      (Maybe Int64, Int64, ByteString, Either Error [GucHeader],
       Either Error (Maybe Status)))
-> Statement
     ()
     (Maybe Int64, Int64, ByteString, Either Error [GucHeader],
      Either Error (Maybe Status))
-> ExceptT
     Error
     Transaction
     (Maybe Int64, Int64, ByteString, Either Error [GucHeader],
      Either Error (Maybe Status))
forall a b. (a -> b) -> a -> b
$
      Bool
-> Bool
-> Snippet
-> Snippet
-> Snippet
-> Bool
-> Bool
-> Bool
-> Bool
-> Maybe Text
-> PgVersion
-> Bool
-> Statement
     ()
     (Maybe Int64, Int64, ByteString, Either Error [GucHeader],
      Either Error (Maybe Status))
Statements.callProcStatement
        (Target -> Bool
returnsScalar Target
iTarget)
        (Target -> Bool
returnsSingle Target
iTarget)
        (QualifiedIdentifier
-> [PgArg]
-> Maybe PayloadJSON
-> Bool
-> Maybe PreferParameters
-> [Text]
-> Snippet
QueryBuilder.requestToCallProcQuery
          (Text -> Text -> QualifiedIdentifier
QualifiedIdentifier (ProcDescription -> Text
pdSchema ProcDescription
proc) (ProcDescription -> Text
pdName ProcDescription
proc))
          (Set Text -> ProcDescription -> [PgArg]
Proc.specifiedProcArgs Set Text
iColumns ProcDescription
proc)
          Maybe PayloadJSON
iPayload
          (Target -> Bool
returnsScalar Target
iTarget)
          Maybe PreferParameters
iPreferParameters
          (ReadRequest -> [Text] -> [Text]
ReqBuilder.returningCols ReadRequest
req [])
        )
        (ReadRequest -> Snippet
QueryBuilder.readRequestToQuery ReadRequest
req)
        (ReadRequest -> Snippet
QueryBuilder.readRequestToCountQuery ReadRequest
req)
        (Maybe PreferCount -> Bool
shouldCount Maybe PreferCount
iPreferCount)
        (ContentType
iAcceptContentType ContentType -> ContentType -> Bool
forall a. Eq a => a -> a -> Bool
== ContentType
CTSingularJSON)
        (ContentType
iAcceptContentType ContentType -> ContentType -> Bool
forall a. Eq a => a -> a -> Bool
== ContentType
CTTextCSV)
        (Maybe PreferParameters
iPreferParameters Maybe PreferParameters -> Maybe PreferParameters -> Bool
forall a. Eq a => a -> a -> Bool
== PreferParameters -> Maybe PreferParameters
forall a. a -> Maybe a
Just PreferParameters
MultipleObjects)
        Maybe Text
bField
        PgVersion
ctxPgVersion
        (AppConfig -> Bool
configDbPreparedStatements AppConfig
ctxConfig)

  Status -> [Header] -> ByteString -> Response
response <- Either Error (Status -> [Header] -> ByteString -> Response)
-> ExceptT
     Error Transaction (Status -> [Header] -> ByteString -> Response)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Error (Status -> [Header] -> ByteString -> Response)
 -> ExceptT
      Error Transaction (Status -> [Header] -> ByteString -> Response))
-> Either Error (Status -> [Header] -> ByteString -> Response)
-> ExceptT
     Error Transaction (Status -> [Header] -> ByteString -> Response)
forall a b. (a -> b) -> a -> b
$ Maybe Status
-> [GucHeader] -> Status -> [Header] -> ByteString -> Response
gucResponse (Maybe Status
 -> [GucHeader] -> Status -> [Header] -> ByteString -> Response)
-> Either Error (Maybe Status)
-> Either
     Error ([GucHeader] -> Status -> [Header] -> ByteString -> Response)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error (Maybe Status)
gucStatus Either
  Error ([GucHeader] -> Status -> [Header] -> ByteString -> Response)
-> Either Error [GucHeader]
-> Either Error (Status -> [Header] -> ByteString -> Response)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either Error [GucHeader]
gucHeaders

  let
    (Status
status, Header
contentRange) =
      NonnegRange -> Int64 -> Maybe Int64 -> (Status, Header)
RangeQuery.rangeStatusHeader NonnegRange
iTopLevelRange Int64
queryTotal Maybe Int64
tableTotal

  ContentType -> Int64 -> Response -> DbHandler Response
failNotSingular ContentType
iAcceptContentType Int64
queryTotal (Response -> DbHandler Response) -> Response -> DbHandler Response
forall a b. (a -> b) -> a -> b
$
    Status -> [Header] -> ByteString -> Response
response Status
status
      (RequestContext -> [Header]
contentTypeHeaders RequestContext
context [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [Header
contentRange])
      (if InvokeMethod
invMethod InvokeMethod -> InvokeMethod -> Bool
forall a. Eq a => a -> a -> Bool
== InvokeMethod
InvHead then ByteString
forall a. Monoid a => a
mempty else ByteString -> ByteString
forall a b. StringConv a b => a -> b
toS ByteString
body)

handleOpenApi :: Bool -> Schema -> RequestContext -> DbHandler Wai.Response
handleOpenApi :: Bool -> Text -> RequestContext -> DbHandler Response
handleOpenApi Bool
headersOnly Text
tSchema (RequestContext conf :: AppConfig
conf@AppConfig{Bool
Int
[(Text, Text)]
[ByteString]
[Text]
JSPath
Maybe Integer
Maybe FilePath
Maybe ByteString
Maybe Text
Maybe StringOrURI
Maybe JWKSet
Maybe QualifiedIdentifier
Text
FileMode
NonEmpty Text
NominalDiffTime
OpenAPIMode
LogLevel
configServerUnixSocketMode :: FileMode
configServerUnixSocket :: Maybe FilePath
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 FilePath
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)]
configServerUnixSocketMode :: AppConfig -> FileMode
configServerUnixSocket :: AppConfig -> Maybe FilePath
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 FilePath
configDbUri :: AppConfig -> Text
configDbTxRollbackAll :: AppConfig -> Bool
configDbTxAllowOverride :: AppConfig -> Bool
configDbConfig :: AppConfig -> Bool
configDbSchemas :: AppConfig -> NonEmpty Text
configDbRootSpec :: AppConfig -> Maybe QualifiedIdentifier
configDbPreparedStatements :: AppConfig -> Bool
configDbPreRequest :: AppConfig -> Maybe QualifiedIdentifier
configDbPoolTimeout :: AppConfig -> NominalDiffTime
configDbPoolSize :: AppConfig -> Int
configDbMaxRows :: AppConfig -> Maybe Integer
configDbExtraSearchPath :: AppConfig -> [Text]
configDbChannelEnabled :: AppConfig -> Bool
configDbChannel :: AppConfig -> Text
configDbAnonRole :: AppConfig -> Text
configAppSettings :: AppConfig -> [(Text, Text)]
..} DbStructure
dbStructure ApiRequest
apiRequest PgVersion
_) = do
  ByteString
body <-
    Transaction ByteString -> ExceptT Error Transaction ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction ByteString -> ExceptT Error Transaction ByteString)
-> Transaction ByteString -> ExceptT Error Transaction ByteString
forall a b. (a -> b) -> a -> b
$ case OpenAPIMode
configOpenApiMode of
      OpenAPIMode
OAFollowPriv ->
        AppConfig
-> DbStructure
-> [Table]
-> HashMap QualifiedIdentifier [ProcDescription]
-> Maybe Text
-> ByteString
forall k.
AppConfig
-> DbStructure
-> [Table]
-> HashMap k [ProcDescription]
-> Maybe Text
-> ByteString
OpenAPI.encode AppConfig
conf DbStructure
dbStructure
           ([Table]
 -> HashMap QualifiedIdentifier [ProcDescription]
 -> Maybe Text
 -> ByteString)
-> Transaction [Table]
-> Transaction
     (HashMap QualifiedIdentifier [ProcDescription]
      -> Maybe Text -> ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Statement Text [Table] -> Transaction [Table]
forall a b. a -> Statement a b -> Transaction b
SQL.statement Text
tSchema (Bool -> Statement Text [Table]
DbStructure.accessibleTables Bool
configDbPreparedStatements)
           Transaction
  (HashMap QualifiedIdentifier [ProcDescription]
   -> Maybe Text -> ByteString)
-> Transaction (HashMap QualifiedIdentifier [ProcDescription])
-> Transaction (Maybe Text -> ByteString)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text
-> Statement Text (HashMap QualifiedIdentifier [ProcDescription])
-> Transaction (HashMap QualifiedIdentifier [ProcDescription])
forall a b. a -> Statement a b -> Transaction b
SQL.statement Text
tSchema (Bool
-> Statement Text (HashMap QualifiedIdentifier [ProcDescription])
DbStructure.accessibleProcs Bool
configDbPreparedStatements)
           Transaction (Maybe Text -> ByteString)
-> Transaction (Maybe Text) -> Transaction ByteString
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Statement Text (Maybe Text) -> Transaction (Maybe Text)
forall a b. a -> Statement a b -> Transaction b
SQL.statement Text
tSchema (Bool -> Statement Text (Maybe Text)
DbStructure.schemaDescription Bool
configDbPreparedStatements)
      OpenAPIMode
OAIgnorePriv ->
        AppConfig
-> DbStructure
-> [Table]
-> HashMap QualifiedIdentifier [ProcDescription]
-> Maybe Text
-> ByteString
forall k.
AppConfig
-> DbStructure
-> [Table]
-> HashMap k [ProcDescription]
-> Maybe Text
-> ByteString
OpenAPI.encode AppConfig
conf DbStructure
dbStructure
              ((Table -> Bool) -> [Table] -> [Table]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Table
x -> Table -> Text
tableSchema Table
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
tSchema) ([Table] -> [Table]) -> [Table] -> [Table]
forall a b. (a -> b) -> a -> b
$ DbStructure -> [Table]
DbStructure.dbTables DbStructure
dbStructure)
              ((QualifiedIdentifier -> [ProcDescription] -> Bool)
-> HashMap QualifiedIdentifier [ProcDescription]
-> HashMap QualifiedIdentifier [ProcDescription]
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
Map.filterWithKey (\(QualifiedIdentifier Text
sch Text
_) [ProcDescription]
_ ->  Text
sch Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
tSchema) (HashMap QualifiedIdentifier [ProcDescription]
 -> HashMap QualifiedIdentifier [ProcDescription])
-> HashMap QualifiedIdentifier [ProcDescription]
-> HashMap QualifiedIdentifier [ProcDescription]
forall a b. (a -> b) -> a -> b
$ DbStructure -> HashMap QualifiedIdentifier [ProcDescription]
DbStructure.dbProcs DbStructure
dbStructure)
          (Maybe Text -> ByteString)
-> Transaction (Maybe Text) -> Transaction ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Statement Text (Maybe Text) -> Transaction (Maybe Text)
forall a b. a -> Statement a b -> Transaction b
SQL.statement Text
tSchema (Bool -> Statement Text (Maybe Text)
DbStructure.schemaDescription Bool
configDbPreparedStatements)
      OpenAPIMode
OADisabled ->
        ByteString -> Transaction ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
forall a. Monoid a => a
mempty

  Response -> DbHandler Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> DbHandler Response) -> Response -> DbHandler Response
forall a b. (a -> b) -> a -> b
$
    Status -> [Header] -> ByteString -> Response
Wai.responseLBS Status
HTTP.status200
      (ContentType -> Header
ContentType.toHeader ContentType
CTOpenAPI Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: Maybe Header -> [Header]
forall a. Maybe a -> [a]
maybeToList (ApiRequest -> Maybe Header
profileHeader ApiRequest
apiRequest))
      (if Bool
headersOnly then ByteString
forall a. Monoid a => a
mempty else ByteString -> ByteString
forall a b. StringConv a b => a -> b
toS ByteString
body)

txMode :: ApiRequest -> SQL.Mode
txMode :: ApiRequest -> Mode
txMode 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 :: 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
iAcceptContentType :: ApiRequest -> ContentType
iSchema :: ApiRequest -> Text
iProfile :: ApiRequest -> Maybe Text
iMethod :: ApiRequest -> ByteString
iPath :: ApiRequest -> ByteString
iCookies :: ApiRequest -> [(ByteString, ByteString)]
iHeaders :: ApiRequest -> [(ByteString, ByteString)]
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
iTarget :: ApiRequest -> Target
iTopLevelRange :: ApiRequest -> NonnegRange
iRange :: ApiRequest -> HashMap ByteString NonnegRange
iAction :: ApiRequest -> Action
..} =
  case (Action
iAction, Target
iTarget) of
    (ActionRead Bool
_, Target
_) ->
      Mode
SQL.Read
    (Action
ActionInfo, Target
_) ->
      Mode
SQL.Read
    (ActionInspect Bool
_, Target
_) ->
      Mode
SQL.Read
    (ActionInvoke InvokeMethod
InvGet, Target
_) ->
      Mode
SQL.Read
    (ActionInvoke InvokeMethod
InvHead, Target
_) ->
      Mode
SQL.Read
    (ActionInvoke InvokeMethod
InvPost, TargetProc ProcDescription{pdVolatility :: ProcDescription -> ProcVolatility
pdVolatility=ProcVolatility
Stable} Bool
_) ->
      Mode
SQL.Read
    (ActionInvoke InvokeMethod
InvPost, TargetProc ProcDescription{pdVolatility :: ProcDescription -> ProcVolatility
pdVolatility=ProcVolatility
Immutable} Bool
_) ->
      Mode
SQL.Read
    (Action, Target)
_ ->
      Mode
SQL.Write

-- | Result from executing a write query on the database
data WriteQueryResult = WriteQueryResult
  { WriteQueryResult -> Int64
resQueryTotal :: Int64
  , WriteQueryResult -> [ByteString]
resFields     :: [ByteString]
  , WriteQueryResult -> ByteString
resBody       :: ByteString
  , WriteQueryResult -> Maybe Status
resGucStatus  :: Maybe HTTP.Status
  , WriteQueryResult -> [GucHeader]
resGucHeaders :: [GucHeader]
  }

writeQuery :: QualifiedIdentifier -> Bool -> [Text] -> RequestContext -> DbHandler WriteQueryResult
writeQuery :: QualifiedIdentifier
-> Bool -> [Text] -> RequestContext -> DbHandler WriteQueryResult
writeQuery identifier :: QualifiedIdentifier
identifier@QualifiedIdentifier{Text
qiName :: Text
qiSchema :: Text
qiSchema :: QualifiedIdentifier -> Text
qiName :: QualifiedIdentifier -> Text
..} Bool
isInsert [Text]
pkCols context :: RequestContext
context@RequestContext{PgVersion
AppConfig
DbStructure
ApiRequest
ctxPgVersion :: PgVersion
ctxApiRequest :: ApiRequest
ctxDbStructure :: DbStructure
ctxConfig :: AppConfig
ctxPgVersion :: RequestContext -> PgVersion
ctxApiRequest :: RequestContext -> ApiRequest
ctxDbStructure :: RequestContext -> DbStructure
ctxConfig :: RequestContext -> AppConfig
..} = do
  ReadRequest
readReq <- QualifiedIdentifier
-> RequestContext -> Handler Transaction ReadRequest
forall (m :: * -> *).
Monad m =>
QualifiedIdentifier -> RequestContext -> Handler m ReadRequest
readRequest QualifiedIdentifier
identifier RequestContext
context

  MutateRequest
mutateReq <-
    Either Error MutateRequest
-> ExceptT Error Transaction MutateRequest
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Error MutateRequest
 -> ExceptT Error Transaction MutateRequest)
-> Either Error MutateRequest
-> ExceptT Error Transaction MutateRequest
forall a b. (a -> b) -> a -> b
$
      Text
-> Text
-> ApiRequest
-> [Text]
-> ReadRequest
-> Either Error MutateRequest
ReqBuilder.mutateRequest Text
qiSchema Text
qiName ApiRequest
ctxApiRequest
        (DbStructure -> Text -> Text -> [Text]
tablePKCols DbStructure
ctxDbStructure Text
qiSchema Text
qiName)
        ReadRequest
readReq

  (Maybe Int64
_, Int64
queryTotal, [ByteString]
fields, ByteString
body, Either Error [GucHeader]
gucHeaders, Either Error (Maybe Status)
gucStatus) <-
    Transaction
  (Maybe Int64, Int64, [ByteString], ByteString,
   Either Error [GucHeader], Either Error (Maybe Status))
-> ExceptT
     Error
     Transaction
     (Maybe Int64, Int64, [ByteString], ByteString,
      Either Error [GucHeader], Either Error (Maybe Status))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction
   (Maybe Int64, Int64, [ByteString], ByteString,
    Either Error [GucHeader], Either Error (Maybe Status))
 -> ExceptT
      Error
      Transaction
      (Maybe Int64, Int64, [ByteString], ByteString,
       Either Error [GucHeader], Either Error (Maybe Status)))
-> (Statement
      ()
      (Maybe Int64, Int64, [ByteString], ByteString,
       Either Error [GucHeader], Either Error (Maybe Status))
    -> Transaction
         (Maybe Int64, Int64, [ByteString], ByteString,
          Either Error [GucHeader], Either Error (Maybe Status)))
-> Statement
     ()
     (Maybe Int64, Int64, [ByteString], ByteString,
      Either Error [GucHeader], Either Error (Maybe Status))
-> ExceptT
     Error
     Transaction
     (Maybe Int64, Int64, [ByteString], ByteString,
      Either Error [GucHeader], Either Error (Maybe Status))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ()
-> Statement
     ()
     (Maybe Int64, Int64, [ByteString], ByteString,
      Either Error [GucHeader], Either Error (Maybe Status))
-> Transaction
     (Maybe Int64, Int64, [ByteString], ByteString,
      Either Error [GucHeader], Either Error (Maybe Status))
forall a b. a -> Statement a b -> Transaction b
SQL.statement ()
forall a. Monoid a => a
mempty (Statement
   ()
   (Maybe Int64, Int64, [ByteString], ByteString,
    Either Error [GucHeader], Either Error (Maybe Status))
 -> ExceptT
      Error
      Transaction
      (Maybe Int64, Int64, [ByteString], ByteString,
       Either Error [GucHeader], Either Error (Maybe Status)))
-> Statement
     ()
     (Maybe Int64, Int64, [ByteString], ByteString,
      Either Error [GucHeader], Either Error (Maybe Status))
-> ExceptT
     Error
     Transaction
     (Maybe Int64, Int64, [ByteString], ByteString,
      Either Error [GucHeader], Either Error (Maybe Status))
forall a b. (a -> b) -> a -> b
$
      Snippet
-> Snippet
-> Bool
-> Bool
-> Bool
-> PreferRepresentation
-> [Text]
-> PgVersion
-> Bool
-> Statement
     ()
     (Maybe Int64, Int64, [ByteString], ByteString,
      Either Error [GucHeader], Either Error (Maybe Status))
Statements.createWriteStatement
        (ReadRequest -> Snippet
QueryBuilder.readRequestToQuery ReadRequest
readReq)
        (MutateRequest -> Snippet
QueryBuilder.mutateRequestToQuery MutateRequest
mutateReq)
        (ApiRequest -> ContentType
iAcceptContentType ApiRequest
ctxApiRequest ContentType -> ContentType -> Bool
forall a. Eq a => a -> a -> Bool
== ContentType
CTSingularJSON)
        Bool
isInsert
        (ApiRequest -> ContentType
iAcceptContentType ApiRequest
ctxApiRequest ContentType -> ContentType -> Bool
forall a. Eq a => a -> a -> Bool
== ContentType
CTTextCSV)
        (ApiRequest -> PreferRepresentation
iPreferRepresentation ApiRequest
ctxApiRequest)
        [Text]
pkCols
        PgVersion
ctxPgVersion
        (AppConfig -> Bool
configDbPreparedStatements AppConfig
ctxConfig)

  Either Error WriteQueryResult -> DbHandler WriteQueryResult
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Error WriteQueryResult -> DbHandler WriteQueryResult)
-> Either Error WriteQueryResult -> DbHandler WriteQueryResult
forall a b. (a -> b) -> a -> b
$ Int64
-> [ByteString]
-> ByteString
-> Maybe Status
-> [GucHeader]
-> WriteQueryResult
WriteQueryResult Int64
queryTotal [ByteString]
fields ByteString
body (Maybe Status -> [GucHeader] -> WriteQueryResult)
-> Either Error (Maybe Status)
-> Either Error ([GucHeader] -> WriteQueryResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error (Maybe Status)
gucStatus Either Error ([GucHeader] -> WriteQueryResult)
-> Either Error [GucHeader] -> Either Error WriteQueryResult
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either Error [GucHeader]
gucHeaders

-- | Response with headers and status overridden from GUCs.
gucResponse
  :: Maybe HTTP.Status
  -> [GucHeader]
  -> HTTP.Status
  -> [HTTP.Header]
  -> LBS.ByteString
  -> Wai.Response
gucResponse :: Maybe Status
-> [GucHeader] -> Status -> [Header] -> ByteString -> Response
gucResponse Maybe Status
gucStatus [GucHeader]
gucHeaders Status
status [Header]
headers =
  Status -> [Header] -> ByteString -> Response
Wai.responseLBS (Status -> Maybe Status -> Status
forall a. a -> Maybe a -> a
fromMaybe Status
status Maybe Status
gucStatus) ([Header] -> ByteString -> Response)
-> [Header] -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$
    [Header] -> [Header] -> [Header]
addHeadersIfNotIncluded [Header]
headers ((GucHeader -> Header) -> [GucHeader] -> [Header]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map GucHeader -> Header
unwrapGucHeader [GucHeader]
gucHeaders)

-- |
-- Fail a response if a single JSON object was requested and not exactly one
-- was found.
failNotSingular :: ContentType -> Int64 -> Wai.Response -> DbHandler Wai.Response
failNotSingular :: ContentType -> Int64 -> Response -> DbHandler Response
failNotSingular ContentType
contentType Int64
queryTotal Response
response =
  if ContentType
contentType ContentType -> ContentType -> Bool
forall a. Eq a => a -> a -> Bool
== ContentType
CTSingularJSON Bool -> Bool -> Bool
&& Int64
queryTotal Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
1 then
    do
      Transaction () -> ExceptT Error Transaction ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Transaction ()
SQL.condemn
      Error -> DbHandler Response
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> DbHandler Response) -> Error -> DbHandler Response
forall a b. (a -> b) -> a -> b
$ Int64 -> Error
forall a. Integral a => a -> Error
Error.singularityError Int64
queryTotal
  else
    Response -> DbHandler Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
response

shouldCount :: Maybe PreferCount -> Bool
shouldCount :: Maybe PreferCount -> Bool
shouldCount Maybe PreferCount
preferCount =
  Maybe PreferCount
preferCount Maybe PreferCount -> Maybe PreferCount -> Bool
forall a. Eq a => a -> a -> Bool
== PreferCount -> Maybe PreferCount
forall a. a -> Maybe a
Just PreferCount
ExactCount Bool -> Bool -> Bool
|| Maybe PreferCount
preferCount Maybe PreferCount -> Maybe PreferCount -> Bool
forall a. Eq a => a -> a -> Bool
== PreferCount -> Maybe PreferCount
forall a. a -> Maybe a
Just PreferCount
EstimatedCount

returnsScalar :: ApiRequest.Target -> Bool
returnsScalar :: Target -> Bool
returnsScalar (TargetProc ProcDescription
proc Bool
_) = ProcDescription -> Bool
Proc.procReturnsScalar ProcDescription
proc
returnsScalar Target
_                   = Bool
False

readRequest :: Monad m => QualifiedIdentifier -> RequestContext -> Handler m ReadRequest
readRequest :: QualifiedIdentifier -> RequestContext -> Handler m ReadRequest
readRequest QualifiedIdentifier{Text
qiName :: Text
qiSchema :: Text
qiSchema :: QualifiedIdentifier -> Text
qiName :: QualifiedIdentifier -> Text
..} (RequestContext AppConfig{Bool
Int
[(Text, Text)]
[ByteString]
[Text]
JSPath
Maybe Integer
Maybe FilePath
Maybe ByteString
Maybe Text
Maybe StringOrURI
Maybe JWKSet
Maybe QualifiedIdentifier
Text
FileMode
NonEmpty Text
NominalDiffTime
OpenAPIMode
LogLevel
configServerUnixSocketMode :: FileMode
configServerUnixSocket :: Maybe FilePath
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 FilePath
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)]
configServerUnixSocketMode :: AppConfig -> FileMode
configServerUnixSocket :: AppConfig -> Maybe FilePath
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 FilePath
configDbUri :: AppConfig -> Text
configDbTxRollbackAll :: AppConfig -> Bool
configDbTxAllowOverride :: AppConfig -> Bool
configDbConfig :: AppConfig -> Bool
configDbSchemas :: AppConfig -> NonEmpty Text
configDbRootSpec :: AppConfig -> Maybe QualifiedIdentifier
configDbPreparedStatements :: AppConfig -> Bool
configDbPreRequest :: AppConfig -> Maybe QualifiedIdentifier
configDbPoolTimeout :: AppConfig -> NominalDiffTime
configDbPoolSize :: AppConfig -> Int
configDbMaxRows :: AppConfig -> Maybe Integer
configDbExtraSearchPath :: AppConfig -> [Text]
configDbChannelEnabled :: AppConfig -> Bool
configDbChannel :: AppConfig -> Text
configDbAnonRole :: AppConfig -> Text
configAppSettings :: AppConfig -> [(Text, Text)]
..} DbStructure
dbStructure ApiRequest
apiRequest PgVersion
_) =
  Either Error ReadRequest -> Handler m ReadRequest
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Error ReadRequest -> Handler m ReadRequest)
-> Either Error ReadRequest -> Handler m ReadRequest
forall a b. (a -> b) -> a -> b
$
    Text
-> Text
-> Maybe Integer
-> [Relationship]
-> ApiRequest
-> Either Error ReadRequest
ReqBuilder.readRequest Text
qiSchema Text
qiName Maybe Integer
configDbMaxRows
      (DbStructure -> [Relationship]
dbRelationships DbStructure
dbStructure)
      ApiRequest
apiRequest

contentTypeHeaders :: RequestContext -> [HTTP.Header]
contentTypeHeaders :: RequestContext -> [Header]
contentTypeHeaders RequestContext{PgVersion
AppConfig
DbStructure
ApiRequest
ctxPgVersion :: PgVersion
ctxApiRequest :: ApiRequest
ctxDbStructure :: DbStructure
ctxConfig :: AppConfig
ctxPgVersion :: RequestContext -> PgVersion
ctxApiRequest :: RequestContext -> ApiRequest
ctxDbStructure :: RequestContext -> DbStructure
ctxConfig :: RequestContext -> AppConfig
..} =
  ContentType -> Header
ContentType.toHeader (ApiRequest -> ContentType
iAcceptContentType ApiRequest
ctxApiRequest) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: Maybe Header -> [Header]
forall a. Maybe a -> [a]
maybeToList (ApiRequest -> Maybe Header
profileHeader ApiRequest
ctxApiRequest)

-- | If raw(binary) output is requested, check that ContentType is one of the
-- admitted rawContentTypes and that`?select=...` contains only one field other
-- than `*`
binaryField :: Monad m => RequestContext -> ReadRequest -> Handler m (Maybe FieldName)
binaryField :: RequestContext -> ReadRequest -> Handler m (Maybe Text)
binaryField RequestContext{PgVersion
AppConfig
DbStructure
ApiRequest
ctxPgVersion :: PgVersion
ctxApiRequest :: ApiRequest
ctxDbStructure :: DbStructure
ctxConfig :: AppConfig
ctxPgVersion :: RequestContext -> PgVersion
ctxApiRequest :: RequestContext -> ApiRequest
ctxDbStructure :: RequestContext -> DbStructure
ctxConfig :: RequestContext -> AppConfig
..} ReadRequest
readReq
  | Target -> Bool
returnsScalar (ApiRequest -> Target
iTarget ApiRequest
ctxApiRequest) Bool -> Bool -> Bool
&& ApiRequest -> ContentType
iAcceptContentType ApiRequest
ctxApiRequest ContentType -> [ContentType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` AppConfig -> [ContentType]
rawContentTypes AppConfig
ctxConfig =
      Maybe Text -> Handler m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> Handler m (Maybe Text))
-> Maybe Text -> Handler m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"pgrst_scalar"
  | ApiRequest -> ContentType
iAcceptContentType ApiRequest
ctxApiRequest ContentType -> [ContentType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` AppConfig -> [ContentType]
rawContentTypes AppConfig
ctxConfig =
      let
        fldNames :: [Text]
fldNames = ReadRequest -> [Text]
fstFieldNames ReadRequest
readReq
        fieldName :: Maybe Text
fieldName = [Text] -> Maybe Text
forall a. [a] -> Maybe a
headMay [Text]
fldNames
      in
      if [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
fldNames Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Maybe Text
fieldName Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"*" then
        Maybe Text -> Handler m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
fieldName
      else
        Error -> Handler m (Maybe Text)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> Handler m (Maybe Text))
-> Error -> Handler m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ ContentType -> Error
Error.BinaryFieldError (ApiRequest -> ContentType
iAcceptContentType ApiRequest
ctxApiRequest)
  | Bool
otherwise =
      Maybe Text -> Handler m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing

rawContentTypes :: AppConfig -> [ContentType]
rawContentTypes :: AppConfig -> [ContentType]
rawContentTypes AppConfig{Bool
Int
[(Text, Text)]
[ByteString]
[Text]
JSPath
Maybe Integer
Maybe FilePath
Maybe ByteString
Maybe Text
Maybe StringOrURI
Maybe JWKSet
Maybe QualifiedIdentifier
Text
FileMode
NonEmpty Text
NominalDiffTime
OpenAPIMode
LogLevel
configServerUnixSocketMode :: FileMode
configServerUnixSocket :: Maybe FilePath
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 FilePath
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)]
configServerUnixSocketMode :: AppConfig -> FileMode
configServerUnixSocket :: AppConfig -> Maybe FilePath
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 FilePath
configDbUri :: AppConfig -> Text
configDbTxRollbackAll :: AppConfig -> Bool
configDbTxAllowOverride :: AppConfig -> Bool
configDbConfig :: AppConfig -> Bool
configDbSchemas :: AppConfig -> NonEmpty Text
configDbRootSpec :: AppConfig -> Maybe QualifiedIdentifier
configDbPreparedStatements :: AppConfig -> Bool
configDbPreRequest :: AppConfig -> Maybe QualifiedIdentifier
configDbPoolTimeout :: AppConfig -> NominalDiffTime
configDbPoolSize :: AppConfig -> Int
configDbMaxRows :: AppConfig -> Maybe Integer
configDbExtraSearchPath :: AppConfig -> [Text]
configDbChannelEnabled :: AppConfig -> Bool
configDbChannel :: AppConfig -> Text
configDbAnonRole :: AppConfig -> Text
configAppSettings :: AppConfig -> [(Text, Text)]
..} =
  (ByteString -> ContentType
ContentType.decodeContentType (ByteString -> ContentType) -> [ByteString] -> [ContentType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString]
configRawMediaTypes) [ContentType] -> [ContentType] -> [ContentType]
forall a. Eq a => [a] -> [a] -> [a]
`union` [ContentType
CTOctetStream, ContentType
CTTextPlain]

profileHeader :: ApiRequest -> Maybe HTTP.Header
profileHeader :: ApiRequest -> Maybe Header
profileHeader 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 :: 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
iAcceptContentType :: ApiRequest -> ContentType
iSchema :: ApiRequest -> Text
iProfile :: ApiRequest -> Maybe Text
iMethod :: ApiRequest -> ByteString
iPath :: ApiRequest -> ByteString
iCookies :: ApiRequest -> [(ByteString, ByteString)]
iHeaders :: ApiRequest -> [(ByteString, ByteString)]
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
iTarget :: ApiRequest -> Target
iTopLevelRange :: ApiRequest -> NonnegRange
iRange :: ApiRequest -> HashMap ByteString NonnegRange
iAction :: ApiRequest -> Action
..} =
  (,) HeaderName
"Content-Profile" (ByteString -> Header) -> Maybe ByteString -> Maybe Header
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> ByteString
forall a b. StringConv a b => a -> b
toS (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
iProfile)

splitKeyValue :: ByteString -> (ByteString, ByteString)
splitKeyValue :: ByteString -> (ByteString, ByteString)
splitKeyValue ByteString
kv =
  (ByteString
k, ByteString -> ByteString
BS8.tail ByteString
v)
  where
    (ByteString
k, ByteString
v) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS8.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=') ByteString
kv