refactor: App.hs and related changes (#1725)
* Use ExceptT to avoid 'staircasing' case analysis in App.hs * Split large function in App.hs into individual handler functions * Adapt API of Auth.hs, OpenApi.hs etc. to simplify the use of those modules in App.hs * Split optional rollback functionality into Middleware * Unify SimpleError and ApiRequestError into one Error type, so it can be used across modules
This commit is contained in:
Remo Rechkemmer
+527
-410
@@ -9,430 +9,547 @@ Some of its functionality includes:
|
||||
- Producing HTTP Headers according to RFCs.
|
||||
- Content Negotiation
|
||||
-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module PostgREST.App (postgrest) where
|
||||
|
||||
module PostgREST.App (
|
||||
postgrest
|
||||
) where
|
||||
import Control.Monad.Except (liftEither)
|
||||
import Data.Either.Combinators (mapLeft)
|
||||
import Data.IORef (IORef, readIORef)
|
||||
import Data.List (union)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.HashMap.Strict as M
|
||||
import qualified Data.List as L (union)
|
||||
import qualified Data.Set as S
|
||||
import qualified Hasql.Pool as P
|
||||
import qualified Hasql.Transaction as H
|
||||
import qualified Hasql.Transaction as HT
|
||||
import qualified Hasql.Transaction.Sessions as HT
|
||||
import qualified Data.ByteString.Char8 as BS8
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
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 Data.IORef (IORef, readIORef)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Network.HTTP.Types.URI (renderSimpleQuery)
|
||||
import qualified PostgREST.ApiRequest as ApiRequest
|
||||
import qualified PostgREST.Auth as Auth
|
||||
import qualified PostgREST.DbRequestBuilder as ReqBuilder
|
||||
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.QueryBuilder as QueryBuilder
|
||||
import qualified PostgREST.RangeQuery as RangeQuery
|
||||
import qualified PostgREST.Statements as Statements
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Maybe
|
||||
import Network.HTTP.Types.Header
|
||||
import Network.HTTP.Types.Status
|
||||
import Network.Wai
|
||||
import PostgREST.ApiRequest (Action (..), ApiRequest (..),
|
||||
InvokeMethod (..), Target (..))
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.Error (Error)
|
||||
|
||||
import PostgREST.ApiRequest (Action (..), ApiRequest (..),
|
||||
InvokeMethod (..), Target (..),
|
||||
mutuallyAgreeable, userApiRequest)
|
||||
import PostgREST.Auth (attemptJwtClaims, containsRole,
|
||||
jwtClaims)
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.DbRequestBuilder (mutateRequest, readRequest,
|
||||
returningCols)
|
||||
import PostgREST.DbStructure
|
||||
import PostgREST.Error (PgError (..), SimpleError (..),
|
||||
errorResponseFor, singularityError)
|
||||
import PostgREST.Middleware
|
||||
import PostgREST.OpenAPI
|
||||
import PostgREST.QueryBuilder (limitedQuery, mutateRequestToQuery,
|
||||
readRequestToCountQuery,
|
||||
readRequestToQuery,
|
||||
requestToCallProcQuery)
|
||||
import PostgREST.RangeQuery (allRange, contentRangeH,
|
||||
rangeStatusHeader)
|
||||
import PostgREST.Statements (callProcStatement,
|
||||
createExplainStatement,
|
||||
createReadStatement,
|
||||
createWriteStatement)
|
||||
import PostgREST.Types
|
||||
import Protolude hiding (Proxy, intercalate, toS)
|
||||
import Protolude.Conv (toS)
|
||||
|
||||
postgrest :: LogLevel -> IORef AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO UTCTime -> IO () -> Application
|
||||
import Protolude hiding (Handler, toS)
|
||||
import Protolude.Conv (toS)
|
||||
|
||||
|
||||
data RequestContext = RequestContext
|
||||
{ ctxConfig :: AppConfig
|
||||
, ctxDbStructure :: DbStructure
|
||||
, ctxApiRequest :: ApiRequest
|
||||
, ctxContentType :: ContentType
|
||||
}
|
||||
|
||||
type Handler = ExceptT Error
|
||||
|
||||
type DbHandler = Handler SQL.Transaction
|
||||
|
||||
|
||||
-- | PostgREST application
|
||||
postgrest
|
||||
:: LogLevel
|
||||
-> IORef AppConfig
|
||||
-> IORef (Maybe DbStructure)
|
||||
-> SQL.Pool
|
||||
-> IO UTCTime
|
||||
-> IO () -- ^ Lauch connection worker in a separate thread
|
||||
-> Wai.Application
|
||||
postgrest logLev refConf refDbStructure pool getTime connWorker =
|
||||
pgrstMiddleware logLev $ \ req respond -> do
|
||||
time <- getTime
|
||||
body <- strictRequestBody req
|
||||
maybeDbStructure <- readIORef refDbStructure
|
||||
conf <- readIORef refConf
|
||||
Middleware.pgrstMiddleware logLev $
|
||||
\req respond -> do
|
||||
time <- getTime
|
||||
conf <- readIORef refConf
|
||||
maybeDbStructure <- readIORef refDbStructure
|
||||
|
||||
let
|
||||
eitherResponse :: IO (Either Error Wai.Response)
|
||||
eitherResponse =
|
||||
runExceptT $ postgrestResponse conf maybeDbStructure pool time req
|
||||
|
||||
response <- either Error.errorResponseFor identity <$> 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.
|
||||
when (Wai.responseStatus response == HTTP.status503) connWorker
|
||||
|
||||
respond response
|
||||
|
||||
postgrestResponse
|
||||
:: AppConfig
|
||||
-> Maybe DbStructure
|
||||
-> SQL.Pool
|
||||
-> UTCTime
|
||||
-> Wai.Request
|
||||
-> Handler IO Wai.Response
|
||||
postgrestResponse conf@AppConfig{..} maybeDbStructure pool time req = do
|
||||
body <- lift $ Wai.strictRequestBody req
|
||||
|
||||
dbStructure <-
|
||||
case maybeDbStructure of
|
||||
Nothing -> respond . errorResponseFor $ ConnectionLostError
|
||||
Just dbStructure -> do
|
||||
response <- do
|
||||
let apiReq = userApiRequest (configDbSchemas conf) (configDbRootSpec conf) dbStructure req body
|
||||
case apiReq of
|
||||
Left err -> return . errorResponseFor $ err
|
||||
Right apiRequest -> do
|
||||
-- The jwt must be checked before touching the db.
|
||||
attempt <- attemptJwtClaims (configJWKS conf) (configJwtAudience conf) (toS $ iJWT apiRequest) time (configJwtRoleClaimKey conf)
|
||||
case jwtClaims attempt of
|
||||
Left errJwt -> return . errorResponseFor $ errJwt
|
||||
Right claims -> do
|
||||
let
|
||||
authed = containsRole claims
|
||||
shouldCommit = configDbTxAllowOverride conf && iPreferTransaction apiRequest == Just Commit
|
||||
shouldRollback = configDbTxAllowOverride conf && iPreferTransaction apiRequest == Just Rollback
|
||||
preferenceApplied
|
||||
| shouldCommit = addHeadersIfNotIncluded [(hPreferenceApplied, BS.pack (show Commit))]
|
||||
| shouldRollback = addHeadersIfNotIncluded [(hPreferenceApplied, BS.pack (show Rollback))]
|
||||
| otherwise = identity
|
||||
handleReq = do
|
||||
when (shouldRollback || (configDbTxRollbackAll conf && not shouldCommit)) HT.condemn
|
||||
mapResponseHeaders preferenceApplied <$> runPgLocals conf claims (app dbStructure conf) apiRequest
|
||||
dbResp <- P.use pool $ HT.transaction HT.ReadCommitted (txMode apiRequest) handleReq
|
||||
return $ either (errorResponseFor . PgError authed) identity dbResp
|
||||
-- Launch the connWorker when the connection is down. The postgrest function can respond successfully(with a stale schema cache) before the connWorker is done.
|
||||
when (responseStatus response == status503) connWorker
|
||||
respond response
|
||||
Just dbStructure ->
|
||||
return dbStructure
|
||||
Nothing ->
|
||||
throwError Error.ConnectionLostError
|
||||
|
||||
txMode :: ApiRequest -> HT.Mode
|
||||
txMode apiRequest =
|
||||
case (iAction apiRequest, iTarget apiRequest) of
|
||||
(ActionRead _ , _) -> HT.Read
|
||||
(ActionInfo , _) -> HT.Read
|
||||
(ActionInspect _ , _) -> HT.Read
|
||||
(ActionInvoke InvGet , _) -> HT.Read
|
||||
(ActionInvoke InvHead, _) -> HT.Read
|
||||
(ActionInvoke InvPost, TargetProc ProcDescription{pdVolatility=Stable} _) -> HT.Read
|
||||
(ActionInvoke InvPost, TargetProc ProcDescription{pdVolatility=Immutable} _) -> HT.Read
|
||||
_ -> HT.Write
|
||||
apiRequest@ApiRequest{..} <-
|
||||
liftEither . mapLeft Error.ApiRequestError $
|
||||
ApiRequest.userApiRequest configDbSchemas configDbRootSpec dbStructure req body
|
||||
|
||||
app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response
|
||||
app dbStructure conf apiRequest =
|
||||
let rawContentTypes = (decodeContentType <$> configRawMediaTypes conf) `L.union` [ CTOctetStream, CTTextPlain ] in
|
||||
case responseContentTypeOrError (iAccepts apiRequest) rawContentTypes (iAction apiRequest) (iTarget apiRequest) of
|
||||
Left errorResponse -> return errorResponse
|
||||
Right contentType ->
|
||||
case (iAction apiRequest, iTarget apiRequest) of
|
||||
-- The JWT must be checked before touching the db
|
||||
jwtClaims <- Auth.jwtClaims conf (toS iJWT) time
|
||||
|
||||
(ActionRead headersOnly, TargetIdent (QualifiedIdentifier tSchema tName)) ->
|
||||
case readSqlParts tSchema tName of
|
||||
Left errorResponse -> return errorResponse
|
||||
Right (q, cq, bField, _) -> do
|
||||
let cQuery = if estimatedCount
|
||||
then limitedQuery cq ((+ 1) <$> maxRows) -- LIMIT maxRows + 1 so we can determine below that maxRows was surpassed
|
||||
else cq
|
||||
stm = createReadStatement q cQuery (contentType == CTSingularJSON) shouldCount
|
||||
(contentType == CTTextCSV) bField pgVer prepared
|
||||
explStm = createExplainStatement cq prepared
|
||||
row <- H.statement mempty stm
|
||||
let (tableTotal, queryTotal, _ , body, gucHeaders, gucStatus) = row
|
||||
gucs = (,) <$> gucHeaders <*> gucStatus
|
||||
case gucs of
|
||||
Left err -> return $ errorResponseFor err
|
||||
Right (ghdrs, gstatus) -> do
|
||||
total <- if | plannedCount -> H.statement mempty explStm
|
||||
| estimatedCount -> if tableTotal > (fromIntegral <$> maxRows)
|
||||
then do estTotal <- H.statement mempty explStm
|
||||
pure $ if estTotal > tableTotal then estTotal else tableTotal
|
||||
else pure tableTotal
|
||||
| otherwise -> pure tableTotal
|
||||
let (rangeStatus, contentRange) = rangeStatusHeader topLevelRange queryTotal total
|
||||
status = fromMaybe rangeStatus gstatus
|
||||
headers = addHeadersIfNotIncluded (catMaybes [
|
||||
Just $ toHeader contentType, Just contentRange,
|
||||
Just $ contentLocationH tName (iCanonicalQS apiRequest), profileH])
|
||||
(unwrapGucHeader <$> ghdrs)
|
||||
rBody = if headersOnly then mempty else toS body
|
||||
return $
|
||||
if contentType == CTSingularJSON && queryTotal /= 1
|
||||
then errorResponseFor . singularityError $ queryTotal
|
||||
else responseLBS status headers rBody
|
||||
contentType <-
|
||||
case ApiRequest.mutuallyAgreeable (requestContentTypes conf apiRequest) iAccepts of
|
||||
Just ct ->
|
||||
return ct
|
||||
Nothing ->
|
||||
throwError . Error.ContentTypeError $ map toMime iAccepts
|
||||
|
||||
(ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName)) ->
|
||||
case mutateSqlParts tSchema tName of
|
||||
Left errorResponse -> return errorResponse
|
||||
Right (sq, mq) -> do
|
||||
let pkCols = tablePKCols dbStructure tSchema tName
|
||||
stm = createWriteStatement sq mq
|
||||
(contentType == CTSingularJSON) True
|
||||
(contentType == CTTextCSV) (iPreferRepresentation apiRequest) pkCols pgVer prepared
|
||||
row <- H.statement mempty stm
|
||||
let (_, queryTotal, fields, body, gucHeaders, gucStatus) = row
|
||||
gucs = (,) <$> gucHeaders <*> gucStatus
|
||||
case gucs of
|
||||
Left err -> return $ errorResponseFor err
|
||||
Right (ghdrs, gstatus) -> do
|
||||
let
|
||||
(ctHeaders, rBody) = if iPreferRepresentation apiRequest == Full
|
||||
then ([Just $ toHeader contentType, profileH], toS body)
|
||||
else ([], mempty)
|
||||
status = fromMaybe status201 gstatus
|
||||
headers = addHeadersIfNotIncluded (catMaybes ([
|
||||
if null fields
|
||||
then Nothing
|
||||
else Just $ locationH tName fields
|
||||
, Just $ contentRangeH 1 0 $ if shouldCount then Just queryTotal else Nothing
|
||||
, if null pkCols && isNothing (iOnConflict apiRequest)
|
||||
then Nothing
|
||||
else (\x -> ("Preference-Applied", BS.pack (show x))) <$> iPreferResolution apiRequest
|
||||
] ++ ctHeaders)) (unwrapGucHeader <$> ghdrs)
|
||||
if contentType == CTSingularJSON && queryTotal /= 1
|
||||
then do
|
||||
HT.condemn
|
||||
return . errorResponseFor . singularityError $ queryTotal
|
||||
else
|
||||
return $ responseLBS status headers rBody
|
||||
|
||||
(ActionUpdate, TargetIdent (QualifiedIdentifier tSchema tName)) ->
|
||||
case mutateSqlParts tSchema tName of
|
||||
Left errorResponse -> return errorResponse
|
||||
Right (sq, mq) -> do
|
||||
row <- H.statement mempty $
|
||||
createWriteStatement sq mq
|
||||
(contentType == CTSingularJSON) False (contentType == CTTextCSV)
|
||||
(iPreferRepresentation apiRequest) mempty pgVer prepared
|
||||
let (_, queryTotal, _, body, gucHeaders, gucStatus) = row
|
||||
gucs = (,) <$> gucHeaders <*> gucStatus
|
||||
case gucs of
|
||||
Left err -> return $ errorResponseFor err
|
||||
Right (ghdrs, gstatus) -> do
|
||||
let
|
||||
updateIsNoOp = S.null (iColumns apiRequest)
|
||||
defStatus | queryTotal == 0 && not updateIsNoOp = status404
|
||||
| iPreferRepresentation apiRequest == Full = status200
|
||||
| otherwise = status204
|
||||
status = fromMaybe defStatus gstatus
|
||||
contentRangeHeader = contentRangeH 0 (queryTotal - 1) $ if shouldCount then Just queryTotal else Nothing
|
||||
(ctHeaders, rBody) = if iPreferRepresentation apiRequest == Full
|
||||
then ([Just $ toHeader contentType, profileH], toS body)
|
||||
else ([], mempty)
|
||||
headers = addHeadersIfNotIncluded (catMaybes ctHeaders ++ [contentRangeHeader]) (unwrapGucHeader <$> ghdrs)
|
||||
if contentType == CTSingularJSON && queryTotal /= 1
|
||||
then do
|
||||
HT.condemn
|
||||
return . errorResponseFor . singularityError $ queryTotal
|
||||
else
|
||||
return $ responseLBS status headers rBody
|
||||
|
||||
(ActionSingleUpsert, TargetIdent (QualifiedIdentifier tSchema tName)) ->
|
||||
case mutateSqlParts tSchema tName of
|
||||
Left errorResponse -> return errorResponse
|
||||
Right (sq, mq) ->
|
||||
if topLevelRange /= allRange
|
||||
then return . errorResponseFor $ PutRangeNotAllowedError
|
||||
else do
|
||||
row <- H.statement mempty $
|
||||
createWriteStatement sq mq (contentType == CTSingularJSON) False
|
||||
(contentType == CTTextCSV) (iPreferRepresentation apiRequest) mempty pgVer prepared
|
||||
let (_, queryTotal, _, body, gucHeaders, gucStatus) = row
|
||||
gucs = (,) <$> gucHeaders <*> gucStatus
|
||||
case gucs of
|
||||
Left err -> return $ errorResponseFor err
|
||||
Right (ghdrs, gstatus) -> do
|
||||
let headers = addHeadersIfNotIncluded (catMaybes [Just $ toHeader contentType, profileH]) (unwrapGucHeader <$> ghdrs)
|
||||
(defStatus, rBody) = if iPreferRepresentation apiRequest == Full then (status200, toS body) else (status204, mempty)
|
||||
status = fromMaybe defStatus gstatus
|
||||
-- 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
|
||||
if queryTotal /= 1
|
||||
then do
|
||||
HT.condemn
|
||||
return . errorResponseFor $ PutMatchingPkError
|
||||
else
|
||||
return $ responseLBS status headers rBody
|
||||
|
||||
(ActionDelete, TargetIdent (QualifiedIdentifier tSchema tName)) ->
|
||||
case mutateSqlParts tSchema tName of
|
||||
Left errorResponse -> return errorResponse
|
||||
Right (sq, mq) -> do
|
||||
let stm = createWriteStatement sq mq
|
||||
(contentType == CTSingularJSON) False
|
||||
(contentType == CTTextCSV)
|
||||
(iPreferRepresentation apiRequest) mempty pgVer prepared
|
||||
row <- H.statement mempty stm
|
||||
let (_, queryTotal, _, body, gucHeaders, gucStatus) = row
|
||||
gucs = (,) <$> gucHeaders <*> gucStatus
|
||||
case gucs of
|
||||
Left err -> return $ errorResponseFor err
|
||||
Right (ghdrs, gstatus) -> do
|
||||
let
|
||||
defStatus = if iPreferRepresentation apiRequest == Full then status200 else status204
|
||||
status = fromMaybe defStatus gstatus
|
||||
contentRangeHeader = contentRangeH 1 0 $ if shouldCount then Just queryTotal else Nothing
|
||||
(ctHeaders, rBody) = if iPreferRepresentation apiRequest == Full
|
||||
then ([Just $ toHeader contentType, profileH], toS body)
|
||||
else ([], mempty)
|
||||
headers = addHeadersIfNotIncluded (catMaybes ctHeaders ++ [contentRangeHeader]) (unwrapGucHeader <$> ghdrs)
|
||||
if contentType == CTSingularJSON
|
||||
&& queryTotal /= 1
|
||||
then do
|
||||
HT.condemn
|
||||
return . errorResponseFor . singularityError $ queryTotal
|
||||
else
|
||||
return $ responseLBS status headers rBody
|
||||
|
||||
(ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable)) ->
|
||||
let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in
|
||||
case mTable of
|
||||
Nothing -> return notFound
|
||||
Just table ->
|
||||
let allowH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET")
|
||||
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header in
|
||||
return $ responseLBS status200 [allOrigins, allowH] mempty
|
||||
|
||||
(ActionInvoke invMethod, TargetProc proc@ProcDescription{pdSchema, pdName} _) ->
|
||||
let tName = fromMaybe pdName $ procTableName proc in
|
||||
case readSqlParts pdSchema tName of
|
||||
Left errorResponse -> return errorResponse
|
||||
Right (q, cq, bField, returning) -> do
|
||||
let
|
||||
preferParams = iPreferParameters apiRequest
|
||||
pq = requestToCallProcQuery (QualifiedIdentifier pdSchema pdName) (specifiedProcArgs (iColumns apiRequest) proc)
|
||||
(iPayload apiRequest) returnsScalar preferParams returning
|
||||
stm = callProcStatement returnsScalar returnsSingle pq q cq shouldCount (contentType == CTSingularJSON)
|
||||
(contentType == CTTextCSV) (preferParams == Just MultipleObjects) bField pgVer prepared
|
||||
row <- H.statement mempty stm
|
||||
let (tableTotal, queryTotal, body, gucHeaders, gucStatus) = row
|
||||
gucs = (,) <$> gucHeaders <*> gucStatus
|
||||
case gucs of
|
||||
Left err -> return $ errorResponseFor err
|
||||
Right (ghdrs, gstatus) -> do
|
||||
let (rangeStatus, contentRange) = rangeStatusHeader topLevelRange queryTotal tableTotal
|
||||
status = fromMaybe rangeStatus gstatus
|
||||
headers = addHeadersIfNotIncluded
|
||||
(catMaybes [Just $ toHeader contentType, Just contentRange, profileH])
|
||||
(unwrapGucHeader <$> ghdrs)
|
||||
rBody = if invMethod == InvHead then mempty else toS body
|
||||
if contentType == CTSingularJSON && queryTotal /= 1
|
||||
then do
|
||||
HT.condemn
|
||||
return . errorResponseFor . singularityError $ queryTotal
|
||||
else
|
||||
return $ responseLBS status headers rBody
|
||||
|
||||
(ActionInspect headersOnly, TargetDefaultSpec tSchema) -> do
|
||||
let host = configServerHost conf
|
||||
port = toInteger $ configServerPort conf
|
||||
proxy = pickProxy $ toS <$> configOpenApiServerProxyUri conf
|
||||
uri Nothing = ("http", host, port, "/")
|
||||
uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b)
|
||||
uri' = uri proxy
|
||||
toTableInfo :: [Table] -> [(Table, [Column], [Text])]
|
||||
toTableInfo = map (\t -> let (s, tn) = (tableSchema t, tableName t) in (t, tableCols dbStructure s tn, tablePKCols dbStructure s tn))
|
||||
encodeApi ti sd procs = encodeOpenAPI (concat $ M.elems procs) (toTableInfo ti) uri' sd $ dbPrimaryKeys dbStructure
|
||||
|
||||
body <- encodeApi <$>
|
||||
H.statement tSchema (accessibleTables prepared) <*>
|
||||
H.statement tSchema (schemaDescription prepared) <*>
|
||||
H.statement tSchema (accessibleProcs prepared)
|
||||
return $ responseLBS status200 (catMaybes [Just $ toHeader CTOpenAPI, profileH]) (if headersOnly then mempty else toS body)
|
||||
|
||||
_ -> return notFound
|
||||
|
||||
where
|
||||
notFound = responseLBS status404 mempty ""
|
||||
maxRows = configDbMaxRows conf
|
||||
prepared = configDbPreparedStatements conf
|
||||
exactCount = iPreferCount apiRequest == Just ExactCount
|
||||
estimatedCount = iPreferCount apiRequest == Just EstimatedCount
|
||||
plannedCount = iPreferCount apiRequest == Just PlannedCount
|
||||
shouldCount = exactCount || estimatedCount
|
||||
topLevelRange = iTopLevelRange apiRequest
|
||||
returnsScalar =
|
||||
case iTarget apiRequest of
|
||||
TargetProc proc _ -> procReturnsScalar proc
|
||||
_ -> False
|
||||
returnsSingle =
|
||||
case iTarget apiRequest of
|
||||
TargetProc proc _ -> procReturnsSingle proc
|
||||
_ -> False
|
||||
pgVer = pgVersion dbStructure
|
||||
profileH = contentProfileH <$> iProfile apiRequest
|
||||
|
||||
readSqlParts s t =
|
||||
let
|
||||
readReq = readRequest s t maxRows (dbRelations dbStructure) apiRequest
|
||||
returnings :: ReadRequest -> Either Response [FieldName]
|
||||
returnings rr = Right (returningCols rr [])
|
||||
in
|
||||
(,,,) <$>
|
||||
(readRequestToQuery <$> readReq) <*>
|
||||
(readRequestToCountQuery <$> readReq) <*>
|
||||
(binaryField contentType rawContentTypes returnsScalar =<< readReq) <*>
|
||||
(returnings =<< readReq)
|
||||
|
||||
mutateSqlParts s t =
|
||||
let
|
||||
readReq = readRequest s t maxRows (dbRelations dbStructure) apiRequest
|
||||
mutReq = mutateRequest s t apiRequest (tablePKCols dbStructure s t) =<< readReq
|
||||
in
|
||||
(,) <$>
|
||||
(readRequestToQuery <$> readReq) <*>
|
||||
(mutateRequestToQuery <$> mutReq)
|
||||
|
||||
responseContentTypeOrError :: [ContentType] -> [ContentType] -> Action -> Target -> Either Response ContentType
|
||||
responseContentTypeOrError accepts rawContentTypes action target = serves contentTypesForRequest accepts
|
||||
where
|
||||
contentTypesForRequest = case action of
|
||||
ActionRead _ -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]
|
||||
++ rawContentTypes
|
||||
ActionCreate -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]
|
||||
ActionUpdate -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]
|
||||
ActionDelete -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]
|
||||
ActionInvoke _ -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]
|
||||
++ rawContentTypes
|
||||
++ [CTOpenAPI | tpIsRootSpec target]
|
||||
ActionInspect _ -> [CTOpenAPI, CTApplicationJSON]
|
||||
ActionInfo -> [CTTextCSV]
|
||||
ActionSingleUpsert -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]
|
||||
serves sProduces cAccepts =
|
||||
case mutuallyAgreeable sProduces cAccepts of
|
||||
Nothing -> Left . errorResponseFor . ContentTypeError . map toMime $ cAccepts
|
||||
Just ct -> Right ct
|
||||
|
||||
{-
|
||||
| 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 :: ContentType -> [ContentType] -> Bool -> ReadRequest -> Either Response (Maybe FieldName)
|
||||
binaryField ct rawContentTypes isScalarProc readReq
|
||||
| isScalarProc =
|
||||
if ct `elem` rawContentTypes
|
||||
then Right $ Just "pgrst_scalar"
|
||||
else Right Nothing
|
||||
| ct `elem` rawContentTypes =
|
||||
let fieldName = headMay fldNames in
|
||||
if length fldNames == 1 && fieldName /= Just "*"
|
||||
then Right fieldName
|
||||
else Left . errorResponseFor $ BinaryFieldError ct
|
||||
| otherwise = Right Nothing
|
||||
where
|
||||
fldNames = fstFieldNames readReq
|
||||
|
||||
locationH :: TableName -> [BS.ByteString] -> Header
|
||||
locationH tName fields =
|
||||
let
|
||||
locationFields = renderSimpleQuery True $ splitKeyValue <$> fields
|
||||
in
|
||||
(hLocation, "/" <> toS tName <> locationFields)
|
||||
handleReq apiReq =
|
||||
handleRequest $ RequestContext conf dbStructure apiReq contentType
|
||||
|
||||
runDbHandler pool (txMode apiRequest) jwtClaims .
|
||||
Middleware.optionalRollback conf apiRequest $
|
||||
Middleware.runPgLocals conf jwtClaims handleReq apiRequest
|
||||
|
||||
runDbHandler :: SQL.Pool -> SQL.Mode -> Auth.JWTClaims -> DbHandler a -> Handler IO a
|
||||
runDbHandler pool mode jwtClaims handler = do
|
||||
dbResp <-
|
||||
lift . SQL.use pool . SQL.transaction SQL.ReadCommitted mode $ runExceptT handler
|
||||
|
||||
resp <-
|
||||
liftEither . mapLeft Error.PgErr $
|
||||
mapLeft (Error.PgError $ Auth.containsRole jwtClaims) dbResp
|
||||
|
||||
liftEither resp
|
||||
|
||||
handleRequest :: RequestContext -> DbHandler Wai.Response
|
||||
handleRequest context@(RequestContext _ _ ApiRequest{..} _) =
|
||||
case (iAction, iTarget) of
|
||||
(ActionRead headersOnly, TargetIdent identifier) ->
|
||||
handleRead headersOnly identifier context
|
||||
(ActionCreate, TargetIdent identifier) ->
|
||||
handleCreate identifier context
|
||||
(ActionUpdate, TargetIdent identifier) ->
|
||||
handleUpdate identifier context
|
||||
(ActionSingleUpsert, TargetIdent identifier) ->
|
||||
handleSingleUpsert identifier context
|
||||
(ActionDelete, TargetIdent identifier) ->
|
||||
handleDelete identifier context
|
||||
(ActionInfo, TargetIdent identifier) ->
|
||||
handleInfo identifier context
|
||||
(ActionInvoke invMethod, TargetProc proc _) ->
|
||||
handleInvoke invMethod proc context
|
||||
(ActionInspect headersOnly, TargetDefaultSpec tSchema) ->
|
||||
handleOpenApi headersOnly tSchema context
|
||||
_ ->
|
||||
throwError Error.NotFound
|
||||
|
||||
handleRead :: Bool -> QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
|
||||
handleRead headersOnly identifier context@RequestContext{..} = do
|
||||
req <- readRequest identifier context
|
||||
bField <- binaryField context req
|
||||
|
||||
let
|
||||
ApiRequest{..} = ctxApiRequest
|
||||
AppConfig{..} = ctxConfig
|
||||
countQuery = QueryBuilder.readRequestToCountQuery req
|
||||
|
||||
(tableTotal, queryTotal, _ , body, gucHeaders, gucStatus) <-
|
||||
lift . SQL.statement mempty $
|
||||
Statements.createReadStatement
|
||||
(QueryBuilder.readRequestToQuery req)
|
||||
(if iPreferCount == Just EstimatedCount then
|
||||
-- LIMIT maxRows + 1 so we can determine below that maxRows was surpassed
|
||||
QueryBuilder.limitedQuery countQuery ((+ 1) <$> configDbMaxRows)
|
||||
else
|
||||
countQuery
|
||||
)
|
||||
(ctxContentType == CTSingularJSON)
|
||||
(shouldCount iPreferCount)
|
||||
(ctxContentType == CTTextCSV)
|
||||
bField
|
||||
(pgVersion ctxDbStructure)
|
||||
configDbPreparedStatements
|
||||
|
||||
total <- readTotal ctxConfig ctxApiRequest tableTotal countQuery
|
||||
response <- liftEither $ gucResponse <$> gucStatus <*> gucHeaders
|
||||
|
||||
let
|
||||
(status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange queryTotal total
|
||||
headers =
|
||||
[ contentRange
|
||||
, ( "Content-Location"
|
||||
, "/"
|
||||
<> toS (qiName identifier)
|
||||
<> if BS8.null iCanonicalQS then mempty else "?" <> toS iCanonicalQS
|
||||
)
|
||||
]
|
||||
++ contentTypeHeaders context
|
||||
|
||||
failNotSingular ctxContentType queryTotal . response status headers $
|
||||
if headersOnly then mempty else toS body
|
||||
|
||||
readTotal :: AppConfig -> ApiRequest -> Maybe Int64 -> SQL.Snippet -> DbHandler (Maybe Int64)
|
||||
readTotal AppConfig{..} ApiRequest{..} tableTotal countQuery =
|
||||
case iPreferCount of
|
||||
Just PlannedCount ->
|
||||
explain
|
||||
Just EstimatedCount ->
|
||||
if tableTotal > (fromIntegral <$> configDbMaxRows) then
|
||||
max tableTotal <$> explain
|
||||
else
|
||||
return tableTotal
|
||||
_ ->
|
||||
return tableTotal
|
||||
where
|
||||
splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString)
|
||||
splitKeyValue kv =
|
||||
let (k, v) = BS.break (== '=') kv
|
||||
in (k, BS.tail v)
|
||||
explain =
|
||||
lift . SQL.statement mempty . Statements.createExplainStatement countQuery $
|
||||
configDbPreparedStatements
|
||||
|
||||
contentLocationH :: TableName -> ByteString -> Header
|
||||
contentLocationH tName qString =
|
||||
("Content-Location", "/" <> toS tName <> if BS.null qString then mempty else "?" <> toS qString)
|
||||
handleCreate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
|
||||
handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do
|
||||
let
|
||||
ApiRequest{..} = ctxApiRequest
|
||||
pkCols = tablePKCols ctxDbStructure qiSchema qiName
|
||||
|
||||
contentProfileH :: Schema -> Header
|
||||
contentProfileH schema =
|
||||
("Content-Profile", toS schema)
|
||||
WriteQueryResult{..} <- writeQuery identifier True pkCols context
|
||||
|
||||
let
|
||||
response = gucResponse resGucStatus resGucHeaders
|
||||
headers =
|
||||
catMaybes
|
||||
[ if null resFields then
|
||||
Nothing
|
||||
else
|
||||
Just
|
||||
( HTTP.hLocation
|
||||
, "/"
|
||||
<> toS qiName
|
||||
<> HTTP.renderSimpleQuery True (splitKeyValue <$> resFields)
|
||||
)
|
||||
, Just . RangeQuery.contentRangeH 1 0 $
|
||||
if shouldCount iPreferCount then Just resQueryTotal else Nothing
|
||||
, if null pkCols && isNothing iOnConflict then
|
||||
Nothing
|
||||
else
|
||||
(\x -> ("Preference-Applied", BS8.pack $ show x)) <$> iPreferResolution
|
||||
]
|
||||
|
||||
failNotSingular ctxContentType resQueryTotal $
|
||||
if iPreferRepresentation == Full then
|
||||
response HTTP.status201 (headers ++ contentTypeHeaders context) (toS resBody)
|
||||
else
|
||||
response HTTP.status201 headers mempty
|
||||
|
||||
handleUpdate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
|
||||
handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} contentType) = do
|
||||
WriteQueryResult{..} <- writeQuery identifier False mempty context
|
||||
|
||||
let
|
||||
response = gucResponse resGucStatus resGucHeaders
|
||||
fullRepr = iPreferRepresentation == Full
|
||||
updateIsNoOp = Set.null iColumns
|
||||
status
|
||||
| resQueryTotal == 0 && not updateIsNoOp = HTTP.status404
|
||||
| fullRepr = HTTP.status200
|
||||
| otherwise = HTTP.status204
|
||||
contentRangeHeader =
|
||||
RangeQuery.contentRangeH 0 (resQueryTotal - 1) $
|
||||
if shouldCount iPreferCount then Just resQueryTotal else Nothing
|
||||
|
||||
failNotSingular contentType resQueryTotal $
|
||||
if fullRepr then
|
||||
response status (contentTypeHeaders context ++ [contentRangeHeader]) (toS resBody)
|
||||
else
|
||||
response status [contentRangeHeader] mempty
|
||||
|
||||
handleSingleUpsert :: QualifiedIdentifier -> RequestContext-> DbHandler Wai.Response
|
||||
handleSingleUpsert identifier context@(RequestContext _ _ ApiRequest{..} _) = do
|
||||
when (iTopLevelRange /= RangeQuery.allRange) $
|
||||
throwError Error.PutRangeNotAllowedError
|
||||
|
||||
WriteQueryResult{..} <- writeQuery identifier False mempty context
|
||||
|
||||
let response = gucResponse resGucStatus 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
|
||||
when (resQueryTotal /= 1) $ do
|
||||
lift SQL.condemn
|
||||
throwError Error.PutMatchingPkError
|
||||
|
||||
return $
|
||||
if iPreferRepresentation == Full then
|
||||
response HTTP.status200 (contentTypeHeaders context) (toS resBody)
|
||||
else
|
||||
response HTTP.status204 (contentTypeHeaders context) mempty
|
||||
|
||||
handleDelete :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
|
||||
handleDelete identifier context@(RequestContext _ _ ApiRequest{..} contentType) = do
|
||||
WriteQueryResult{..} <- writeQuery identifier False mempty context
|
||||
|
||||
let
|
||||
response = gucResponse resGucStatus resGucHeaders
|
||||
contentRangeHeader =
|
||||
RangeQuery.contentRangeH 1 0 $
|
||||
if shouldCount iPreferCount then Just resQueryTotal else Nothing
|
||||
|
||||
failNotSingular contentType resQueryTotal $
|
||||
if iPreferRepresentation == Full then
|
||||
response HTTP.status200
|
||||
(contentTypeHeaders context ++ [contentRangeHeader])
|
||||
(toS resBody)
|
||||
else
|
||||
response HTTP.status204 [contentRangeHeader] mempty
|
||||
|
||||
handleInfo :: Monad m => QualifiedIdentifier -> RequestContext -> Handler m Wai.Response
|
||||
handleInfo identifier RequestContext{..} =
|
||||
case find tableMatches $ dbTables ctxDbStructure of
|
||||
Just table ->
|
||||
return $ Wai.responseLBS HTTP.status200 [allOrigins, allowH table] mempty
|
||||
Nothing ->
|
||||
throwError Error.NotFound
|
||||
where
|
||||
allOrigins = ("Access-Control-Allow-Origin", "*")
|
||||
allowH table =
|
||||
( HTTP.hAllow
|
||||
, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET"
|
||||
)
|
||||
tableMatches table =
|
||||
tableName table == qiName identifier
|
||||
&& tableSchema table == qiSchema identifier
|
||||
|
||||
handleInvoke :: InvokeMethod -> ProcDescription -> RequestContext -> DbHandler Wai.Response
|
||||
handleInvoke invMethod proc context@RequestContext{..} = do
|
||||
let
|
||||
ApiRequest{..} = ctxApiRequest
|
||||
|
||||
identifier =
|
||||
QualifiedIdentifier
|
||||
(pdSchema proc)
|
||||
(fromMaybe (pdName proc) $ procTableName proc)
|
||||
|
||||
returnsSingle (ApiRequest.TargetProc target _) = procReturnsSingle target
|
||||
returnsSingle _ = False
|
||||
|
||||
req <- readRequest identifier context
|
||||
bField <- binaryField context req
|
||||
|
||||
(tableTotal, queryTotal, body, gucHeaders, gucStatus) <-
|
||||
lift . SQL.statement mempty $
|
||||
Statements.callProcStatement
|
||||
(returnsScalar iTarget)
|
||||
(returnsSingle iTarget)
|
||||
(QueryBuilder.requestToCallProcQuery
|
||||
(QualifiedIdentifier (pdSchema proc) (pdName proc))
|
||||
(specifiedProcArgs iColumns proc)
|
||||
iPayload
|
||||
(returnsScalar iTarget)
|
||||
iPreferParameters
|
||||
(ReqBuilder.returningCols req [])
|
||||
)
|
||||
(QueryBuilder.readRequestToQuery req)
|
||||
(QueryBuilder.readRequestToCountQuery req)
|
||||
(shouldCount iPreferCount)
|
||||
(ctxContentType == CTSingularJSON)
|
||||
(ctxContentType == CTTextCSV)
|
||||
(iPreferParameters == Just MultipleObjects)
|
||||
bField
|
||||
(pgVersion ctxDbStructure)
|
||||
(configDbPreparedStatements ctxConfig)
|
||||
|
||||
response <- liftEither $ gucResponse <$> gucStatus <*> gucHeaders
|
||||
|
||||
let
|
||||
(status, contentRange) =
|
||||
RangeQuery.rangeStatusHeader iTopLevelRange queryTotal tableTotal
|
||||
|
||||
failNotSingular ctxContentType queryTotal $
|
||||
response status
|
||||
(contentTypeHeaders context ++ [contentRange])
|
||||
(if invMethod == InvHead then mempty else toS body)
|
||||
|
||||
handleOpenApi :: Bool -> Schema -> RequestContext -> DbHandler Wai.Response
|
||||
handleOpenApi headersOnly tSchema (RequestContext conf@AppConfig{..} dbStructure apiRequest _) = do
|
||||
body <-
|
||||
lift $
|
||||
OpenAPI.encode conf dbStructure
|
||||
<$> SQL.statement tSchema (DbStructure.accessibleTables configDbPreparedStatements)
|
||||
<*> SQL.statement tSchema (DbStructure.schemaDescription configDbPreparedStatements)
|
||||
<*> SQL.statement tSchema (DbStructure.accessibleProcs configDbPreparedStatements)
|
||||
|
||||
return $
|
||||
Wai.responseLBS HTTP.status200
|
||||
(toHeader CTOpenAPI : maybeToList (profileHeader apiRequest))
|
||||
(if headersOnly then mempty else toS body)
|
||||
|
||||
txMode :: ApiRequest -> SQL.Mode
|
||||
txMode ApiRequest{..} =
|
||||
case (iAction, iTarget) of
|
||||
(ActionRead _, _) ->
|
||||
SQL.Read
|
||||
(ActionInfo, _) ->
|
||||
SQL.Read
|
||||
(ActionInspect _, _) ->
|
||||
SQL.Read
|
||||
(ActionInvoke InvGet, _) ->
|
||||
SQL.Read
|
||||
(ActionInvoke InvHead, _) ->
|
||||
SQL.Read
|
||||
(ActionInvoke InvPost, TargetProc ProcDescription{pdVolatility=Stable} _) ->
|
||||
SQL.Read
|
||||
(ActionInvoke InvPost, TargetProc ProcDescription{pdVolatility=Immutable} _) ->
|
||||
SQL.Read
|
||||
_ ->
|
||||
SQL.Write
|
||||
|
||||
-- | Result from executing a write query on the database
|
||||
data WriteQueryResult = WriteQueryResult
|
||||
{ resQueryTotal :: Int64
|
||||
, resFields :: [ByteString]
|
||||
, resBody :: ByteString
|
||||
, resGucStatus :: Maybe HTTP.Status
|
||||
, resGucHeaders :: [GucHeader]
|
||||
}
|
||||
|
||||
writeQuery :: QualifiedIdentifier -> Bool -> [Text] -> RequestContext -> DbHandler WriteQueryResult
|
||||
writeQuery identifier@QualifiedIdentifier{..} isInsert pkCols context@RequestContext{..} = do
|
||||
readReq <- readRequest identifier context
|
||||
|
||||
mutateReq <-
|
||||
liftEither $
|
||||
ReqBuilder.mutateRequest qiSchema qiName ctxApiRequest
|
||||
(tablePKCols ctxDbStructure qiSchema qiName)
|
||||
readReq
|
||||
|
||||
(_, queryTotal, fields, body, gucHeaders, gucStatus) <-
|
||||
lift . SQL.statement mempty $
|
||||
Statements.createWriteStatement
|
||||
(QueryBuilder.readRequestToQuery readReq)
|
||||
(QueryBuilder.mutateRequestToQuery mutateReq)
|
||||
(ctxContentType == CTSingularJSON)
|
||||
isInsert
|
||||
(ctxContentType == CTTextCSV)
|
||||
(iPreferRepresentation ctxApiRequest)
|
||||
pkCols
|
||||
(pgVersion ctxDbStructure)
|
||||
(configDbPreparedStatements ctxConfig)
|
||||
|
||||
liftEither $ WriteQueryResult queryTotal fields body <$> gucStatus <*> gucHeaders
|
||||
|
||||
-- | Response with headers and status overridden from GUCs.
|
||||
gucResponse
|
||||
:: Maybe HTTP.Status
|
||||
-> [GucHeader]
|
||||
-> HTTP.Status
|
||||
-> [HTTP.Header]
|
||||
-> LBS.ByteString
|
||||
-> Wai.Response
|
||||
gucResponse gucStatus gucHeaders status headers =
|
||||
Wai.responseLBS (fromMaybe status gucStatus) $
|
||||
addHeadersIfNotIncluded headers (map unwrapGucHeader 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 queryTotal response =
|
||||
if contentType == CTSingularJSON && queryTotal /= 1 then
|
||||
do
|
||||
lift SQL.condemn
|
||||
throwError $ Error.singularityError queryTotal
|
||||
else
|
||||
return response
|
||||
|
||||
shouldCount :: Maybe PreferCount -> Bool
|
||||
shouldCount preferCount =
|
||||
preferCount == Just ExactCount || preferCount == Just EstimatedCount
|
||||
|
||||
returnsScalar :: ApiRequest.Target -> Bool
|
||||
returnsScalar (TargetProc proc _) = procReturnsScalar proc
|
||||
returnsScalar _ = False
|
||||
|
||||
readRequest :: Monad m => QualifiedIdentifier -> RequestContext -> Handler m ReadRequest
|
||||
readRequest QualifiedIdentifier{..} (RequestContext AppConfig{..} dbStructure apiRequest _) =
|
||||
liftEither $
|
||||
ReqBuilder.readRequest qiSchema qiName configDbMaxRows
|
||||
(dbRelations dbStructure)
|
||||
apiRequest
|
||||
|
||||
contentTypeHeaders :: RequestContext -> [HTTP.Header]
|
||||
contentTypeHeaders RequestContext{..} =
|
||||
toHeader ctxContentType : maybeToList (profileHeader ctxApiRequest)
|
||||
|
||||
requestContentTypes :: AppConfig -> ApiRequest -> [ContentType]
|
||||
requestContentTypes conf ApiRequest{..} =
|
||||
case iAction of
|
||||
ActionRead _ -> defaultContentTypes ++ rawContentTypes conf
|
||||
ActionInvoke _ -> invokeContentTypes
|
||||
ActionInspect _ -> [CTOpenAPI, CTApplicationJSON]
|
||||
ActionInfo -> [CTTextCSV]
|
||||
_ -> defaultContentTypes
|
||||
where
|
||||
invokeContentTypes =
|
||||
defaultContentTypes
|
||||
++ rawContentTypes conf
|
||||
++ [CTOpenAPI | ApiRequest.tpIsRootSpec iTarget]
|
||||
defaultContentTypes =
|
||||
[CTApplicationJSON, CTSingularJSON, CTTextCSV]
|
||||
|
||||
-- |
|
||||
-- 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{..} readReq
|
||||
| returnsScalar (iTarget ctxApiRequest) && ctxContentType `elem` rawContentTypes ctxConfig =
|
||||
return $ Just "pgrst_scalar"
|
||||
| ctxContentType `elem` rawContentTypes ctxConfig =
|
||||
let
|
||||
fldNames = fstFieldNames readReq
|
||||
fieldName = headMay fldNames
|
||||
in
|
||||
if length fldNames == 1 && fieldName /= Just "*" then
|
||||
return fieldName
|
||||
else
|
||||
throwError $ Error.BinaryFieldError ctxContentType
|
||||
| otherwise =
|
||||
return Nothing
|
||||
|
||||
rawContentTypes :: AppConfig -> [ContentType]
|
||||
rawContentTypes AppConfig{..} =
|
||||
(decodeContentType <$> configRawMediaTypes) `union` [CTOctetStream, CTTextPlain]
|
||||
|
||||
profileHeader :: ApiRequest -> Maybe HTTP.Header
|
||||
profileHeader ApiRequest{..} =
|
||||
(,) "Content-Profile" <$> (toS <$> iProfile)
|
||||
|
||||
splitKeyValue :: ByteString -> (ByteString, ByteString)
|
||||
splitKeyValue kv =
|
||||
(k, BS8.tail v)
|
||||
where
|
||||
(k, v) = BS8.break (== '=') kv
|
||||
|
||||
Reference in New Issue
Block a user