439 lines
23 KiB
Haskell
439 lines
23 KiB
Haskell
{-|
|
|
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 FlexibleContexts #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module PostgREST.App (
|
|
postgrest
|
|
) where
|
|
|
|
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 Data.IORef (IORef, readIORef)
|
|
import Data.Time.Clock (UTCTime)
|
|
import Network.HTTP.Types.URI (renderSimpleQuery)
|
|
|
|
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 (..),
|
|
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
|
|
postgrest logLev refConf refDbStructure pool getTime connWorker =
|
|
pgrstMiddleware logLev $ \ req respond -> do
|
|
time <- getTime
|
|
body <- strictRequestBody req
|
|
maybeDbStructure <- readIORef refDbStructure
|
|
conf <- readIORef refConf
|
|
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 (rightToMaybe $ 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
|
|
|
|
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
|
|
|
|
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
|
|
|
|
(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
|
|
|
|
(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 <*>
|
|
H.statement tSchema schemaDescription <*>
|
|
H.statement tSchema accessibleProcs
|
|
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)
|
|
where
|
|
splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString)
|
|
splitKeyValue kv =
|
|
let (k, v) = BS.break (== '=') kv
|
|
in (k, BS.tail v)
|
|
|
|
contentLocationH :: TableName -> ByteString -> Header
|
|
contentLocationH tName qString =
|
|
("Content-Location", "/" <> toS tName <> if BS.null qString then mempty else "?" <> toS qString)
|
|
|
|
contentProfileH :: Schema -> Header
|
|
contentProfileH schema =
|
|
("Content-Profile", toS schema)
|