chore: move executable code to src/
src/ now contains all source code - in subdirectories, according to the .cabal component they belong to. This will allow us to put vendored libraries in the same place - and later split our own code into multiple components/libraries as well.
This commit is contained in:
Wolfgang Walther
@@ -0,0 +1,68 @@
|
||||
module PostgREST.Admin
|
||||
( runAdmin
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Network.HTTP.Types.Status as HTTP
|
||||
import qualified Network.Wai as Wai
|
||||
import qualified Network.Wai.Handler.Warp as Warp
|
||||
|
||||
import Control.Monad.Extra (whenJust)
|
||||
|
||||
import PostgREST.AppState (AppState, getConfig)
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.MediaType (MediaType (..), toContentType)
|
||||
import PostgREST.Metrics (metricsToText)
|
||||
import PostgREST.Network (resolveSocketToAddress)
|
||||
import PostgREST.Observation (Observation (..))
|
||||
|
||||
import qualified PostgREST.AppState as AppState
|
||||
|
||||
import qualified Network.Socket as NS
|
||||
import Protolude
|
||||
|
||||
runAdmin :: AppState -> Maybe NS.Socket -> IO Bool -> Warp.Settings -> IO ()
|
||||
runAdmin appState maybeAdminSocket checkMainAppLive settings = do
|
||||
conf <- getConfig appState
|
||||
whenJust maybeAdminSocket $ \adminSocket -> do
|
||||
address <- resolveSocketToAddress adminSocket
|
||||
void . forkIO $ handle (onError adminSocket) $
|
||||
Warp.runSettingsSocket (adminServerSettings conf address) adminSocket adminApp
|
||||
where
|
||||
adminApp = admin appState checkMainAppLive
|
||||
observer = AppState.getObserver appState
|
||||
adminServerSettings config addr=
|
||||
settings
|
||||
& Warp.setBeforeMainLoop (observer $ AdminStartObs addr)
|
||||
& maybe identity Warp.setPort (configAdminServerPort config)
|
||||
|
||||
onError adminSock ex = do
|
||||
observer $ AdminServerCrashedObs ex
|
||||
NS.close adminSock -- we close the socket so request doesn't hang
|
||||
|
||||
-- | PostgREST admin application
|
||||
admin :: AppState.AppState -> IO Bool -> Wai.Application
|
||||
admin appState checkMainAppLive req respond = do
|
||||
isMainAppLive <- checkMainAppLive
|
||||
isLoaded <- AppState.isLoaded appState
|
||||
isPending <- AppState.isPending appState
|
||||
|
||||
case Wai.pathInfo req of
|
||||
["live"] ->
|
||||
respond $ Wai.responseLBS (if isMainAppLive then HTTP.status200 else HTTP.status500) [] mempty
|
||||
["ready"] ->
|
||||
let
|
||||
status | isPending = HTTP.status503
|
||||
| not isMainAppLive = HTTP.status500
|
||||
| isLoaded = HTTP.status200
|
||||
| otherwise = HTTP.status500
|
||||
in
|
||||
respond $ Wai.responseLBS status [] mempty
|
||||
["schema_cache"] -> do
|
||||
sCache <- AppState.getSchemaCache appState
|
||||
respond $ Wai.responseLBS HTTP.status200 [] (maybe mempty JSON.encode sCache)
|
||||
["metrics"] -> do
|
||||
mets <- metricsToText
|
||||
respond $ Wai.responseLBS HTTP.status200 [toContentType MTTextPlain] mets -- Content-Type is required for prometheus compliance
|
||||
_ ->
|
||||
respond $ Wai.responseLBS HTTP.status404 [] mempty
|
||||
@@ -0,0 +1,197 @@
|
||||
{-|
|
||||
Module : PostgREST.Request.ApiRequest
|
||||
Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
|
||||
-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
module PostgREST.ApiRequest
|
||||
( ApiRequest(..)
|
||||
, userApiRequest
|
||||
, userPreferences
|
||||
, userBearerAuth
|
||||
) where
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.List.NonEmpty as NonEmptyList
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Text.Encoding as T
|
||||
|
||||
import Data.List (lookup)
|
||||
import Data.Ranged.Ranges (emptyRange, rangeIntersection,
|
||||
rangeIsEmpty)
|
||||
import Network.HTTP.Types.Header (RequestHeaders,
|
||||
hAuthorization, hCookie)
|
||||
import Network.Wai (Request (..))
|
||||
import Network.Wai.Middleware.HttpAuth (extractBearerAuth)
|
||||
import Network.Wai.Parse (parseHttpAccept)
|
||||
import Web.Cookie (parseCookies)
|
||||
|
||||
import PostgREST.ApiRequest.Payload (getPayload)
|
||||
import PostgREST.ApiRequest.QueryParams (QueryParams (..))
|
||||
import PostgREST.ApiRequest.Types (Action (..), DbAction (..),
|
||||
InvokeMethod (..),
|
||||
Mutation (..), Payload (..),
|
||||
RequestBody, Resource (..))
|
||||
import PostgREST.Config (AppConfig (..),
|
||||
OpenAPIMode (..))
|
||||
import PostgREST.Config.Database (TimezoneNames)
|
||||
import PostgREST.Error (ApiRequestError (..),
|
||||
RangeError (..))
|
||||
import PostgREST.MediaType (MediaType (..))
|
||||
import PostgREST.RangeQuery (NonnegRange, allRange,
|
||||
convertToLimitZeroRange,
|
||||
hasLimitZero,
|
||||
rangeRequested)
|
||||
import PostgREST.SchemaCache.Identifiers (FieldName,
|
||||
QualifiedIdentifier (..),
|
||||
Schema)
|
||||
|
||||
import qualified PostgREST.ApiRequest.Preferences as Preferences
|
||||
import qualified PostgREST.ApiRequest.QueryParams as QueryParams
|
||||
import qualified PostgREST.MediaType as MediaType
|
||||
|
||||
import Protolude
|
||||
|
||||
{-|
|
||||
Describes what the user wants to do. This data type is a
|
||||
translation of the raw elements of an HTTP request into domain
|
||||
specific language. There is no guarantee that the intent is
|
||||
sensible, it is up to a later stage of processing to determine
|
||||
if it is an action we are able to perform.
|
||||
-}
|
||||
data ApiRequest = ApiRequest {
|
||||
iAction :: Action -- ^ Action on the resource
|
||||
, iRange :: HM.HashMap Text NonnegRange -- ^ Requested range of rows within response
|
||||
, iTopLevelRange :: NonnegRange -- ^ Requested range of rows from the top level
|
||||
, iPayload :: Maybe Payload -- ^ Data sent by client and used for mutation actions
|
||||
, iPreferences :: Preferences.Preferences -- ^ Prefer header values
|
||||
, iQueryParams :: QueryParams.QueryParams
|
||||
, iColumns :: S.Set FieldName -- ^ parsed columns from &columns parameter and payload
|
||||
, iHeaders :: [(ByteString, ByteString)] -- ^ HTTP request headers
|
||||
, iCookies :: [(ByteString, ByteString)] -- ^ Request Cookies
|
||||
, iPath :: ByteString -- ^ Raw request path
|
||||
, iMethod :: ByteString -- ^ Raw request method
|
||||
, iSchema :: Schema -- ^ The request schema. Can vary depending on profile headers.
|
||||
, iNegotiatedByProfile :: Bool -- ^ If schema was was chosen according to the profile spec https://www.w3.org/TR/dx-prof-conneg/
|
||||
, iAcceptMediaType :: [MediaType] -- ^ The resolved media types in the Accept, considering quality(q) factors
|
||||
, iContentMediaType :: MediaType -- ^ The media type in the Content-Type header
|
||||
}
|
||||
|
||||
-- | Examines HTTP request and translates it into user intent.
|
||||
userApiRequest :: AppConfig -> Preferences.Preferences -> Request -> RequestBody -> Either ApiRequestError ApiRequest
|
||||
userApiRequest conf prefs req reqBody = do
|
||||
resource <- getResource conf $ pathInfo req
|
||||
(schema, negotiatedByProfile) <- getSchema conf hdrs method
|
||||
act <- getAction resource schema method
|
||||
qPrms <- first QueryParamError $ QueryParams.parse (actIsInvokeSafe act) $ rawQueryString req
|
||||
(topLevelRange, ranges) <- getRanges method qPrms hdrs
|
||||
(payload, columns) <- getPayload reqBody contentMediaType qPrms act
|
||||
return $ ApiRequest {
|
||||
iAction = act
|
||||
, iRange = ranges
|
||||
, iTopLevelRange = topLevelRange
|
||||
, iPayload = payload
|
||||
, iPreferences = prefs
|
||||
, iQueryParams = qPrms
|
||||
, iColumns = columns
|
||||
, iHeaders = iHdrs
|
||||
, iCookies = iCkies
|
||||
, iPath = rawPathInfo req
|
||||
, iMethod = method
|
||||
, iSchema = schema
|
||||
, iNegotiatedByProfile = negotiatedByProfile
|
||||
, iAcceptMediaType = maybe [MTAny] (map MediaType.decodeMediaType . parseHttpAccept) $ lookupHeader "accept"
|
||||
, iContentMediaType = contentMediaType
|
||||
}
|
||||
where
|
||||
method = requestMethod req
|
||||
hdrs = requestHeaders req
|
||||
lookupHeader = flip lookup hdrs
|
||||
iHdrs = [ (CI.foldedCase k, v) | (k,v) <- hdrs, k /= hCookie]
|
||||
iCkies = maybe [] parseCookies $ lookupHeader "Cookie"
|
||||
contentMediaType = maybe MTApplicationJSON MediaType.decodeMediaType $ lookupHeader "content-type"
|
||||
actIsInvokeSafe x = case x of {ActDb (ActRoutine _ (InvRead _)) -> True; _ -> False}
|
||||
|
||||
-- | Parses the Prefer header
|
||||
userPreferences :: AppConfig -> Request -> TimezoneNames -> Preferences.Preferences
|
||||
userPreferences conf req timezones = Preferences.fromHeaders (configDbTxAllowOverride conf) timezones $ requestHeaders req
|
||||
|
||||
-- | Obtains the Bearer Auth
|
||||
userBearerAuth :: Request -> Maybe ByteString
|
||||
userBearerAuth req = extractBearerAuth =<< lookup hAuthorization (requestHeaders req)
|
||||
|
||||
getResource :: AppConfig -> [Text] -> Either ApiRequestError Resource
|
||||
getResource AppConfig{configOpenApiMode, configDbRootSpec} = \case
|
||||
[] ->
|
||||
case (configOpenApiMode,configDbRootSpec) of
|
||||
(OADisabled,_) -> Left OpenAPIDisabled
|
||||
(_, Just qi) -> Right $ ResourceRoutine (qiName qi)
|
||||
(_, Nothing) -> Right ResourceSchema
|
||||
|
||||
[table] -> Right $ ResourceRelation table
|
||||
["rpc", pName] -> Right $ ResourceRoutine pName
|
||||
_ -> Left InvalidResourcePath
|
||||
|
||||
getAction :: Resource -> Schema -> ByteString -> Either ApiRequestError Action
|
||||
getAction resource schema method =
|
||||
case (resource, method) of
|
||||
(ResourceRoutine rout, "HEAD") -> Right . ActDb $ ActRoutine (qi rout) $ InvRead True
|
||||
(ResourceRoutine rout, "GET") -> Right . ActDb $ ActRoutine (qi rout) $ InvRead False
|
||||
(ResourceRoutine rout, "POST") -> Right . ActDb $ ActRoutine (qi rout) Inv
|
||||
(ResourceRoutine rout, "OPTIONS") -> Right $ ActRoutineInfo (qi rout) $ InvRead True
|
||||
(ResourceRoutine _, _) -> Left $ InvalidRpcMethod method
|
||||
|
||||
(ResourceRelation rel, "HEAD") -> Right . ActDb $ ActRelationRead (qi rel) True
|
||||
(ResourceRelation rel, "GET") -> Right . ActDb $ ActRelationRead (qi rel) False
|
||||
(ResourceRelation rel, "POST") -> Right . ActDb $ ActRelationMut (qi rel) MutationCreate
|
||||
(ResourceRelation rel, "PUT") -> Right . ActDb $ ActRelationMut (qi rel) MutationSingleUpsert
|
||||
(ResourceRelation rel, "PATCH") -> Right . ActDb $ ActRelationMut (qi rel) MutationUpdate
|
||||
(ResourceRelation rel, "DELETE") -> Right . ActDb $ ActRelationMut (qi rel) MutationDelete
|
||||
(ResourceRelation rel, "OPTIONS") -> Right $ ActRelationInfo (qi rel)
|
||||
|
||||
(ResourceSchema, "HEAD") -> Right . ActDb $ ActSchemaRead schema True
|
||||
(ResourceSchema, "GET") -> Right . ActDb $ ActSchemaRead schema False
|
||||
(ResourceSchema, "OPTIONS") -> Right ActSchemaInfo
|
||||
|
||||
_ -> Left $ UnsupportedMethod method
|
||||
where
|
||||
qi = QualifiedIdentifier schema
|
||||
|
||||
|
||||
getSchema :: AppConfig -> RequestHeaders -> ByteString -> Either ApiRequestError (Schema, Bool)
|
||||
getSchema AppConfig{configDbSchemas} hdrs method = do
|
||||
case profile of
|
||||
Just p | p `notElem` configDbSchemas -> Left $ UnacceptableSchema p $ toList configDbSchemas
|
||||
| otherwise -> Right (p, True)
|
||||
Nothing -> Right (defaultSchema, length configDbSchemas /= 1) -- if we have many schemas, assume the default schema was negotiated
|
||||
where
|
||||
defaultSchema = NonEmptyList.head configDbSchemas
|
||||
profile = case method of
|
||||
-- POST/PATCH/PUT/DELETE don't use the same header as per the spec
|
||||
"DELETE" -> contentProfile
|
||||
"PATCH" -> contentProfile
|
||||
"POST" -> contentProfile
|
||||
"PUT" -> contentProfile
|
||||
_ -> acceptProfile
|
||||
contentProfile = T.decodeUtf8 <$> lookupHeader "Content-Profile"
|
||||
acceptProfile = T.decodeUtf8 <$> lookupHeader "Accept-Profile"
|
||||
lookupHeader = flip lookup hdrs
|
||||
|
||||
getRanges :: ByteString -> QueryParams -> RequestHeaders -> Either ApiRequestError (NonnegRange, HM.HashMap Text NonnegRange)
|
||||
getRanges method QueryParams{qsRanges} hdrs
|
||||
| isInvalidRange = Left $ InvalidRange (if rangeIsEmpty headerRange then LowerGTUpper else NegativeLimit)
|
||||
| method == "PUT" && topLevelRange /= allRange = Left PutLimitNotAllowedError
|
||||
| otherwise = Right (topLevelRange, ranges)
|
||||
where
|
||||
-- According to the RFC (https://www.rfc-editor.org/rfc/rfc9110.html#name-range),
|
||||
-- the Range header must be ignored for all methods other than GET
|
||||
headerRange = if method == "GET" then rangeRequested hdrs else allRange
|
||||
limitRange = fromMaybe allRange (HM.lookup "limit" qsRanges)
|
||||
headerAndLimitRange = rangeIntersection headerRange limitRange
|
||||
-- Bypass all the ranges and send only the limit zero range (0 <= x <= -1) if
|
||||
-- limit=0 is present in the query params (not allowed for the Range header)
|
||||
ranges = HM.insert "limit" (convertToLimitZeroRange limitRange headerAndLimitRange) qsRanges
|
||||
-- The only emptyRange allowed is the limit zero range
|
||||
isInvalidRange = topLevelRange == emptyRange && not (hasLimitZero limitRange)
|
||||
topLevelRange = fromMaybe allRange $ HM.lookup "limit" ranges -- if no limit is specified, get all the request rows
|
||||
@@ -0,0 +1,138 @@
|
||||
-- |
|
||||
-- Module : PostgREST.ApiRequest.Payload
|
||||
-- Description : Parser for PostgREST Request Body
|
||||
--
|
||||
-- This module is in charge of parsing the request body (payload)
|
||||
--
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
module PostgREST.ApiRequest.Payload
|
||||
( getPayload
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.Key as K
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.Csv as CSV
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Data.Vector as V
|
||||
|
||||
import Control.Arrow ((***))
|
||||
import Data.Aeson.Types (emptyArray, emptyObject)
|
||||
import Data.Either.Combinators (mapBoth)
|
||||
import Network.HTTP.Types.URI (parseSimpleQuery)
|
||||
|
||||
import PostgREST.ApiRequest.QueryParams (QueryParams (..))
|
||||
import PostgREST.ApiRequest.Types
|
||||
import PostgREST.Error (ApiRequestError (..))
|
||||
import PostgREST.MediaType (MediaType (..))
|
||||
import PostgREST.SchemaCache.Identifiers (FieldName)
|
||||
|
||||
import qualified PostgREST.MediaType as MediaType
|
||||
|
||||
import Protolude
|
||||
|
||||
getPayload :: RequestBody -> MediaType -> QueryParams -> Action -> Either ApiRequestError (Maybe Payload, S.Set FieldName)
|
||||
getPayload reqBody contentMediaType QueryParams{qsColumns} action = do
|
||||
checkedPayload <- if shouldParsePayload then payload else Right Nothing
|
||||
let cols = case (checkedPayload, columns) of
|
||||
(Just ProcessedJSON{payKeys}, _) -> payKeys
|
||||
(Just ProcessedUrlEncoded{payKeys}, _) -> payKeys
|
||||
(Just RawJSON{}, Just cls) -> cls
|
||||
_ -> S.empty
|
||||
return (checkedPayload, cols)
|
||||
where
|
||||
payload :: Either ApiRequestError (Maybe Payload)
|
||||
payload = mapBoth InvalidBody Just $ case (contentMediaType, isProc) of
|
||||
(MTApplicationJSON, _) ->
|
||||
if isJust columns
|
||||
then Right $ RawJSON reqBody
|
||||
else note "All object keys must match" . payloadAttributes reqBody
|
||||
=<< if LBS.null reqBody && isProc
|
||||
then Right emptyObject
|
||||
else first BS.pack $
|
||||
-- Drop parsing error message in favor of generic one (https://github.com/PostgREST/postgrest/issues/2344)
|
||||
maybe (Left "Empty or invalid json") Right $ JSON.decode reqBody
|
||||
(MTTextCSV, _) -> do
|
||||
json <- csvToJson <$> first BS.pack (CSV.decodeByName reqBody)
|
||||
note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json
|
||||
(MTUrlEncoded, True) ->
|
||||
Right $ ProcessedUrlEncoded params (S.fromList $ fst <$> params)
|
||||
(MTUrlEncoded, False) ->
|
||||
let paramsMap = HM.fromList $ (identity *** JSON.String) <$> params in
|
||||
Right $ ProcessedJSON (JSON.encode paramsMap) $ S.fromList (HM.keys paramsMap)
|
||||
(MTTextPlain, True) -> Right $ RawPay reqBody
|
||||
(MTTextXML, True) -> Right $ RawPay reqBody
|
||||
(MTOctetStream, True) -> Right $ RawPay reqBody
|
||||
(ct, _) -> Left $ "Content-Type not acceptable: " <> MediaType.toMime ct
|
||||
|
||||
shouldParsePayload = case action of
|
||||
ActDb (ActRelationMut _ MutationDelete) -> False
|
||||
ActDb (ActRelationMut _ _) -> True
|
||||
ActDb (ActRoutine _ Inv) -> True
|
||||
_ -> False
|
||||
|
||||
columns = case action of
|
||||
ActDb (ActRelationMut _ MutationCreate) -> qsColumns
|
||||
ActDb (ActRelationMut _ MutationUpdate) -> qsColumns
|
||||
ActDb (ActRoutine _ Inv) -> qsColumns
|
||||
_ -> Nothing
|
||||
|
||||
isProc = case action of
|
||||
ActDb (ActRoutine _ _) -> True
|
||||
_ -> False
|
||||
params = (T.decodeUtf8 *** T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody)
|
||||
|
||||
type CsvData = V.Vector (M.Map Text LBS.ByteString)
|
||||
|
||||
{-|
|
||||
Converts CSV like
|
||||
a,b
|
||||
1,hi
|
||||
2,bye
|
||||
|
||||
into a JSON array like
|
||||
[ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ]
|
||||
|
||||
The reason for its odd signature is so that it can compose
|
||||
directly with CSV.decodeByName
|
||||
-}
|
||||
csvToJson :: (CSV.Header, CsvData) -> JSON.Value
|
||||
csvToJson (_, vals) =
|
||||
JSON.Array $ V.map rowToJsonObj vals
|
||||
where
|
||||
rowToJsonObj = JSON.Object . KM.fromMapText .
|
||||
M.map (\str ->
|
||||
if str == "NULL"
|
||||
then JSON.Null
|
||||
else JSON.String . T.decodeUtf8 $ LBS.toStrict str
|
||||
)
|
||||
|
||||
payloadAttributes :: RequestBody -> JSON.Value -> Maybe Payload
|
||||
payloadAttributes raw json =
|
||||
-- Test that Array contains only Objects having the same keys
|
||||
case json of
|
||||
JSON.Array arr ->
|
||||
case arr V.!? 0 of
|
||||
Just (JSON.Object o) ->
|
||||
let canonicalKeys = S.fromList $ K.toText <$> KM.keys o
|
||||
areKeysUniform = all (\case
|
||||
JSON.Object x -> S.fromList (K.toText <$> KM.keys x) == canonicalKeys
|
||||
_ -> False) arr in
|
||||
if areKeysUniform
|
||||
then Just $ ProcessedJSON raw canonicalKeys
|
||||
else Nothing
|
||||
Just _ -> Nothing
|
||||
Nothing -> Just emptyPJArray
|
||||
|
||||
JSON.Object o -> Just $ ProcessedJSON raw (S.fromList $ K.toText <$> KM.keys o)
|
||||
|
||||
-- truncate everything else to an empty array.
|
||||
_ -> Just emptyPJArray
|
||||
where
|
||||
emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty
|
||||
@@ -0,0 +1,295 @@
|
||||
-- |
|
||||
-- Module: PostgREST.ApiRequest.Preferences
|
||||
-- Description: Track client preferences to be employed when processing requests
|
||||
--
|
||||
-- Track client preferences set in HTTP 'Prefer' headers according to RFC7240[1].
|
||||
--
|
||||
-- [1] https://datatracker.ietf.org/doc/html/rfc7240
|
||||
--
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
module PostgREST.ApiRequest.Preferences
|
||||
( Preferences(..)
|
||||
, PreferCount(..)
|
||||
, PreferHandling(..)
|
||||
, PreferMissing(..)
|
||||
, PreferRepresentation(..)
|
||||
, PreferResolution(..)
|
||||
, PreferTransaction(..)
|
||||
, PreferTimezone(..)
|
||||
, PreferMaxAffected(..)
|
||||
, fromHeaders
|
||||
, shouldCount
|
||||
, shouldExplainCount
|
||||
, prefAppliedHeader
|
||||
, toHeaderValue
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as S
|
||||
import qualified Network.HTTP.Types.Header as HTTP
|
||||
|
||||
import PostgREST.Config.Database (TimezoneNames)
|
||||
|
||||
import Protolude
|
||||
|
||||
-- $setup
|
||||
-- Setup for doctests
|
||||
-- >>> :set -XStandaloneDeriving
|
||||
-- >>> import Text.Pretty.Simple (pPrint)
|
||||
-- >>> import qualified Data.Set as S
|
||||
-- >>> import Protolude
|
||||
-- >>> deriving instance Show PreferResolution
|
||||
-- >>> deriving instance Show PreferRepresentation
|
||||
-- >>> deriving instance Show PreferCount
|
||||
-- >>> deriving instance Show PreferTransaction
|
||||
-- >>> deriving instance Show PreferMissing
|
||||
-- >>> deriving instance Show PreferHandling
|
||||
-- >>> deriving instance Show PreferTimezone
|
||||
-- >>> deriving instance Show PreferMaxAffected
|
||||
-- >>> deriving instance Show Preferences
|
||||
|
||||
-- | Preferences recognized by the application.
|
||||
data Preferences
|
||||
= Preferences
|
||||
{ preferResolution :: Maybe PreferResolution
|
||||
, preferRepresentation :: Maybe PreferRepresentation
|
||||
, preferCount :: Maybe PreferCount
|
||||
, preferTransaction :: Maybe PreferTransaction
|
||||
, preferMissing :: Maybe PreferMissing
|
||||
, preferHandling :: Maybe PreferHandling
|
||||
, preferTimezone :: Maybe PreferTimezone
|
||||
, preferMaxAffected :: Maybe PreferMaxAffected
|
||||
, invalidPrefs :: [ByteString]
|
||||
}
|
||||
|
||||
-- |
|
||||
-- Parse HTTP headers based on RFC7240[1] to identify preferences.
|
||||
--
|
||||
-- >>> let sc = S.fromList ["America/Los_Angeles"]
|
||||
--
|
||||
-- One header with comma-separated values can be used to set multiple preferences:
|
||||
-- >>> pPrint $ fromHeaders True sc [("Prefer", "resolution=ignore-duplicates, count=exact, timezone=America/Los_Angeles, max-affected=100")]
|
||||
-- Preferences
|
||||
-- { preferResolution = Just IgnoreDuplicates
|
||||
-- , preferRepresentation = Nothing
|
||||
-- , preferCount = Just ExactCount
|
||||
-- , preferTransaction = Nothing
|
||||
-- , preferMissing = Nothing
|
||||
-- , preferHandling = Nothing
|
||||
-- , preferTimezone = Just
|
||||
-- ( PreferTimezone "America/Los_Angeles" )
|
||||
-- , preferMaxAffected = Just
|
||||
-- ( PreferMaxAffected 100 )
|
||||
-- , invalidPrefs = []
|
||||
-- }
|
||||
--
|
||||
-- Multiple headers can also be used:
|
||||
--
|
||||
-- >>> pPrint $ fromHeaders True sc [("Prefer", "resolution=ignore-duplicates"), ("Prefer", "count=exact"), ("Prefer", "missing=null"), ("Prefer", "handling=lenient"), ("Prefer", "invalid"), ("Prefer", "max-affected=5999")]
|
||||
-- Preferences
|
||||
-- { preferResolution = Just IgnoreDuplicates
|
||||
-- , preferRepresentation = Nothing
|
||||
-- , preferCount = Just ExactCount
|
||||
-- , preferTransaction = Nothing
|
||||
-- , preferMissing = Just ApplyNulls
|
||||
-- , preferHandling = Just Lenient
|
||||
-- , preferTimezone = Nothing
|
||||
-- , preferMaxAffected = Just
|
||||
-- ( PreferMaxAffected 5999 )
|
||||
-- , invalidPrefs = [ "invalid" ]
|
||||
-- }
|
||||
--
|
||||
-- If a preference is set more than once, only the first is used:
|
||||
--
|
||||
-- >>> preferTransaction $ fromHeaders True sc [("Prefer", "tx=commit, tx=rollback")]
|
||||
-- Just Commit
|
||||
--
|
||||
-- This is also the case across multiple headers:
|
||||
--
|
||||
-- >>> :{
|
||||
-- preferResolution . fromHeaders True sc $
|
||||
-- [ ("Prefer", "resolution=ignore-duplicates")
|
||||
-- , ("Prefer", "resolution=merge-duplicates")
|
||||
-- ]
|
||||
-- :}
|
||||
-- Just IgnoreDuplicates
|
||||
--
|
||||
--
|
||||
-- Preferences can be separated by arbitrary amounts of space, lower-case header is also recognized:
|
||||
--
|
||||
-- >>> pPrint $ fromHeaders True sc [("prefer", "count=exact, tx=commit ,return=representation , missing=default, handling=strict, anything")]
|
||||
-- Preferences
|
||||
-- { preferResolution = Nothing
|
||||
-- , preferRepresentation = Just Full
|
||||
-- , preferCount = Just ExactCount
|
||||
-- , preferTransaction = Just Commit
|
||||
-- , preferMissing = Just ApplyDefaults
|
||||
-- , preferHandling = Just Strict
|
||||
-- , preferTimezone = Nothing
|
||||
-- , preferMaxAffected = Nothing
|
||||
-- , invalidPrefs = [ "anything" ]
|
||||
-- }
|
||||
--
|
||||
fromHeaders :: Bool -> TimezoneNames -> [HTTP.Header] -> Preferences
|
||||
fromHeaders allowTxDbOverride acceptedTzNames headers =
|
||||
Preferences
|
||||
{ preferResolution = parsePrefs [MergeDuplicates, IgnoreDuplicates]
|
||||
, preferRepresentation = parsePrefs [Full, None, HeadersOnly]
|
||||
, preferCount = parsePrefs [ExactCount, PlannedCount, EstimatedCount]
|
||||
, preferTransaction = if allowTxDbOverride then parsePrefs [Commit, Rollback] else Nothing
|
||||
, preferMissing = parsePrefs [ApplyDefaults, ApplyNulls]
|
||||
, preferHandling = parsePrefs [Strict, Lenient]
|
||||
, preferTimezone = if isTimezonePrefAccepted then PreferTimezone <$> timezonePref else Nothing
|
||||
, preferMaxAffected = PreferMaxAffected <$> maxAffectedPref
|
||||
, invalidPrefs = filter isUnacceptable prefs
|
||||
}
|
||||
where
|
||||
mapToHeadVal :: ToHeaderValue a => [a] -> [ByteString]
|
||||
mapToHeadVal = map toHeaderValue
|
||||
acceptedPrefs = mapToHeadVal [MergeDuplicates, IgnoreDuplicates] ++
|
||||
mapToHeadVal [Full, None, HeadersOnly] ++
|
||||
mapToHeadVal [ExactCount, PlannedCount, EstimatedCount] ++
|
||||
mapToHeadVal [Commit, Rollback] ++
|
||||
mapToHeadVal [ApplyDefaults, ApplyNulls] ++
|
||||
mapToHeadVal [Strict, Lenient]
|
||||
|
||||
prefHeaders = filter ((==) HTTP.hPrefer . fst) headers
|
||||
prefs = fmap BS.strip . concatMap (BS.split ',' . snd) $ prefHeaders
|
||||
|
||||
listStripPrefix prefix prefList = listToMaybe $ mapMaybe (BS.stripPrefix prefix) prefList
|
||||
|
||||
timezonePref = listStripPrefix "timezone=" prefs
|
||||
isTimezonePrefAccepted = ((S.member . decodeUtf8 <$> timezonePref) <*> pure acceptedTzNames) == Just True
|
||||
|
||||
maxAffectedPref = listStripPrefix "max-affected=" prefs >>= readMaybe . BS.unpack
|
||||
|
||||
isUnacceptable p = p `notElem` acceptedPrefs &&
|
||||
(isNothing (BS.stripPrefix "timezone=" p) || not isTimezonePrefAccepted) &&
|
||||
isNothing (BS.stripPrefix "max-affected=" p)
|
||||
|
||||
parsePrefs :: ToHeaderValue a => [a] -> Maybe a
|
||||
parsePrefs vals =
|
||||
head $ mapMaybe (flip Map.lookup $ prefMap vals) prefs
|
||||
|
||||
prefMap :: ToHeaderValue a => [a] -> Map.Map ByteString a
|
||||
prefMap = Map.fromList . fmap (\pref -> (toHeaderValue pref, pref))
|
||||
|
||||
prefAppliedHeader :: Preferences -> Maybe HTTP.Header
|
||||
prefAppliedHeader Preferences {preferResolution, preferRepresentation, preferCount, preferTransaction, preferMissing, preferHandling, preferTimezone, preferMaxAffected } =
|
||||
if null prefsVals
|
||||
then Nothing
|
||||
else Just (HTTP.hPreferenceApplied, combined)
|
||||
where
|
||||
combined = BS.intercalate ", " prefsVals
|
||||
prefsVals = catMaybes [
|
||||
toHeaderValue <$> preferResolution
|
||||
, toHeaderValue <$> preferMissing
|
||||
, toHeaderValue <$> preferRepresentation
|
||||
, toHeaderValue <$> preferCount
|
||||
, toHeaderValue <$> preferTransaction
|
||||
, toHeaderValue <$> preferHandling
|
||||
, toHeaderValue <$> preferTimezone
|
||||
, if preferHandling == Just Strict then toHeaderValue <$> preferMaxAffected else Nothing
|
||||
]
|
||||
|
||||
-- |
|
||||
-- Convert a preference into the value that we look for in the 'Prefer' headers.
|
||||
--
|
||||
-- >>> toHeaderValue MergeDuplicates
|
||||
-- "resolution=merge-duplicates"
|
||||
--
|
||||
class ToHeaderValue a where
|
||||
toHeaderValue :: a -> ByteString
|
||||
|
||||
-- | How to handle duplicate values.
|
||||
data PreferResolution
|
||||
= MergeDuplicates
|
||||
| IgnoreDuplicates
|
||||
deriving Eq
|
||||
|
||||
instance ToHeaderValue PreferResolution where
|
||||
toHeaderValue MergeDuplicates = "resolution=merge-duplicates"
|
||||
toHeaderValue IgnoreDuplicates = "resolution=ignore-duplicates"
|
||||
|
||||
-- |
|
||||
-- How to return the mutated data.
|
||||
--
|
||||
-- From https://tools.ietf.org/html/rfc7240#section-4.2
|
||||
data PreferRepresentation
|
||||
= Full -- ^ Return the body.
|
||||
| HeadersOnly -- ^ Return the Location header(in case of POST). This needs a SELECT privilege on the pk.
|
||||
| None -- ^ Return nothing from the mutated data.
|
||||
deriving Eq
|
||||
|
||||
instance ToHeaderValue PreferRepresentation where
|
||||
toHeaderValue Full = "return=representation"
|
||||
toHeaderValue None = "return=minimal"
|
||||
toHeaderValue HeadersOnly = "return=headers-only"
|
||||
|
||||
-- | How to determine the count of (expected) results
|
||||
data PreferCount
|
||||
= ExactCount -- ^ Exact count (slower).
|
||||
| PlannedCount -- ^ PostgreSQL query planner rows count guess. Done by using EXPLAIN {query}.
|
||||
| EstimatedCount -- ^ Use the query planner rows if the count is superior to max-rows, otherwise get the exact count.
|
||||
deriving Eq
|
||||
|
||||
instance ToHeaderValue PreferCount where
|
||||
toHeaderValue ExactCount = "count=exact"
|
||||
toHeaderValue PlannedCount = "count=planned"
|
||||
toHeaderValue EstimatedCount = "count=estimated"
|
||||
|
||||
shouldCount :: Maybe PreferCount -> Bool
|
||||
shouldCount prefCount =
|
||||
prefCount == Just ExactCount || prefCount == Just EstimatedCount
|
||||
|
||||
shouldExplainCount :: Maybe PreferCount -> Bool
|
||||
shouldExplainCount prefCount =
|
||||
prefCount == Just PlannedCount || prefCount == Just EstimatedCount
|
||||
|
||||
-- | Whether to commit or roll back transactions.
|
||||
data PreferTransaction
|
||||
= Commit -- ^ Commit transaction - the default.
|
||||
| Rollback -- ^ Rollback transaction after sending the response - does not persist changes, e.g. for running tests.
|
||||
deriving Eq
|
||||
|
||||
instance ToHeaderValue PreferTransaction where
|
||||
toHeaderValue Commit = "tx=commit"
|
||||
toHeaderValue Rollback = "tx=rollback"
|
||||
|
||||
-- |
|
||||
-- How to handle the insertion/update when the keys specified in ?columns are not present
|
||||
-- in the json body.
|
||||
data PreferMissing
|
||||
= ApplyDefaults -- ^ Use the default column value for missing values.
|
||||
| ApplyNulls -- ^ Use the null value for missing values.
|
||||
deriving Eq
|
||||
|
||||
instance ToHeaderValue PreferMissing where
|
||||
toHeaderValue ApplyDefaults = "missing=default"
|
||||
toHeaderValue ApplyNulls = "missing=null"
|
||||
|
||||
-- |
|
||||
-- Handling of unrecognised preferences
|
||||
data PreferHandling
|
||||
= Strict -- ^ Throw error on unrecognised preferences
|
||||
| Lenient -- ^ Ignore unrecognised preferences
|
||||
deriving Eq
|
||||
|
||||
instance ToHeaderValue PreferHandling where
|
||||
toHeaderValue Strict = "handling=strict"
|
||||
toHeaderValue Lenient = "handling=lenient"
|
||||
|
||||
-- |
|
||||
-- Change timezone
|
||||
newtype PreferTimezone = PreferTimezone ByteString
|
||||
|
||||
instance ToHeaderValue PreferTimezone where
|
||||
toHeaderValue (PreferTimezone tz) = "timezone=" <> tz
|
||||
|
||||
-- |
|
||||
-- Limit Affected Resources
|
||||
newtype PreferMaxAffected = PreferMaxAffected Int64
|
||||
|
||||
instance ToHeaderValue PreferMaxAffected where
|
||||
toHeaderValue (PreferMaxAffected n) = "max-affected=" <> show n
|
||||
@@ -0,0 +1,879 @@
|
||||
-- |
|
||||
-- Module : PostgREST.ApiRequest.QueryParams
|
||||
-- Description : Parser for PostgREST Query parameters
|
||||
--
|
||||
-- This module is in charge of parsing all the querystring values in an url, e.g.
|
||||
-- the select, id, order in `/projects?select=id,name&id=eq.1&order=id,name.desc`.
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
module PostgREST.ApiRequest.QueryParams
|
||||
( parse
|
||||
, QueryParams(..)
|
||||
, pFieldForest
|
||||
, pFieldName
|
||||
, pFieldSelect
|
||||
, pJsonPath
|
||||
, pLogicTree
|
||||
, pOpExpr
|
||||
, pOrder
|
||||
, pRelationSelect
|
||||
, pRequestFilter
|
||||
, pRequestRange
|
||||
, pSingleVal
|
||||
, pSpreadRelationSelect
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Network.HTTP.Base as HTTP
|
||||
import qualified Network.HTTP.Types.URI as HTTP
|
||||
import qualified Text.ParserCombinators.Parsec as P
|
||||
|
||||
import Control.Arrow ((***))
|
||||
import Data.Either.Combinators (mapLeft)
|
||||
import Data.List (init, last)
|
||||
import Data.Ranged.Boundaries (Boundary (..))
|
||||
import Data.Ranged.Ranges (Range (..))
|
||||
import Data.Tree (Tree (..))
|
||||
import Text.Parsec.Error (errorMessages,
|
||||
showErrorMessages)
|
||||
import Text.ParserCombinators.Parsec (GenParser, ParseError, Parser,
|
||||
anyChar, between, char, choice,
|
||||
digit, eof, errorPos, letter,
|
||||
lookAhead, many1, noneOf,
|
||||
notFollowedBy, oneOf,
|
||||
optionMaybe, sepBy, sepBy1,
|
||||
string, try, (<?>))
|
||||
|
||||
import PostgREST.RangeQuery (NonnegRange, allRange,
|
||||
rangeGeq, rangeLimit,
|
||||
rangeOffset, restrictRange)
|
||||
import PostgREST.SchemaCache.Identifiers (FieldName)
|
||||
|
||||
import PostgREST.ApiRequest.Types (AggregateFunction (..),
|
||||
EmbedParam (..), EmbedPath, Field,
|
||||
Filter (..), FtsOperator (..),
|
||||
Hint, IsVal (..), JoinType (..),
|
||||
JsonOperand (..),
|
||||
JsonOperation (..), JsonPath,
|
||||
ListVal, LogicOperator (..),
|
||||
LogicTree (..), OpExpr (..),
|
||||
OpQuantifier (..), Operation (..),
|
||||
OrderDirection (..),
|
||||
OrderNulls (..), OrderTerm (..),
|
||||
QuantOperator (..),
|
||||
SelectItem (..),
|
||||
SimpleOperator (..), SingleVal)
|
||||
|
||||
import PostgREST.Error (QPError (..))
|
||||
|
||||
import Protolude hiding (Sum, try)
|
||||
|
||||
-- $setup
|
||||
-- >>> import qualified Text.ParserCombinators.Parsec as P
|
||||
-- >>> import Protolude hiding (Sum, try)
|
||||
|
||||
data QueryParams =
|
||||
QueryParams
|
||||
{ qsCanonical :: ByteString
|
||||
-- ^ Canonical representation of the query params, sorted alphabetically
|
||||
, qsParams :: [(Text, Text)]
|
||||
-- ^ Parameters for RPC calls
|
||||
, qsRanges :: HM.HashMap Text (Range Integer)
|
||||
-- ^ Ranges derived from &limit and &offset params
|
||||
, qsOrder :: [(EmbedPath, [OrderTerm])]
|
||||
-- ^ &order parameters for each level
|
||||
, qsLogic :: [(EmbedPath, LogicTree)]
|
||||
-- ^ &and and &or parameters used for complex boolean logic
|
||||
, qsColumns :: Maybe (S.Set FieldName)
|
||||
-- ^ &columns parameter and payload
|
||||
, qsSelect :: [Tree SelectItem]
|
||||
-- ^ &select parameter used to shape the response
|
||||
, qsFilters :: [(EmbedPath, Filter)]
|
||||
-- ^ Filters on the result from e.g. &id=e.10
|
||||
, qsFiltersRoot :: [Filter]
|
||||
-- ^ Subset of the filters that apply on the root table. These are used on UPDATE/DELETE.
|
||||
, qsFiltersNotRoot :: [(EmbedPath, Filter)]
|
||||
-- ^ Subset of the filters that do not apply on the root table
|
||||
, qsFilterFields :: S.Set FieldName
|
||||
-- ^ Set of fields that filters apply to
|
||||
, qsOnConflict :: Maybe [FieldName]
|
||||
-- ^ &on_conflict parameter used to upsert on specific unique keys
|
||||
}
|
||||
|
||||
-- |
|
||||
-- Parse query parameters from a query string like "id=eq.1&select=name".
|
||||
--
|
||||
-- The canonical representation of the query string has parameters sorted alphabetically:
|
||||
--
|
||||
-- >>> qsCanonical <$> parse True "a=1&c=3&b=2&d"
|
||||
-- Right "a=1&b=2&c=3&d="
|
||||
--
|
||||
-- 'select' is a reserved parameter that selects the fields to be returned:
|
||||
--
|
||||
-- >>> qsSelect <$> parse False "select=name,location"
|
||||
-- Right [Node {rootLabel = SelectField {selField = ("name",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []},Node {rootLabel = SelectField {selField = ("location",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]
|
||||
--
|
||||
-- Filters are parameters whose value contains an operator, separated by a '.' from its value:
|
||||
--
|
||||
-- >>> qsFilters <$> parse False "a.b=eq.0"
|
||||
-- Right [(["a"],Filter {field = ("b",[]), opExpr = OpExpr False (OpQuant OpEqual Nothing "0")})]
|
||||
--
|
||||
-- If the operator specified in a filter does not exist, parsing the query string fails:
|
||||
--
|
||||
-- >>> qsFilters <$> parse False "a.b=noop.0"
|
||||
-- Left (QPError "\"failed to parse filter (noop.0)\" (line 1, column 1)" "unexpected \"o\" expecting \"not\" or operator (eq, gt, ...)")
|
||||
parse :: Bool -> ByteString -> Either QPError QueryParams
|
||||
parse isRpcRead qs = do
|
||||
rOrd <- pRequestOrder `traverse` order
|
||||
rLogic <- pRequestLogicTree `traverse` logic
|
||||
rCols <- pRequestColumns columns
|
||||
rSel <- pRequestSelect select
|
||||
(rFlts, params) <- L.partition hasOp <$> pRequestFilter isRpcRead `traverse` filters
|
||||
(rFltsRoot, rFltsNotRoot) <- pure $ L.partition hasRootFilter rFlts
|
||||
rOnConflict <- pRequestOnConflict `traverse` onConflict
|
||||
|
||||
let rFltsFields = S.fromList (fst <$> filters)
|
||||
params' = mapMaybe (\case {(_, Filter (fld, _) (NoOpExpr v)) -> Just (fld,v); _ -> Nothing}) params
|
||||
rFltsRoot' = snd <$> rFltsRoot
|
||||
|
||||
return $ QueryParams canonical params' ranges rOrd rLogic rCols rSel rFlts rFltsRoot' rFltsNotRoot rFltsFields rOnConflict
|
||||
where
|
||||
hasRootFilter, hasOp :: (EmbedPath, Filter) -> Bool
|
||||
hasRootFilter ([], _) = True
|
||||
hasRootFilter _ = False
|
||||
hasOp (_, Filter (_, _) (NoOpExpr _)) = False
|
||||
hasOp _ = True
|
||||
|
||||
logic = filter (endingIn ["and", "or"] . fst) nonemptyParams
|
||||
select = fromMaybe "*" $ lookupParam "select"
|
||||
onConflict = lookupParam "on_conflict"
|
||||
columns = lookupParam "columns"
|
||||
order = filter (endingIn ["order"] . fst) nonemptyParams
|
||||
limits = filter (endingIn ["limit"] . fst) nonemptyParams
|
||||
-- Replace .offset ending with .limit to be able to match those params later in a map
|
||||
offsets = first (replaceLast "limit") <$> filter (endingIn ["offset"] . fst) nonemptyParams
|
||||
lookupParam :: Text -> Maybe Text
|
||||
lookupParam needle = toS <$> join (L.lookup needle qParams)
|
||||
nonemptyParams = mapMaybe (\(k, v) -> (k,) <$> v) qParams
|
||||
|
||||
qString = HTTP.parseQueryReplacePlus True qs
|
||||
|
||||
qParams = [(T.decodeUtf8 k, T.decodeUtf8 <$> v)|(k,v) <- qString]
|
||||
|
||||
canonical =
|
||||
BS.pack $ HTTP.urlEncodeVars
|
||||
. L.sortOn fst
|
||||
. map (join (***) BS.unpack . second (fromMaybe mempty))
|
||||
$ qString
|
||||
|
||||
endingIn:: [Text] -> Text -> Bool
|
||||
endingIn xx key = lastWord `elem` xx
|
||||
where lastWord = L.last $ T.split (== '.') key
|
||||
|
||||
filters = filter (isFilter . fst) nonemptyParams
|
||||
isFilter k = not (endingIn reservedEmbeddable k) && notElem k reserved
|
||||
reserved = ["select", "columns", "on_conflict"]
|
||||
reservedEmbeddable = ["order", "limit", "offset", "and", "or"]
|
||||
|
||||
replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) <> [x]
|
||||
|
||||
ranges :: HM.HashMap Text (Range Integer)
|
||||
ranges = HM.unionWith f limitParams offsetParams
|
||||
where
|
||||
f rl ro = Range (BoundaryBelow o) (BoundaryAbove $ o + l - 1)
|
||||
where
|
||||
l = fromMaybe 0 $ rangeLimit rl
|
||||
o = rangeOffset ro
|
||||
|
||||
limitParams =
|
||||
HM.fromList [(k, restrictRange (readMaybe v) allRange) | (k,v) <- limits]
|
||||
|
||||
offsetParams =
|
||||
HM.fromList [(k, maybe allRange rangeGeq (readMaybe v)) | (k,v) <- offsets]
|
||||
|
||||
simpleOperator :: Parser SimpleOperator
|
||||
simpleOperator =
|
||||
try (string "neq" $> OpNotEqual) <|>
|
||||
try (string "cs" $> OpContains) <|>
|
||||
try (string "cd" $> OpContained) <|>
|
||||
try (string "ov" $> OpOverlap) <|>
|
||||
try (string "sl" $> OpStrictlyLeft) <|>
|
||||
try (string "sr" $> OpStrictlyRight) <|>
|
||||
try (string "nxr" $> OpNotExtendsRight) <|>
|
||||
try (string "nxl" $> OpNotExtendsLeft) <|>
|
||||
try (string "adj" $> OpAdjacent) <?>
|
||||
"unknown single value operator"
|
||||
|
||||
quantOperator :: Parser QuantOperator
|
||||
quantOperator =
|
||||
try (string "eq" $> OpEqual) <|>
|
||||
try (string "gte" $> OpGreaterThanEqual) <|>
|
||||
try (string "gt" $> OpGreaterThan) <|>
|
||||
try (string "lte" $> OpLessThanEqual) <|>
|
||||
try (string "lt" $> OpLessThan) <|>
|
||||
try (string "like" $> OpLike) <|>
|
||||
try (string "ilike" $> OpILike) <|>
|
||||
try (string "match" $> OpMatch) <|>
|
||||
try (string "imatch" $> OpIMatch) <?>
|
||||
"unknown single value operator"
|
||||
|
||||
pRequestSelect :: Text -> Either QPError [Tree SelectItem]
|
||||
pRequestSelect selStr =
|
||||
mapError $ P.parse pFieldForest ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)
|
||||
|
||||
pRequestOnConflict :: Text -> Either QPError [FieldName]
|
||||
pRequestOnConflict oncStr =
|
||||
mapError $ P.parse pColumns ("failed to parse on_conflict parameter (" <> toS oncStr <> ")") (toS oncStr)
|
||||
|
||||
-- |
|
||||
-- Parse `id=eq.1`(id, eq.1) into (EmbedPath, Filter)
|
||||
--
|
||||
-- >>> pRequestFilter False ("id", "eq.1")
|
||||
-- Right ([],Filter {field = ("id",[]), opExpr = OpExpr False (OpQuant OpEqual Nothing "1")})
|
||||
--
|
||||
-- >>> pRequestFilter False ("id", "val")
|
||||
-- Left (QPError "\"failed to parse filter (val)\" (line 1, column 1)" "unexpected \"v\" expecting \"not\" or operator (eq, gt, ...)")
|
||||
--
|
||||
-- >>> pRequestFilter True ("id", "val")
|
||||
-- Right ([],Filter {field = ("id",[]), opExpr = NoOpExpr "val"})
|
||||
pRequestFilter :: Bool -> (Text, Text) -> Either QPError (EmbedPath, Filter)
|
||||
pRequestFilter isRpcRead (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper)
|
||||
where
|
||||
treePath = P.parse pTreePath ("failed to parse tree path (" ++ toS k ++ ")") $ toS k
|
||||
oper = P.parse parseFlt ("failed to parse filter (" ++ toS v ++ ")") $ toS v
|
||||
parseFlt = if isRpcRead
|
||||
then pOpExpr pSingleVal <|> pure (NoOpExpr v)
|
||||
else pOpExpr pSingleVal
|
||||
path = fst <$> treePath
|
||||
fld = snd <$> treePath
|
||||
|
||||
pRequestOrder :: (Text, Text) -> Either QPError (EmbedPath, [OrderTerm])
|
||||
pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord'
|
||||
where
|
||||
treePath = P.parse pTreePath ("failed to parse tree path (" ++ toS k ++ ")") $ toS k
|
||||
path = fst <$> treePath
|
||||
ord' = P.parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v
|
||||
|
||||
pRequestRange :: (Text, NonnegRange) -> Either QPError (EmbedPath, NonnegRange)
|
||||
pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v
|
||||
where
|
||||
treePath = P.parse pTreePath ("failed to parse tree path (" ++ toS k ++ ")") $ toS k
|
||||
path = fst <$> treePath
|
||||
|
||||
pRequestLogicTree :: (Text, Text) -> Either QPError (EmbedPath, LogicTree)
|
||||
pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree
|
||||
where
|
||||
path = P.parse pLogicPath ("failed to parse logic path (" ++ toS k ++ ")") $ toS k
|
||||
embedPath = fst <$> path
|
||||
logicTree = do
|
||||
op <- snd <$> path
|
||||
-- Concat op and v to make pLogicTree argument regular,
|
||||
-- in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)"
|
||||
P.parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") $ toS (op <> v)
|
||||
|
||||
pRequestColumns :: Maybe Text -> Either QPError (Maybe (S.Set FieldName))
|
||||
pRequestColumns colStr =
|
||||
case colStr of
|
||||
Just str ->
|
||||
mapError $ Just . S.fromList <$> P.parse pColumns ("failed to parse columns parameter (" <> toS str <> ")") (toS str)
|
||||
_ -> Right Nothing
|
||||
|
||||
ws :: Parser Text
|
||||
ws = toS <$> many (oneOf " \t")
|
||||
|
||||
lexeme :: Parser a -> Parser a
|
||||
lexeme p = ws *> p <* ws
|
||||
|
||||
pTreePath :: Parser (EmbedPath, Field)
|
||||
pTreePath = do
|
||||
p <- pFieldName `sepBy1` pDelimiter
|
||||
jp <- P.option [] pJsonPath
|
||||
return (init p, (last p, jp))
|
||||
|
||||
-- |
|
||||
-- Parse select= into a Forest of SelectItems
|
||||
--
|
||||
-- >>> P.parse pFieldForest "" "id"
|
||||
-- Right [Node {rootLabel = SelectField {selField = ("id",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]
|
||||
--
|
||||
-- >>> P.parse pFieldForest "" "client(id)"
|
||||
-- Right [Node {rootLabel = SelectRelation {selRelation = "client", selAlias = Nothing, selHint = Nothing, selJoinType = Nothing}, subForest = [Node {rootLabel = SelectField {selField = ("id",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]}]
|
||||
--
|
||||
-- >>> P.parse pFieldForest "" "*,client(*,nested(*))"
|
||||
-- Right [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []},Node {rootLabel = SelectRelation {selRelation = "client", selAlias = Nothing, selHint = Nothing, selJoinType = Nothing}, subForest = [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []},Node {rootLabel = SelectRelation {selRelation = "nested", selAlias = Nothing, selHint = Nothing, selJoinType = Nothing}, subForest = [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]}]}]
|
||||
--
|
||||
-- >>> P.parse pFieldForest "" "*,...client(*),other(*)"
|
||||
-- Right [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []},Node {rootLabel = SpreadRelation {selRelation = "client", selHint = Nothing, selJoinType = Nothing}, subForest = [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]},Node {rootLabel = SelectRelation {selRelation = "other", selAlias = Nothing, selHint = Nothing, selJoinType = Nothing}, subForest = [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]}]
|
||||
--
|
||||
-- >>> P.parse pFieldForest "" ""
|
||||
-- Right []
|
||||
--
|
||||
-- >>> P.parse pFieldForest "" "id,clients(name[])"
|
||||
-- Left (line 1, column 16):
|
||||
-- unexpected '['
|
||||
-- expecting letter, digit, "-", "->>", "->", "::", ".", ")", "," or end of input
|
||||
--
|
||||
-- >>> P.parse pFieldForest "" "data->>-78xy"
|
||||
-- Left (line 1, column 11):
|
||||
-- unexpected 'x'
|
||||
-- expecting digit, "->", "::", ".", "," or end of input
|
||||
pFieldForest :: Parser [Tree SelectItem]
|
||||
pFieldForest = pFieldTree `sepBy` lexeme (char ',')
|
||||
where
|
||||
pFieldTree = Node <$> try pSpreadRelationSelect <*> between (char '(') (char ')') pFieldForest <|>
|
||||
Node <$> try pRelationSelect <*> between (char '(') (char ')') pFieldForest <|>
|
||||
Node <$> pFieldSelect <*> pure []
|
||||
|
||||
-- |
|
||||
-- Parse field names
|
||||
--
|
||||
-- >>> P.parse pFieldName "" "identifier"
|
||||
-- Right "identifier"
|
||||
--
|
||||
-- >>> P.parse pFieldName "" "identifier with spaces"
|
||||
-- Right "identifier with spaces"
|
||||
--
|
||||
-- >>> P.parse pFieldName "" "identifier-with-dashes"
|
||||
-- Right "identifier-with-dashes"
|
||||
--
|
||||
-- >>> P.parse pFieldName "" "123"
|
||||
-- Right "123"
|
||||
--
|
||||
-- >>> P.parse pFieldName "" "_"
|
||||
-- Right "_"
|
||||
--
|
||||
-- >>> P.parse pFieldName "" "$"
|
||||
-- Right "$"
|
||||
--
|
||||
-- >>> P.parse pFieldName "" ":"
|
||||
-- Left (line 1, column 1):
|
||||
-- unexpected ":"
|
||||
-- expecting field name (* or [a..z0..9_$])
|
||||
--
|
||||
-- >>> P.parse pFieldName "" "\":\""
|
||||
-- Right ":"
|
||||
--
|
||||
-- >>> P.parse pFieldName "" " no leading or trailing spaces "
|
||||
-- Right "no leading or trailing spaces"
|
||||
--
|
||||
-- >>> P.parse pFieldName "" "\" leading and trailing spaces \""
|
||||
-- Right " leading and trailing spaces "
|
||||
pFieldName :: Parser Text
|
||||
pFieldName =
|
||||
pQuotedValue <|>
|
||||
sepByDash pIdentifier <?>
|
||||
"field name (* or [a..z0..9_$])"
|
||||
|
||||
sepByDash :: Parser Text -> Parser Text
|
||||
sepByDash fieldIdent =
|
||||
T.intercalate "-" . map toS <$> (fieldIdent `sepBy1` dash)
|
||||
where
|
||||
isDash :: GenParser Char st ()
|
||||
isDash = try ( char '-' >> notFollowedBy (char '>') )
|
||||
dash :: Parser Char
|
||||
dash = isDash $> '-'
|
||||
|
||||
-- |
|
||||
-- Parse json operators in select, order and filters
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->text"
|
||||
-- Right [JArrow {jOp = JKey {jVal = "text"}}]
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->!@#$%^&*_a"
|
||||
-- Right [JArrow {jOp = JKey {jVal = "!@#$%^&*_a"}}]
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->1"
|
||||
-- Right [JArrow {jOp = JIdx {jVal = "+1"}}]
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->>text"
|
||||
-- Right [J2Arrow {jOp = JKey {jVal = "text"}}]
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->>!@#$%^&*_a"
|
||||
-- Right [J2Arrow {jOp = JKey {jVal = "!@#$%^&*_a"}}]
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->>1"
|
||||
-- Right [J2Arrow {jOp = JIdx {jVal = "+1"}}]
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->0,other"
|
||||
-- Right [JArrow {jOp = JIdx {jVal = "+0"}}]
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->0.desc"
|
||||
-- Right [JArrow {jOp = JIdx {jVal = "+0"}}]
|
||||
--
|
||||
-- Fails on badly formed negatives
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->>-78xy"
|
||||
-- Left (line 1, column 7):
|
||||
-- unexpected 'x'
|
||||
-- expecting digit, "->", "::", ".", "," or end of input
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->>--34"
|
||||
-- Left (line 1, column 5):
|
||||
-- unexpected "-"
|
||||
-- expecting digit
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->>-xy-4"
|
||||
-- Left (line 1, column 5):
|
||||
-- unexpected "x"
|
||||
-- expecting digit
|
||||
pJsonPath :: Parser JsonPath
|
||||
pJsonPath = many pJsonOperation
|
||||
where
|
||||
pJsonOperation :: Parser JsonOperation
|
||||
pJsonOperation = pJsonArrow <*> pJsonOperand
|
||||
|
||||
pJsonArrow =
|
||||
try (string "->>" $> J2Arrow) <|>
|
||||
try (string "->" $> JArrow)
|
||||
|
||||
pJsonOperand =
|
||||
let pJKey = JKey . toS <$> pJsonKeyName
|
||||
pJIdx = JIdx . toS <$> ((:) <$> P.option '+' (char '-') <*> many1 digit) <* pEnd
|
||||
pEnd = try (void $ lookAhead (string "->")) <|>
|
||||
try (void $ lookAhead (string "::")) <|>
|
||||
try (void $ lookAhead (string ".")) <|>
|
||||
try (void $ lookAhead (string ",")) <|>
|
||||
try eof in
|
||||
try pJIdx <|> try pJKey
|
||||
|
||||
pJsonKeyName :: Parser Text
|
||||
pJsonKeyName =
|
||||
pQuotedValue <|>
|
||||
sepByDash pJsonKeyIdentifier <?>
|
||||
"any non reserved character different from: .,>()"
|
||||
|
||||
pJsonKeyIdentifier :: Parser Text
|
||||
pJsonKeyIdentifier = T.strip . toS <$> many1 (noneOf "(-:.,>)")
|
||||
|
||||
pField :: Parser Field
|
||||
pField = lexeme $ (,) <$> pFieldName <*> P.option [] pJsonPath
|
||||
|
||||
aliasSeparator :: Parser ()
|
||||
aliasSeparator = char ':' >> notFollowedBy (char ':')
|
||||
|
||||
-- |
|
||||
-- Parse regular fields in select
|
||||
--
|
||||
-- >>> P.parse pRelationSelect "" "rel(*)"
|
||||
-- Right (SelectRelation {selRelation = "rel", selAlias = Nothing, selHint = Nothing, selJoinType = Nothing})
|
||||
--
|
||||
-- >>> P.parse pRelationSelect "" "alias:rel(*)"
|
||||
-- Right (SelectRelation {selRelation = "rel", selAlias = Just "alias", selHint = Nothing, selJoinType = Nothing})
|
||||
--
|
||||
-- >>> P.parse pRelationSelect "" "rel!hint(*)"
|
||||
-- Right (SelectRelation {selRelation = "rel", selAlias = Nothing, selHint = Just "hint", selJoinType = Nothing})
|
||||
--
|
||||
-- >>> P.parse pRelationSelect "" "rel!inner(*)"
|
||||
-- Right (SelectRelation {selRelation = "rel", selAlias = Nothing, selHint = Nothing, selJoinType = Just JTInner})
|
||||
--
|
||||
-- >>> P.parse pRelationSelect "" "rel!hint!inner(*)"
|
||||
-- Right (SelectRelation {selRelation = "rel", selAlias = Nothing, selHint = Just "hint", selJoinType = Just JTInner})
|
||||
--
|
||||
-- >>> P.parse pRelationSelect "" "alias:rel!inner!hint(*)"
|
||||
-- Right (SelectRelation {selRelation = "rel", selAlias = Just "alias", selHint = Just "hint", selJoinType = Just JTInner})
|
||||
--
|
||||
-- >>> P.parse pRelationSelect "" "rel->jsonpath(*)"
|
||||
-- Left (line 1, column 6):
|
||||
-- unexpected '>'
|
||||
--
|
||||
-- >>> P.parse pRelationSelect "" "rel->jsonpath!hint(*)"
|
||||
-- Left (line 1, column 6):
|
||||
-- unexpected '>'
|
||||
pRelationSelect :: Parser SelectItem
|
||||
pRelationSelect = lexeme $ do
|
||||
alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
|
||||
name <- pFieldName
|
||||
guard (name /= "count")
|
||||
(hint, jType) <- pEmbedParams
|
||||
try (void $ lookAhead (string "("))
|
||||
return $ SelectRelation name alias hint jType
|
||||
|
||||
|
||||
-- |
|
||||
-- Parse regular fields in select
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "name"
|
||||
-- Right (SelectField {selField = ("name",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing})
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "name->jsonpath"
|
||||
-- Right (SelectField {selField = ("name",[JArrow {jOp = JKey {jVal = "jsonpath"}}]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing})
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "name::cast"
|
||||
-- Right (SelectField {selField = ("name",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Just "cast", selAlias = Nothing})
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "alias:name"
|
||||
-- Right (SelectField {selField = ("name",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Just "alias"})
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "alias:name->jsonpath::cast"
|
||||
-- Right (SelectField {selField = ("name",[JArrow {jOp = JKey {jVal = "jsonpath"}}]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Just "cast", selAlias = Just "alias"})
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "alias:name->!@#$%^&*_a::cast"
|
||||
-- Right (SelectField {selField = ("name",[JArrow {jOp = JKey {jVal = "!@#$%^&*_a"}}]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Just "cast", selAlias = Just "alias"})
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "*"
|
||||
-- Right (SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing})
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "name!hint"
|
||||
-- Left (line 1, column 5):
|
||||
-- unexpected '!'
|
||||
-- expecting letter, digit, "-", "->>", "->", "::", ".", ")", "," or end of input
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "*!hint"
|
||||
-- Left (line 1, column 2):
|
||||
-- unexpected '!'
|
||||
-- expecting ")", "," or end of input
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "name::"
|
||||
-- Left (line 1, column 7):
|
||||
-- unexpected end of input
|
||||
-- expecting letter or digit
|
||||
pFieldSelect :: Parser SelectItem
|
||||
pFieldSelect = lexeme $ try (do
|
||||
s <- pStar
|
||||
pEnd
|
||||
return $ SelectField (s, []) Nothing Nothing Nothing Nothing)
|
||||
<|> try (do
|
||||
alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
|
||||
_ <- string "count()"
|
||||
aggCast' <- optionMaybe (string "::" *> pIdentifier)
|
||||
pEnd
|
||||
return $ SelectField ("*", []) (Just Count) (toS <$> aggCast') Nothing alias)
|
||||
<|> do
|
||||
alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
|
||||
fld <- pField
|
||||
cast' <- optionMaybe (string "::" *> pIdentifier)
|
||||
agg <- optionMaybe (try (char '.' *> pAggregation <* string "()"))
|
||||
aggCast' <- optionMaybe (string "::" *> pIdentifier)
|
||||
pEnd
|
||||
return $ SelectField fld agg (toS <$> aggCast') (toS <$> cast') alias
|
||||
where
|
||||
pEnd = try (void $ lookAhead (string ")")) <|>
|
||||
try (void $ lookAhead (string ",")) <|>
|
||||
try eof
|
||||
pStar = string "*" $> "*"
|
||||
pAggregation = choice
|
||||
[ string "sum" $> Sum
|
||||
, string "avg" $> Avg
|
||||
, string "count" $> Count
|
||||
-- Using 'try' for "min" and "max" to allow backtracking.
|
||||
-- This is necessary because both start with the same character 'm',
|
||||
-- and without 'try', a partial match on "max" would prevent "min" from being tried.
|
||||
, try (string "max") $> Max
|
||||
, try (string "min") $> Min
|
||||
]
|
||||
|
||||
|
||||
-- |
|
||||
-- Parse spread relations in select
|
||||
--
|
||||
-- >>> P.parse pSpreadRelationSelect "" "...rel(*)"
|
||||
-- Right (SpreadRelation {selRelation = "rel", selHint = Nothing, selJoinType = Nothing})
|
||||
--
|
||||
-- >>> P.parse pSpreadRelationSelect "" "...rel!hint!inner(*)"
|
||||
-- Right (SpreadRelation {selRelation = "rel", selHint = Just "hint", selJoinType = Just JTInner})
|
||||
--
|
||||
-- >>> P.parse pSpreadRelationSelect "" "rel(*)"
|
||||
-- Left (line 1, column 1):
|
||||
-- unexpected "r"
|
||||
-- expecting "..."
|
||||
--
|
||||
-- >>> P.parse pSpreadRelationSelect "" "alias:...rel(*)"
|
||||
-- Left (line 1, column 1):
|
||||
-- unexpected "a"
|
||||
-- expecting "..."
|
||||
--
|
||||
-- >>> P.parse pSpreadRelationSelect "" "...rel->jsonpath(*)"
|
||||
-- Left (line 1, column 9):
|
||||
-- unexpected '>'
|
||||
pSpreadRelationSelect :: Parser SelectItem
|
||||
pSpreadRelationSelect = lexeme $ do
|
||||
name <- string "..." >> pFieldName
|
||||
(hint, jType) <- pEmbedParams
|
||||
try (void $ lookAhead (string "("))
|
||||
return $ SpreadRelation name hint jType
|
||||
|
||||
pEmbedParams :: Parser (Maybe Hint, Maybe JoinType)
|
||||
pEmbedParams = do
|
||||
prm1 <- optionMaybe pEmbedParam
|
||||
prm2 <- optionMaybe pEmbedParam
|
||||
return (embedParamHint prm1 <|> embedParamHint prm2, embedParamJoin prm1 <|> embedParamJoin prm2)
|
||||
where
|
||||
pEmbedParam :: Parser EmbedParam
|
||||
pEmbedParam =
|
||||
char '!' *> (
|
||||
try (string "left" $> EPJoinType JTLeft) <|>
|
||||
try (string "inner" $> EPJoinType JTInner) <|>
|
||||
try (EPHint <$> pFieldName))
|
||||
embedParamHint prm = case prm of
|
||||
Just (EPHint hint) -> Just hint
|
||||
_ -> Nothing
|
||||
embedParamJoin prm = case prm of
|
||||
Just (EPJoinType jt) -> Just jt
|
||||
_ -> Nothing
|
||||
|
||||
-- |
|
||||
-- Parse operator expression used in horizontal filtering
|
||||
--
|
||||
-- >>> P.parse (pOpExpr pSingleVal) "" "fts().value"
|
||||
-- Left (line 1, column 5):
|
||||
-- unexpected ")"
|
||||
-- expecting operator (eq, gt, ...)
|
||||
--
|
||||
-- >>> P.parse (pOpExpr pSingleVal) "" "eq(any).value"
|
||||
-- Right (OpExpr False (OpQuant OpEqual (Just QuantAny) "value"))
|
||||
--
|
||||
-- >>> P.parse (pOpExpr pSingleVal) "" "eq(all).value"
|
||||
-- Right (OpExpr False (OpQuant OpEqual (Just QuantAll) "value"))
|
||||
--
|
||||
-- >>> P.parse (pOpExpr pSingleVal) "" "not.eq(all).value"
|
||||
-- Right (OpExpr True (OpQuant OpEqual (Just QuantAll) "value"))
|
||||
--
|
||||
-- >>> P.parse (pOpExpr pSingleVal) "" "eq().value"
|
||||
-- Left (line 1, column 4):
|
||||
-- unexpected ")"
|
||||
-- expecting operator (eq, gt, ...)
|
||||
--
|
||||
-- >>> P.parse (pOpExpr pSingleVal) "" "is().value"
|
||||
-- Left (line 1, column 3):
|
||||
-- unexpected "("
|
||||
-- expecting operator (eq, gt, ...)
|
||||
--
|
||||
-- >>> P.parse (pOpExpr pSingleVal) "" "in().value"
|
||||
-- Left (line 1, column 3):
|
||||
-- unexpected "("
|
||||
-- expecting operator (eq, gt, ...)
|
||||
pOpExpr :: Parser SingleVal -> Parser OpExpr
|
||||
pOpExpr pSVal = do
|
||||
boolExpr <- try (string "not" *> pDelimiter $> True) <|> pure False
|
||||
OpExpr boolExpr <$> pOperation
|
||||
where
|
||||
pOperation :: Parser Operation
|
||||
pOperation = pIn <|> pIs <|> pIsDist <|> try pFts <|> try pSimpleOp <|> try pQuantOp <?> "operator (eq, gt, ...)"
|
||||
|
||||
pIn = In <$> (try (string "in" *> pDelimiter) *> pListVal)
|
||||
pIs = Is <$> (try (string "is" *> pDelimiter) *> pIsVal)
|
||||
|
||||
pIsDist = IsDistinctFrom <$> (try (string "isdistinct" *> pDelimiter) *> pSVal)
|
||||
|
||||
pSimpleOp = do
|
||||
op <- simpleOperator
|
||||
pDelimiter *> (Op op <$> pSVal)
|
||||
|
||||
pQuantOp = do
|
||||
op <- quantOperator
|
||||
quant <- optionMaybe $ try (between (char '(') (char ')') (try (string "any" $> QuantAny) <|> string "all" $> QuantAll))
|
||||
pDelimiter *> (OpQuant op quant <$> pSVal)
|
||||
|
||||
pIsVal = try (ciString "null" $> IsNull)
|
||||
<|> try (ciString "not_null" $> IsNotNull)
|
||||
<|> try (ciString "true" $> IsTriTrue)
|
||||
<|> try (ciString "false" $> IsTriFalse)
|
||||
<|> try (ciString "unknown" $> IsTriUnknown)
|
||||
<?> "isVal: (null, not_null, true, false, unknown)"
|
||||
|
||||
pFts = do
|
||||
op <- try (string "fts" $> FilterFts)
|
||||
<|> try (string "plfts" $> FilterFtsPlain)
|
||||
<|> try (string "phfts" $> FilterFtsPhrase)
|
||||
<|> try (string "wfts" $> FilterFtsWebsearch)
|
||||
|
||||
lang <- optionMaybe $ try (between (char '(') (char ')') pIdentifier)
|
||||
pDelimiter >> Fts op (toS <$> lang) <$> pSVal
|
||||
|
||||
-- case insensitive char and string
|
||||
ciChar :: Char -> GenParser Char state Char
|
||||
ciChar c = char c <|> char (toUpper c)
|
||||
ciString :: [Char] -> GenParser Char state [Char]
|
||||
ciString = traverse ciChar
|
||||
|
||||
pSingleVal :: Parser SingleVal
|
||||
pSingleVal = toS <$> many anyChar
|
||||
|
||||
pListVal :: Parser ListVal
|
||||
pListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')')
|
||||
|
||||
pListElement :: Parser Text
|
||||
pListElement = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> (toS <$> many (noneOf ",)"))
|
||||
|
||||
pQuotedValue :: Parser Text
|
||||
pQuotedValue = toS <$> (char '"' *> many pCharsOrSlashed <* char '"')
|
||||
where
|
||||
pCharsOrSlashed = noneOf "\\\"" <|> (char '\\' *> anyChar)
|
||||
|
||||
pDelimiter :: Parser Char
|
||||
pDelimiter = char '.' <?> "delimiter (.)"
|
||||
|
||||
-- |
|
||||
-- Parses the elements in the order query parameter
|
||||
--
|
||||
-- >>> P.parse pOrder "" "name.desc.nullsfirst"
|
||||
-- Right [OrderTerm {otTerm = ("name",[]), otDirection = Just OrderDesc, otNullOrder = Just OrderNullsFirst}]
|
||||
--
|
||||
-- >>> P.parse pOrder "" "json_col->key.asc.nullslast"
|
||||
-- Right [OrderTerm {otTerm = ("json_col",[JArrow {jOp = JKey {jVal = "key"}}]), otDirection = Just OrderAsc, otNullOrder = Just OrderNullsLast}]
|
||||
--
|
||||
-- >>> P.parse pOrder "" "json_col->!@#$%^&*_a.asc.nullslast"
|
||||
-- Right [OrderTerm {otTerm = ("json_col",[JArrow {jOp = JKey {jVal = "!@#$%^&*_a"}}]), otDirection = Just OrderAsc, otNullOrder = Just OrderNullsLast}]
|
||||
--
|
||||
-- >>> P.parse pOrder "" "clients(json_col->key).desc.nullsfirst"
|
||||
-- Right [OrderRelationTerm {otRelation = "clients", otRelTerm = ("json_col",[JArrow {jOp = JKey {jVal = "key"}}]), otDirection = Just OrderDesc, otNullOrder = Just OrderNullsFirst}]
|
||||
--
|
||||
-- >>> P.parse pOrder "" "clients(json_col->!@#$%^&*_a).desc.nullsfirst"
|
||||
-- Right [OrderRelationTerm {otRelation = "clients", otRelTerm = ("json_col",[JArrow {jOp = JKey {jVal = "!@#$%^&*_a"}}]), otDirection = Just OrderDesc, otNullOrder = Just OrderNullsFirst}]
|
||||
--
|
||||
-- >>> P.parse pOrder "" "clients(name,id)"
|
||||
-- Left (line 1, column 8):
|
||||
-- unexpected '('
|
||||
-- expecting letter, digit, "-", "->>", "->", delimiter (.), "," or end of input
|
||||
--
|
||||
-- >>> P.parse pOrder "" "name,clients(name),id"
|
||||
-- Right [OrderTerm {otTerm = ("name",[]), otDirection = Nothing, otNullOrder = Nothing},OrderRelationTerm {otRelation = "clients", otRelTerm = ("name",[]), otDirection = Nothing, otNullOrder = Nothing},OrderTerm {otTerm = ("id",[]), otDirection = Nothing, otNullOrder = Nothing}]
|
||||
--
|
||||
-- >>> P.parse pOrder "" "id.ac"
|
||||
-- Left (line 1, column 4):
|
||||
-- unexpected "c"
|
||||
-- expecting "asc", "desc", "nullsfirst" or "nullslast"
|
||||
--
|
||||
-- >>> P.parse pOrder "" "id.descc"
|
||||
-- Left (line 1, column 8):
|
||||
-- unexpected 'c'
|
||||
-- expecting delimiter (.), "," or end of input
|
||||
--
|
||||
-- >>> P.parse pOrder "" "id.nulsfist"
|
||||
-- Left (line 1, column 4):
|
||||
-- unexpected "n"
|
||||
-- expecting "asc", "desc", "nullsfirst" or "nullslast"
|
||||
--
|
||||
-- >>> P.parse pOrder "" "id.nullslasttt"
|
||||
-- Left (line 1, column 13):
|
||||
-- unexpected 't'
|
||||
-- expecting "," or end of input
|
||||
--
|
||||
-- >>> P.parse pOrder "" "id.smth34"
|
||||
-- Left (line 1, column 4):
|
||||
-- unexpected "s"
|
||||
-- expecting "asc", "desc", "nullsfirst" or "nullslast"
|
||||
--
|
||||
-- >>> P.parse pOrder "" "id.asc.nlsfst"
|
||||
-- Left (line 1, column 8):
|
||||
-- unexpected "l"
|
||||
-- expecting "nullsfirst" or "nullslast"
|
||||
--
|
||||
-- >>> P.parse pOrder "" "id.asc.nullslasttt"
|
||||
-- Left (line 1, column 17):
|
||||
-- unexpected 't'
|
||||
-- expecting "," or end of input
|
||||
--
|
||||
-- >>> P.parse pOrder "" "id.asc.smth34"
|
||||
-- Left (line 1, column 8):
|
||||
-- unexpected "s"
|
||||
-- expecting "nullsfirst" or "nullslast"
|
||||
pOrder :: Parser [OrderTerm]
|
||||
pOrder = lexeme (try pOrderRelationTerm <|> pOrderTerm) `sepBy1` char ','
|
||||
where
|
||||
pOrderTerm = do
|
||||
fld <- pField
|
||||
dir <- optionMaybe pOrdDir
|
||||
nls <- optionMaybe pNulls <* pEnd <|>
|
||||
pEnd $> Nothing
|
||||
return $ OrderTerm fld dir nls
|
||||
|
||||
pOrderRelationTerm = do
|
||||
nam <- pFieldName
|
||||
fld <- between (char '(') (char ')') pField
|
||||
dir <- optionMaybe pOrdDir
|
||||
nls <- optionMaybe pNulls <* pEnd <|> pEnd $> Nothing
|
||||
return $ OrderRelationTerm nam fld dir nls
|
||||
|
||||
pNulls :: Parser OrderNulls
|
||||
pNulls = try (pDelimiter *> string "nullsfirst" $> OrderNullsFirst) <|>
|
||||
try (pDelimiter *> string "nullslast" $> OrderNullsLast)
|
||||
|
||||
pOrdDir :: Parser OrderDirection
|
||||
pOrdDir = try (pDelimiter *> string "asc" $> OrderAsc) <|>
|
||||
try (pDelimiter *> string "desc" $> OrderDesc)
|
||||
|
||||
pEnd = try (void $ lookAhead (char ',')) <|> try eof
|
||||
|
||||
-- |
|
||||
-- Parses the elements inside or/and
|
||||
--
|
||||
-- >>> P.parse pLogicTree "" "or()"
|
||||
-- Left (line 1, column 4):
|
||||
-- unexpected ")"
|
||||
-- expecting field name (* or [a..z0..9_$]), negation operator (not) or logic operator (and, or)
|
||||
--
|
||||
-- >>> P.parse pLogicTree "" "or(id.in.1,2,id.eq.3)"
|
||||
-- Left (line 1, column 10):
|
||||
-- unexpected "1"
|
||||
-- expecting "("
|
||||
--
|
||||
-- >>> P.parse pLogicTree "" "or)("
|
||||
-- Left (line 1, column 3):
|
||||
-- unexpected ")"
|
||||
-- expecting "("
|
||||
--
|
||||
-- >>> P.parse pLogicTree "" "and(ord(id.eq.1,id.eq.1),id.eq.2)"
|
||||
-- Left (line 1, column 7):
|
||||
-- unexpected "d"
|
||||
-- expecting "("
|
||||
--
|
||||
-- >>> P.parse pLogicTree "" "or(id.eq.1,not.xor(id.eq.2,id.eq.3))"
|
||||
-- Left (line 1, column 16):
|
||||
-- unexpected "x"
|
||||
-- expecting logic operator (and, or)
|
||||
pLogicTree :: Parser LogicTree
|
||||
pLogicTree = Stmnt <$> try pLogicFilter
|
||||
<|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree `sepBy1` lexeme (char ',') <* lexeme (char ')'))
|
||||
where
|
||||
pLogicFilter :: Parser Filter
|
||||
pLogicFilter = Filter <$> pField <* pDelimiter <*> pOpExpr pLogicSingleVal
|
||||
pNot :: Parser Bool
|
||||
pNot = try (string "not" *> pDelimiter $> True)
|
||||
<|> pure False
|
||||
<?> "negation operator (not)"
|
||||
pLogicOp :: Parser LogicOperator
|
||||
pLogicOp = try (string "and" $> And)
|
||||
<|> string "or" $> Or
|
||||
<?> "logic operator (and, or)"
|
||||
|
||||
pLogicSingleVal :: Parser SingleVal
|
||||
pLogicSingleVal = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> try pPgArray <|> (toS <$> many (noneOf ",)"))
|
||||
where
|
||||
pPgArray :: Parser Text
|
||||
pPgArray = do
|
||||
a <- string "{"
|
||||
b <- many (noneOf "{}")
|
||||
c <- string "}"
|
||||
pure (toS $ a ++ b ++ c)
|
||||
|
||||
pLogicPath :: Parser (EmbedPath, Text)
|
||||
pLogicPath = do
|
||||
path <- pFieldName `sepBy1` pDelimiter
|
||||
let op = last path
|
||||
notOp = "not." <> op
|
||||
return (filter (/= "not") (init path), if "not" `elem` path then notOp else op)
|
||||
|
||||
pColumns :: Parser [FieldName]
|
||||
pColumns = pFieldName `sepBy1` lexeme (char ',')
|
||||
|
||||
pIdentifier :: Parser Text
|
||||
pIdentifier = T.strip . toS <$> many1 pIdentifierChar
|
||||
|
||||
pIdentifierChar :: Parser Char
|
||||
pIdentifierChar = letter <|> digit <|> oneOf "_ $"
|
||||
|
||||
mapError :: Either ParseError a -> Either QPError a
|
||||
mapError = mapLeft translateError
|
||||
where
|
||||
translateError e =
|
||||
QPError message details
|
||||
where
|
||||
message = show $ errorPos e
|
||||
details = T.strip $ T.replace "\n" " " $ toS
|
||||
$ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
|
||||
@@ -0,0 +1,279 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
module PostgREST.ApiRequest.Types
|
||||
( AggregateFunction(..)
|
||||
, Alias
|
||||
, Cast
|
||||
, Depth
|
||||
, EmbedParam(..)
|
||||
, EmbedPath
|
||||
, Field
|
||||
, Filter(..)
|
||||
, Hint
|
||||
, JoinType(..)
|
||||
, JsonOperand(..)
|
||||
, JsonOperation(..)
|
||||
, JsonPath
|
||||
, Language
|
||||
, ListVal
|
||||
, LogicOperator(..)
|
||||
, LogicTree(..)
|
||||
, NodeName
|
||||
, OpExpr(..)
|
||||
, Operation (..)
|
||||
, OpQuantifier(..)
|
||||
, OrderDirection(..)
|
||||
, OrderNulls(..)
|
||||
, OrderTerm(..)
|
||||
, SingleVal
|
||||
, IsVal(..)
|
||||
, SimpleOperator(..)
|
||||
, QuantOperator(..)
|
||||
, FtsOperator(..)
|
||||
, SelectItem(..)
|
||||
, Payload (..)
|
||||
, InvokeMethod (..)
|
||||
, Mutation (..)
|
||||
, Resource (..)
|
||||
, DbAction (..)
|
||||
, Action (..)
|
||||
, RequestBody
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.Set as S
|
||||
|
||||
import PostgREST.SchemaCache.Identifiers (FieldName,
|
||||
QualifiedIdentifier (..),
|
||||
Schema)
|
||||
|
||||
import Protolude
|
||||
|
||||
data InvokeMethod = Inv | InvRead Bool
|
||||
deriving Eq
|
||||
|
||||
data Mutation
|
||||
= MutationCreate
|
||||
| MutationDelete
|
||||
| MutationSingleUpsert
|
||||
| MutationUpdate
|
||||
deriving Eq
|
||||
|
||||
data Resource
|
||||
= ResourceRelation Text
|
||||
| ResourceRoutine Text
|
||||
| ResourceSchema
|
||||
|
||||
data DbAction
|
||||
= ActRelationRead {dbActQi :: QualifiedIdentifier, actHeadersOnly :: Bool}
|
||||
| ActRelationMut {dbActQi :: QualifiedIdentifier, actMutation :: Mutation}
|
||||
| ActRoutine {dbActQi :: QualifiedIdentifier, actInvMethod :: InvokeMethod}
|
||||
| ActSchemaRead Schema Bool
|
||||
|
||||
data Action
|
||||
= ActDb DbAction
|
||||
| ActRelationInfo QualifiedIdentifier
|
||||
| ActRoutineInfo QualifiedIdentifier InvokeMethod
|
||||
| ActSchemaInfo
|
||||
|
||||
type RequestBody = LBS.ByteString
|
||||
|
||||
data Payload
|
||||
= ProcessedJSON -- ^ Cached attributes of a JSON payload
|
||||
{ payRaw :: LBS.ByteString
|
||||
-- ^ This is the raw ByteString that comes from the request body. We
|
||||
-- cache this instead of an Aeson Value because it was detected that for
|
||||
-- large payloads the encoding had high memory usage, see
|
||||
-- https://github.com/PostgREST/postgrest/pull/1005 for more details
|
||||
, payKeys :: S.Set Text
|
||||
-- ^ Keys of the object or if it's an array these keys are guaranteed to
|
||||
-- be the same across all its objects
|
||||
}
|
||||
| ProcessedUrlEncoded { payArray :: [(Text, Text)], payKeys :: S.Set Text }
|
||||
| RawJSON { payRaw :: LBS.ByteString }
|
||||
| RawPay { payRaw :: LBS.ByteString }
|
||||
|
||||
|
||||
-- | The value in `/tbl?select=alias:field.aggregateFunction()::cast`
|
||||
data SelectItem
|
||||
= SelectField
|
||||
{ selField :: Field
|
||||
, selAggregateFunction :: Maybe AggregateFunction
|
||||
, selAggregateCast :: Maybe Cast
|
||||
, selCast :: Maybe Cast
|
||||
, selAlias :: Maybe Alias
|
||||
}
|
||||
-- | The value in `/tbl?select=alias:another_tbl(*)`
|
||||
| SelectRelation
|
||||
{ selRelation :: FieldName
|
||||
, selAlias :: Maybe Alias
|
||||
, selHint :: Maybe Hint
|
||||
, selJoinType :: Maybe JoinType
|
||||
}
|
||||
-- | The value in `/tbl?select=...another_tbl(*)`
|
||||
| SpreadRelation
|
||||
{ selRelation :: FieldName
|
||||
, selHint :: Maybe Hint
|
||||
, selJoinType :: Maybe JoinType
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
type NodeName = Text
|
||||
type Depth = Integer
|
||||
|
||||
data OrderTerm
|
||||
= OrderTerm
|
||||
{ otTerm :: Field
|
||||
, otDirection :: Maybe OrderDirection
|
||||
, otNullOrder :: Maybe OrderNulls
|
||||
}
|
||||
| OrderRelationTerm
|
||||
{ otRelation :: FieldName
|
||||
, otRelTerm :: Field
|
||||
, otDirection :: Maybe OrderDirection
|
||||
, otNullOrder :: Maybe OrderNulls
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data OrderDirection
|
||||
= OrderAsc
|
||||
| OrderDesc
|
||||
deriving (Eq, Show)
|
||||
|
||||
data OrderNulls
|
||||
= OrderNullsFirst
|
||||
| OrderNullsLast
|
||||
deriving (Eq, Show)
|
||||
|
||||
type Field = (FieldName, JsonPath)
|
||||
type Cast = Text
|
||||
type Alias = Text
|
||||
type Hint = Text
|
||||
|
||||
data AggregateFunction = Sum | Avg | Max | Min | Count
|
||||
deriving (Show, Eq)
|
||||
|
||||
data EmbedParam
|
||||
-- | Disambiguates an embedding operation when there's multiple relationships
|
||||
-- between two tables. Can be the name of a foreign key constraint, column
|
||||
-- name or the junction in an m2m relationship.
|
||||
= EPHint Hint
|
||||
| EPJoinType JoinType
|
||||
|
||||
data JoinType
|
||||
= JTInner
|
||||
| JTLeft
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path
|
||||
-- ["clients", "projects"]
|
||||
type EmbedPath = [Text]
|
||||
|
||||
-- | Json path operations as specified in
|
||||
-- https://www.postgresql.org/docs/current/static/functions-json.html
|
||||
type JsonPath = [JsonOperation]
|
||||
|
||||
-- | Represents the single arrow `->` or double arrow `->>` operators
|
||||
data JsonOperation
|
||||
= JArrow { jOp :: JsonOperand }
|
||||
| J2Arrow { jOp :: JsonOperand }
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
-- | Represents the key(`->'key'`) or index(`->'1`::int`), the index is Text
|
||||
-- because we reuse our escaping functions and let pg do the casting with
|
||||
-- '1'::int
|
||||
data JsonOperand
|
||||
= JKey { jVal :: Text }
|
||||
| JIdx { jVal :: Text }
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
-- | Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is:
|
||||
--
|
||||
-- And
|
||||
-- / \
|
||||
-- name.eq.N Or
|
||||
-- / \
|
||||
-- id.eq.1 id.eq.2
|
||||
data LogicTree
|
||||
= Expr Bool LogicOperator [LogicTree]
|
||||
| Stmnt Filter
|
||||
deriving (Eq, Show)
|
||||
|
||||
data LogicOperator
|
||||
= And
|
||||
| Or
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Filter
|
||||
= Filter
|
||||
{ field :: Field
|
||||
, opExpr :: OpExpr
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data OpExpr
|
||||
= OpExpr Bool Operation
|
||||
| NoOpExpr Text
|
||||
deriving (Eq, Show)
|
||||
|
||||
data OpQuantifier = QuantAny | QuantAll
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Operation
|
||||
= Op SimpleOperator SingleVal
|
||||
| OpQuant QuantOperator (Maybe OpQuantifier) SingleVal
|
||||
| In ListVal
|
||||
| Is IsVal
|
||||
| IsDistinctFrom SingleVal
|
||||
| Fts FtsOperator (Maybe Language) SingleVal
|
||||
deriving (Eq, Show)
|
||||
|
||||
type Language = Text
|
||||
|
||||
-- | Represents a single value in a filter, e.g. id=eq.singleval
|
||||
type SingleVal = Text
|
||||
|
||||
-- | Represents a list value in a filter, e.g. id=in.(val1,val2,val3)
|
||||
type ListVal = [Text]
|
||||
|
||||
data IsVal
|
||||
= IsNull
|
||||
| IsNotNull
|
||||
-- Trilean values
|
||||
| IsTriTrue
|
||||
| IsTriFalse
|
||||
| IsTriUnknown
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- Operators that are quantifiable, i.e. they can be used with the any/all modifiers
|
||||
data QuantOperator
|
||||
= OpEqual
|
||||
| OpGreaterThanEqual
|
||||
| OpGreaterThan
|
||||
| OpLessThanEqual
|
||||
| OpLessThan
|
||||
| OpLike
|
||||
| OpILike
|
||||
| OpMatch
|
||||
| OpIMatch
|
||||
deriving (Eq, Show)
|
||||
|
||||
data SimpleOperator
|
||||
= OpNotEqual
|
||||
| OpContains
|
||||
| OpContained
|
||||
| OpOverlap
|
||||
| OpStrictlyLeft
|
||||
| OpStrictlyRight
|
||||
| OpNotExtendsRight
|
||||
| OpNotExtendsLeft
|
||||
| OpAdjacent
|
||||
deriving (Eq, Show)
|
||||
|
||||
--
|
||||
-- | Operators for full text search operators
|
||||
data FtsOperator
|
||||
= FilterFts
|
||||
| FilterFtsPlain
|
||||
| FilterFtsPhrase
|
||||
| FilterFtsWebsearch
|
||||
deriving (Eq, Show)
|
||||
@@ -0,0 +1,337 @@
|
||||
{-|
|
||||
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 LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
module PostgREST.App
|
||||
( postgrest
|
||||
, run
|
||||
) where
|
||||
|
||||
import GHC.Conc (ThreadStatus (..), threadStatus)
|
||||
import GHC.IO.Exception (IOErrorType (..))
|
||||
import GHC.Weak
|
||||
import System.IO.Error (ioeGetErrorType)
|
||||
|
||||
import Control.Monad.Except (liftEither)
|
||||
import Data.Either.Combinators (mapLeft, whenLeft)
|
||||
import Data.IORef (atomicWriteIORef, newIORef,
|
||||
readIORef)
|
||||
import Data.String (IsString (..), String)
|
||||
import Network.Wai.Handler.Warp (defaultSettings, setBeforeMainLoop,
|
||||
setHost, setOnException, setPort,
|
||||
setServerName)
|
||||
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Network.Wai as Wai
|
||||
import qualified Network.Wai.Handler.Warp as Warp
|
||||
import qualified Network.Wai.Header as WaiHeader
|
||||
|
||||
import qualified PostgREST.Admin as Admin
|
||||
import qualified PostgREST.ApiRequest as ApiRequest
|
||||
import qualified PostgREST.AppState as AppState
|
||||
import qualified PostgREST.Auth as Auth
|
||||
import qualified PostgREST.Cors as Cors
|
||||
import qualified PostgREST.Error as Error
|
||||
import qualified PostgREST.Listener as Listener
|
||||
import qualified PostgREST.MainTx as MainTx
|
||||
import qualified PostgREST.Plan as Plan
|
||||
import qualified PostgREST.Query as Query
|
||||
import qualified PostgREST.Response as Response
|
||||
import qualified PostgREST.Unix as Unix (installSignalHandlers)
|
||||
|
||||
import PostgREST.ApiRequest (ApiRequest (..))
|
||||
import PostgREST.AppState (AppState)
|
||||
import PostgREST.Auth.Types (AuthResult (..))
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.Error (Error)
|
||||
import PostgREST.Network (resolveSocketToAddress)
|
||||
import PostgREST.Observation (Observation (..))
|
||||
import PostgREST.Response.Performance (ServerTiming (..),
|
||||
serverTimingHeader)
|
||||
import PostgREST.SchemaCache (SchemaCache (..))
|
||||
import PostgREST.TimeIt (timeItT)
|
||||
import PostgREST.Version (docsVersion, prettyVersion)
|
||||
|
||||
import Control.Monad.Writer
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.List as L
|
||||
import Data.Streaming.Network (bindPortTCP)
|
||||
import qualified Data.Text as T
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Network.HTTP.Types.Header (hVary, hWarning)
|
||||
import qualified Network.Socket as NS
|
||||
import PostgREST.Unix (createAndBindDomainSocket)
|
||||
import System.Posix.Types (FileMode)
|
||||
|
||||
import Protolude hiding (Handler)
|
||||
import System.Directory (doesPathExist)
|
||||
|
||||
run :: AppState -> Weak ThreadId -> IO ()
|
||||
run appState mainThreadIdRef = do
|
||||
conf <- AppState.getConfig appState
|
||||
|
||||
mainSocketRef <- newIORef Nothing
|
||||
let setMainSocketRef = atomicWriteIORef mainSocketRef . Just
|
||||
clearMainSocketRef = atomicWriteIORef mainSocketRef Nothing
|
||||
|
||||
bracket (initAdminServerSocket conf) ensureSocketClosed $ \adminSocket -> do
|
||||
|
||||
let closeSockets = do
|
||||
ensureSocketClosed adminSocket
|
||||
ensureSocketClosed =<< readIORef mainSocketRef
|
||||
Unix.installSignalHandlers observer closeSockets (AppState.schemaCacheLoader appState) (AppState.readInDbConfig False appState)
|
||||
|
||||
Admin.runAdmin appState adminSocket (checkMainAppLive (readIORef mainSocketRef) mainThreadIdRef) (serverSettings conf)
|
||||
|
||||
Listener.runListener appState
|
||||
|
||||
-- Kick off and wait for the initial SchemaCache load before creating the
|
||||
-- main API socket.
|
||||
AppState.schemaCacheLoader appState
|
||||
AppState.waitForSchemaCacheInit appState
|
||||
|
||||
bracket (initServerSocket conf) NS.close $ \mainSocket -> do
|
||||
|
||||
let app = postgrest appState (AppState.schemaCacheLoader appState)
|
||||
|
||||
address <- resolveSocketToAddress mainSocket
|
||||
|
||||
let
|
||||
appServerSettings = serverSettings conf
|
||||
& setPort (configServerPort conf)
|
||||
& setOnException onWarpException
|
||||
& setBeforeMainLoop (setMainSocketRef mainSocket *> observer (AppServerAddressObs address))
|
||||
|
||||
Warp.runSettingsSocket appServerSettings mainSocket app
|
||||
`finally` clearMainSocketRef
|
||||
where
|
||||
observer = AppState.getObserver appState
|
||||
|
||||
ensureSocketClosed = foldMap NS.close
|
||||
|
||||
onWarpException :: Maybe Wai.Request -> SomeException -> IO ()
|
||||
onWarpException _ ex =
|
||||
when (shouldDisplayException ex) $
|
||||
observer $ WarpServerObs $ show ex
|
||||
|
||||
-- Similar to wai defaultShouldDisplayException in
|
||||
-- https://github.com/yesodweb/wai//blob/8c3882c60f6abe043889fc20c7efd3fa9747fa4a/warp/Network/Wai/Handler/Warp/Settings.hs#L251-L258
|
||||
-- but without omitting AsyncException since it's important to log for ThreadKilled, StackOverflow and other cases.
|
||||
-- We want to reuse this to avoid flooding the logs for some transient failure cases.
|
||||
shouldDisplayException :: SomeException -> Bool
|
||||
shouldDisplayException se
|
||||
| Just (_ :: Warp.InvalidRequest) <- fromException se = False
|
||||
| Just (ioeGetErrorType -> et) <- fromException se, et == ResourceVanished || et == InvalidArgument = False
|
||||
| otherwise = True
|
||||
|
||||
serverSettings :: AppConfig -> Warp.Settings
|
||||
serverSettings AppConfig{..} =
|
||||
defaultSettings
|
||||
& setHost (fromString $ toS configServerHost)
|
||||
& setServerName ("postgrest/" <> prettyVersion)
|
||||
|
||||
-- | PostgREST application
|
||||
postgrest :: AppState.AppState -> IO () -> Wai.Application
|
||||
postgrest appState connWorker =
|
||||
traceHeaderMiddleware appState .
|
||||
Cors.middleware appState $
|
||||
\req respond -> do
|
||||
appConf@AppConfig{..} <- AppState.getConfig appState -- the config must be read again because it can reload
|
||||
maybeSchemaCache <- AppState.getSchemaCache appState
|
||||
|
||||
let handleError = fmap (either (Error.errorResponseFor configClientErrorVerbosity) identity)
|
||||
|
||||
-- writer to save authRole (uses `tell` for this and `getLast` to obtain it)
|
||||
-- has to be before runExceptT to make sure role is not lost on error
|
||||
(response, authRole) <- runWriterT . handleError . runExceptT $ do
|
||||
(jwtTime, authResult@AuthResult{..}) <- withTiming appConf $
|
||||
Auth.getAuthResult appState $ ApiRequest.userBearerAuth req
|
||||
|
||||
tell $ pure authRole
|
||||
|
||||
postgrestResponse appState appConf maybeSchemaCache jwtTime authResult req
|
||||
|
||||
AppState.getObserver appState $ genResponseObs (getLast authRole) req response
|
||||
|
||||
-- Launch the connWorker when the connection is down. The postgrest
|
||||
-- function can respond successfully (with a stale schema cache) before
|
||||
-- the connWorker is done. However, when there's an empty schema cache
|
||||
-- postgrest responds with the error `PGRST002`; this means that the schema
|
||||
-- cache is still loading, so we don't launch the connWorker here because
|
||||
-- it would duplicate the loading process, e.g. https://github.com/PostgREST/postgrest/issues/3704
|
||||
-- TODO: this process may be unnecessary when the Listener is enabled. Revisit once https://github.com/PostgREST/postgrest/issues/1766 is done
|
||||
when (isServiceUnavailable response && isJust maybeSchemaCache) connWorker
|
||||
delay <- AppState.getNextDelay appState
|
||||
respond $ addRetryHint delay response
|
||||
where
|
||||
-- TODO WaiHeader.contentLength does a lookup everytime, see: https://hackage.haskell.org/package/wai-extra-3.1.17/docs/src/Network.Wai.Header.html#contentLength
|
||||
-- It might be possible to gain some perf by returning the response length from `postgrestResponse`. We calculate the length manually on Response.hs.
|
||||
genResponseObs :: Maybe ByteString -> Wai.Request -> Wai.Response -> Observation
|
||||
genResponseObs user req resp =
|
||||
ResponseObs user req (Wai.responseStatus resp) (WaiHeader.contentLength $ Wai.responseHeaders resp)
|
||||
|
||||
postgrestResponse
|
||||
:: (MonadError Error m, MonadIO m)
|
||||
=> AppState.AppState
|
||||
-> AppConfig
|
||||
-> Maybe SchemaCache
|
||||
-> Maybe Double
|
||||
-> AuthResult
|
||||
-> Wai.Request
|
||||
-> m Wai.Response
|
||||
postgrestResponse appState conf@AppConfig{..} maybeSchemaCache jwtTime authResult@AuthResult{..} req = do
|
||||
let observer = AppState.getObserver appState
|
||||
|
||||
sCache <-
|
||||
case maybeSchemaCache of
|
||||
Just sCache ->
|
||||
return sCache
|
||||
Nothing -> do
|
||||
liftIO $ observer SchemaCacheEmptyObs
|
||||
throwError Error.NoSchemaCacheError
|
||||
|
||||
let prefs = ApiRequest.userPreferences conf req (dbTimezones sCache)
|
||||
|
||||
body <- liftIO $ Wai.strictRequestBody req
|
||||
|
||||
(parseTime, apiReq@ApiRequest{..}) <- withTiming conf $ liftEither . mapLeft Error.ApiRequestErr $ ApiRequest.userApiRequest conf prefs req body
|
||||
(planTime, plan) <- withTiming conf $ liftEither $ Plan.actionPlan iAction conf apiReq sCache
|
||||
|
||||
let warnings = Plan.legacyWarnings plan
|
||||
legacyWarnMsg = "Embedded resource was referenced by relation name even though it has an alias. This is deprecated and will stop working in a future release."
|
||||
legacyWarnHint = let replacement (relName, alias) = "`" <> relName <> "` to `" <> alias <> "`" in T.intercalate ", " (replacement <$> warnings)
|
||||
shouldShowWarnings = configUrlUseLegacyTargetNames && not (null warnings)
|
||||
|
||||
liftIO $ when shouldShowWarnings $
|
||||
observer $ LegacyTargetNameWarningObs (legacyWarnMsg, legacyWarnHint) iMethod (iPath <> Wai.rawQueryString req) -- TODO maybe store rawQueryString in ApiRequest for consistency
|
||||
|
||||
let mainQ = Query.mainQuery plan conf apiReq authResult configDbPreRequest
|
||||
tx = MainTx.mainTx mainQ conf authResult apiReq plan sCache
|
||||
obsQuery s = when configLogQuery $ observer $ QueryObs mainQ s
|
||||
|
||||
(txTime, txResult) <- withTiming conf $ do
|
||||
case tx of
|
||||
MainTx.NoDbTx r -> pure r
|
||||
MainTx.DbTx dbSession -> do
|
||||
dbRes <- liftIO $ AppState.usePool appState dbSession
|
||||
let eitherResp = join $ mapLeft (Error.PgErr . Error.PgError (Just authRole /= configDbAnonRole)) dbRes
|
||||
|
||||
-- TODO: we use obsQuery twice, one here and one below because in case of an error with the usePool above, the request will finish here and return an error message.
|
||||
-- This is because of a combination of ExceptT + our Error module which has Wai.responseLBS.
|
||||
-- This needs refactoring so only the below obsQuery is used.
|
||||
liftIO $ whenLeft eitherResp $ obsQuery . Error.status
|
||||
liftEither eitherResp
|
||||
|
||||
(respTime, resp) <- withTiming conf $ do
|
||||
let response = Response.actionResponse txResult apiReq (T.decodeUtf8 prettyVersion, docsVersion) conf sCache
|
||||
status' = either Error.status Response.pgrstStatus response
|
||||
|
||||
-- TODO: see above obsQuery, only this obsQuery should remain after refactoring (because the QueryObs depends on the status)
|
||||
liftIO $ obsQuery status'
|
||||
liftEither response
|
||||
|
||||
let warnHdrMsgs = if shouldShowWarnings then Just (legacyWarnMsg, legacyWarnHint) else Nothing
|
||||
|
||||
return $ toWaiResponse (ServerTiming jwtTime parseTime planTime txTime respTime) warnHdrMsgs resp
|
||||
|
||||
where
|
||||
toWaiResponse :: ServerTiming -> Maybe (Text, Text) -> Response.PgrstResponse -> Wai.Response
|
||||
toWaiResponse timing warnMsgs (Response.PgrstResponse st hdrs bod) =
|
||||
Wai.responseLBS st (hdrs ++ serverTimingHeaders timing ++ warningHeaders warnMsgs ++ [varyHeader | not $ varyHeaderPresent hdrs]) bod
|
||||
|
||||
serverTimingHeaders :: ServerTiming -> [HTTP.Header]
|
||||
serverTimingHeaders timing = [serverTimingHeader timing | configServerTimingEnabled]
|
||||
|
||||
varyHeader :: HTTP.Header
|
||||
varyHeader = (hVary, "Accept, Prefer, Range")
|
||||
|
||||
varyHeaderPresent :: [HTTP.Header] -> Bool
|
||||
varyHeaderPresent = any (\(h, _v) -> h == hVary)
|
||||
|
||||
warningHeaders :: Maybe (Text, Text) -> [HTTP.Header]
|
||||
warningHeaders Nothing = []
|
||||
warningHeaders (Just (msg, hint)) =
|
||||
let warnMsg = msg <> " Update " <> hint <> " in query string filters, orders or limits."
|
||||
pgrstVer = "PostgRESTv" <> BS.filter (/= ' ') prettyVersion
|
||||
in
|
||||
[(hWarning, "299 " <> pgrstVer <> " \"" <> encodeUtf8 warnMsg <> "\"")]
|
||||
|
||||
withTiming :: (MonadError e m, MonadIO m) => AppConfig -> m a -> m (Maybe Double, a)
|
||||
withTiming AppConfig{configServerTimingEnabled} f = if configServerTimingEnabled
|
||||
then do
|
||||
(t, r) <- timeItT f
|
||||
pure (Just t, r)
|
||||
else do
|
||||
r <- f
|
||||
pure (Nothing, r)
|
||||
|
||||
traceHeaderMiddleware :: AppState -> Wai.Middleware
|
||||
traceHeaderMiddleware appState app req respond = do
|
||||
conf <- AppState.getConfig appState
|
||||
|
||||
case configServerTraceHeader conf of
|
||||
Nothing -> app req respond
|
||||
Just hdr ->
|
||||
let hdrVal = L.lookup hdr $ Wai.requestHeaders req in
|
||||
app req (respond . Wai.mapResponseHeaders ([(hdr, fromMaybe mempty hdrVal)] ++))
|
||||
|
||||
addRetryHint :: Int -> Wai.Response -> Wai.Response
|
||||
addRetryHint delay response = do
|
||||
let h = ("Retry-After", BS.pack $ show delay)
|
||||
Wai.mapResponseHeaders (\hs -> if isServiceUnavailable response then h:hs else hs) response
|
||||
|
||||
isServiceUnavailable :: Wai.Response -> Bool
|
||||
isServiceUnavailable response = Wai.responseStatus response == HTTP.status503
|
||||
|
||||
initSocket :: (Applicative f, Traversable f) => Maybe String -> FileMode -> Text -> f Int -> IO (f NS.Socket)
|
||||
initSocket unixSocket unixSocketMode tcpHost tcpPort =
|
||||
maybe initTCPSocket initDomainSocket unixSocket
|
||||
where
|
||||
initTCPSocket = traverse (`bindPortTCP` (fromString $ T.unpack tcpHost)) tcpPort
|
||||
-- I'm not using `streaming-commons`' bindPath function here because it's not defined for Windows,
|
||||
-- but we need to have runtime error if we try to use it in Windows, not compile time error
|
||||
initDomainSocket = fmap pure . (`createAndBindDomainSocket` unixSocketMode)
|
||||
|
||||
initServerSocket :: AppConfig -> IO NS.Socket
|
||||
initServerSocket AppConfig{..} =
|
||||
runIdentity <$> initSocket
|
||||
configServerUnixSocket configServerUnixSocketMode
|
||||
configServerHost (pure configServerPort)
|
||||
|
||||
initAdminServerSocket :: AppConfig -> IO (Maybe NS.Socket)
|
||||
initAdminServerSocket AppConfig{..} =
|
||||
initSocket
|
||||
configAdminServerUnixSocket configAdminServerUnixSocketMode
|
||||
configAdminServerHost configAdminServerPort
|
||||
|
||||
checkMainAppLive :: IO (Maybe NS.Socket) -> Weak ThreadId -> IO Bool
|
||||
checkMainAppLive getMainSocket mainThreadIdRef =
|
||||
handle (\(_ :: IOException) -> pure False) $
|
||||
checkMainThread <&&> checkSocket
|
||||
where
|
||||
checkSocket = getMainSocket >>=
|
||||
maybe (pure False)
|
||||
(NS.getSocketName >=> \case
|
||||
-- in case of unix socket, check if it still exists
|
||||
NS.SockAddrUnix fp -> doesPathExist fp
|
||||
_ -> pure True)
|
||||
checkMainThread = deRefWeak mainThreadIdRef >>=
|
||||
maybe (pure False)
|
||||
(fmap isRunning . threadStatus)
|
||||
isRunning = \case
|
||||
ThreadRunning -> True
|
||||
ThreadBlocked _ -> True
|
||||
_ -> False
|
||||
@@ -0,0 +1,432 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
|
||||
module PostgREST.AppState
|
||||
( AppState
|
||||
, destroy
|
||||
, getConfig
|
||||
, getSchemaCache
|
||||
, getPgVersion
|
||||
, getNextDelay
|
||||
, getTime
|
||||
, getJwtCacheState
|
||||
, init
|
||||
, initWithPool
|
||||
, killApp
|
||||
, putConfig -- For tests TODO refactoring
|
||||
, putSchemaCache
|
||||
, putPgVersion
|
||||
, putIsListenerOn
|
||||
, usePool
|
||||
, readInDbConfig
|
||||
, schemaCacheLoader
|
||||
, getObserver
|
||||
, isLoaded
|
||||
, isPending
|
||||
, waitForSchemaCacheInit
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Either.Combinators (whenLeft)
|
||||
import qualified Hasql.Pool as SQL
|
||||
import qualified Hasql.Pool.Config as SQL
|
||||
import qualified Hasql.Session as SQL
|
||||
import qualified Hasql.Transaction.Sessions as SQL
|
||||
import qualified Network.HTTP.Types.Status as HTTP
|
||||
import qualified PostgREST.Auth.JwtCache as JwtCache
|
||||
import qualified PostgREST.Error as Error
|
||||
import qualified PostgREST.Logger as Logger
|
||||
import qualified PostgREST.Metrics as Metrics
|
||||
import PostgREST.Observation
|
||||
import PostgREST.TimeIt (timeItT)
|
||||
import PostgREST.Version (prettyVersion)
|
||||
|
||||
import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate,
|
||||
updateAction)
|
||||
import Control.Retry (RetryPolicy, RetryStatus (..), capDelay,
|
||||
exponentialBackoff, retrying,
|
||||
rsPreviousDelay)
|
||||
import Data.IORef (IORef, atomicWriteIORef, newIORef,
|
||||
readIORef)
|
||||
import Data.Time.Clock (UTCTime, getCurrentTime)
|
||||
|
||||
import Control.Concurrent.STM (TMVar, newEmptyTMVarIO,
|
||||
putTMVar, readTMVar,
|
||||
tryReadTMVar, tryTakeTMVar)
|
||||
import PostgREST.Auth.JwtCache (JwtCacheState, update)
|
||||
import PostgREST.Config (AppConfig (..),
|
||||
readAppConfig,
|
||||
toConnectionSettings)
|
||||
import PostgREST.Config.Database (queryDbSettings,
|
||||
queryPgVersion,
|
||||
queryRoleSettings)
|
||||
import PostgREST.Config.PgVersion (PgVersion (..),
|
||||
minimumPgVersion)
|
||||
import PostgREST.Debounce (makeDebouncer)
|
||||
import PostgREST.SchemaCache (SchemaCache (..),
|
||||
querySchemaCache,
|
||||
showSummary)
|
||||
import PostgREST.SchemaCache.Identifiers (quoteQi)
|
||||
|
||||
import Protolude
|
||||
|
||||
data AppState = AppState
|
||||
-- | Database connection pool
|
||||
{ statePool :: SQL.Pool
|
||||
-- | Database server version
|
||||
, statePgVersion :: IORef PgVersion
|
||||
-- | Schema cache
|
||||
, stateSchemaCache :: IORef (Maybe SchemaCache)
|
||||
-- | The schema cache status
|
||||
, stateSCacheStatus :: SchemaCacheStatus
|
||||
-- | State of the LISTEN channel
|
||||
, stateIsListenerOn :: IORef Bool
|
||||
-- | starts the connection worker with a debounce
|
||||
, debouncedSCacheLoader :: IO ()
|
||||
-- | Config that can change at runtime
|
||||
, stateConf :: IORef AppConfig
|
||||
-- | Time used for verifying JWT expiration
|
||||
, stateGetTime :: IO UTCTime
|
||||
-- | Used for killing the main thread in case a subthread fails
|
||||
, stateKillApp :: IO ()
|
||||
-- | Keeps track of the next delay for db connection retry
|
||||
, stateNextDelay :: IORef Int
|
||||
-- | Observation handler
|
||||
, stateObserver :: ObservationHandler
|
||||
-- | JWT Cache
|
||||
, stateJwtCache :: JwtCache.JwtCacheState
|
||||
, stateLogger :: Logger.LoggerState
|
||||
, stateMetrics :: Metrics.MetricsState
|
||||
}
|
||||
|
||||
-- | Schema cache status.
|
||||
-- Empty means initial loading on startup, False means pending and True means loaded.
|
||||
-- "Initial" state is needed so that we can wait with application socket listening
|
||||
-- until after initial schema cache querying.
|
||||
newtype SchemaCacheStatus = SchemaCacheStatus
|
||||
{ getSCStatusTMVar :: TMVar Bool
|
||||
}
|
||||
|
||||
init :: AppConfig -> IO () -> IO AppState
|
||||
init conf@AppConfig{configLogLevel, configDbPoolSize} appKiller = do
|
||||
loggerState <- Logger.init
|
||||
metricsState <- Metrics.init configDbPoolSize
|
||||
let observer = liftA2 (>>) (Logger.observationLogger loggerState configLogLevel) (Metrics.observationMetrics metricsState)
|
||||
|
||||
observer $ AppStartObs prettyVersion
|
||||
|
||||
pool <- initPool conf observer
|
||||
initWithPool pool conf loggerState metricsState observer appKiller
|
||||
|
||||
initWithPool :: SQL.Pool -> AppConfig -> Logger.LoggerState -> Metrics.MetricsState -> ObservationHandler -> IO () -> IO AppState
|
||||
initWithPool pool conf loggerState metricsState observer appKiller = mdo
|
||||
|
||||
appState <- AppState pool
|
||||
<$> newIORef minimumPgVersion -- assume we're in a supported version when starting, this will be corrected on a later step
|
||||
<*> newIORef Nothing
|
||||
<*> newSchemaCacheStatus
|
||||
<*> newIORef False
|
||||
<*> makeDebouncer (retryingSchemaCacheLoad appState *> threadDelay 100000) -- 100ms cooldown
|
||||
<*> newIORef conf
|
||||
<*> mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime }
|
||||
<*> pure appKiller
|
||||
<*> newIORef 0
|
||||
<*> pure observer
|
||||
<*> JwtCache.init conf observer
|
||||
<*> pure loggerState
|
||||
<*> pure metricsState
|
||||
|
||||
return appState
|
||||
|
||||
-- | Destroy the pool on shutdown.
|
||||
-- | Differs from flushPool in not emiting PoolFlushed observation.
|
||||
destroy :: AppState -> IO ()
|
||||
destroy AppState{..} = SQL.release statePool
|
||||
|
||||
initPool :: AppConfig -> ObservationHandler -> IO SQL.Pool
|
||||
initPool cfg@AppConfig{..} observer = do
|
||||
SQL.acquire $ SQL.settings
|
||||
[ SQL.size configDbPoolSize
|
||||
, SQL.acquisitionTimeout $ fromIntegral configDbPoolAcquisitionTimeout
|
||||
, SQL.agingTimeout $ fromIntegral configDbPoolMaxLifetime
|
||||
, SQL.idlenessTimeout $ fromIntegral configDbPoolMaxIdletime
|
||||
, SQL.staticConnectionSettings $ toConnectionSettings identity cfg
|
||||
, SQL.observationHandler $ observer . HasqlPoolObs
|
||||
]
|
||||
|
||||
-- | Run an action with a database connection.
|
||||
usePool :: AppState -> SQL.Session a -> IO (Either SQL.UsageError a)
|
||||
usePool appState@AppState{stateObserver=observer, ..} sess = do
|
||||
observer PoolRequest
|
||||
|
||||
res <- SQL.use statePool sess
|
||||
|
||||
observer PoolRequestFullfilled
|
||||
|
||||
whenLeft res (\case
|
||||
SQL.AcquisitionTimeoutUsageError ->
|
||||
observer PoolAcqTimeoutObs
|
||||
err@(SQL.ConnectionUsageError e) ->
|
||||
let failureMessage = BS.unpack $ fromMaybe mempty e in
|
||||
when (("FATAL: password authentication failed" `isInfixOf` failureMessage) || ("no password supplied" `isInfixOf` failureMessage)) $ do
|
||||
observer $ ExitDBFatalError ServerAuthError err
|
||||
killApp appState
|
||||
err@(SQL.SessionUsageError (SQL.QueryError tpl _ (SQL.ResultError resultErr))) ->
|
||||
handleResultError err tpl resultErr
|
||||
err@(SQL.SessionUsageError (SQL.PipelineError (SQL.ResultError resultErr))) ->
|
||||
-- Passing the empty template will not work for schema cache queries, see TODO further below.
|
||||
handleResultError err mempty resultErr
|
||||
err@(SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ClientError _))) ->
|
||||
-- An error on the client-side, usually indicates problems with connection
|
||||
observer $ QueryErrorCodeHighObs err
|
||||
SQL.SessionUsageError (SQL.PipelineError (SQL.ClientError _)) -> pure ()
|
||||
)
|
||||
|
||||
return res
|
||||
where
|
||||
handleResultError err tpl resultErr = do
|
||||
case resultErr of
|
||||
SQL.UnexpectedResult{} -> do
|
||||
observer $ ExitDBFatalError ServerPgrstBug err
|
||||
killApp appState
|
||||
SQL.RowError{} -> do
|
||||
observer $ ExitDBFatalError ServerPgrstBug err
|
||||
killApp appState
|
||||
SQL.UnexpectedAmountOfRows{} -> do
|
||||
observer $ ExitDBFatalError ServerPgrstBug err
|
||||
killApp appState
|
||||
-- Check for a syntax error (42601 is the pg code) only for queries that don't have `WITH pgrst_source` as prefix.
|
||||
-- This would mean the error is on our schema cache queries, so we treat it as fatal.
|
||||
-- TODO have a better way to mark this as a schema cache query
|
||||
SQL.ServerError "42601" _ _ _ _ ->
|
||||
unless ("WITH pgrst_source" `BS.isPrefixOf` tpl) $ do
|
||||
observer $ ExitDBFatalError ServerPgrstBug err
|
||||
killApp appState
|
||||
-- Check for a "prepared statement <name> already exists" error (Code 42P05: duplicate_prepared_statement).
|
||||
-- This would mean that a connection pooler in transaction mode is being used
|
||||
-- while prepared statements are enabled in the PostgREST configuration,
|
||||
-- both of which are incompatible with each other.
|
||||
SQL.ServerError "42P05" _ _ _ _ -> do
|
||||
observer $ ExitDBFatalError ServerError42P05 err
|
||||
killApp appState
|
||||
-- Check for a "transaction blocks not allowed in statement pooling mode" error (Code 08P01: protocol_violation).
|
||||
-- This would mean that a connection pooler in statement mode is being used which is not supported in PostgREST.
|
||||
SQL.ServerError "08P01" "transaction blocks not allowed in statement pooling mode" _ _ _ -> do
|
||||
observer $ ExitDBFatalError ServerError08P01 err
|
||||
killApp appState
|
||||
SQL.ServerError{} ->
|
||||
when (Error.status (Error.PgError False err) >= HTTP.status500) $
|
||||
observer $ QueryErrorCodeHighObs err
|
||||
|
||||
-- | Flush the connection pool so that any future use of the pool will
|
||||
-- use connections freshly established after this call.
|
||||
-- | Emits PoolFlushed observation
|
||||
flushPool :: AppState -> IO ()
|
||||
flushPool AppState{..} = do
|
||||
SQL.release statePool
|
||||
stateObserver PoolFlushed
|
||||
|
||||
getPgVersion :: AppState -> IO PgVersion
|
||||
getPgVersion = readIORef . statePgVersion
|
||||
|
||||
putPgVersion :: AppState -> PgVersion -> IO ()
|
||||
putPgVersion = atomicWriteIORef . statePgVersion
|
||||
|
||||
getSchemaCache :: AppState -> IO (Maybe SchemaCache)
|
||||
getSchemaCache = readIORef . stateSchemaCache
|
||||
|
||||
putSchemaCache :: AppState -> Maybe SchemaCache -> IO ()
|
||||
putSchemaCache appState = atomicWriteIORef (stateSchemaCache appState)
|
||||
|
||||
schemaCacheLoader :: AppState -> IO ()
|
||||
schemaCacheLoader = debouncedSCacheLoader
|
||||
|
||||
getNextDelay :: AppState -> IO Int
|
||||
getNextDelay = readIORef . stateNextDelay
|
||||
|
||||
getConfig :: AppState -> IO AppConfig
|
||||
getConfig = readIORef . stateConf
|
||||
|
||||
putConfig :: AppState -> AppConfig -> IO ()
|
||||
putConfig = atomicWriteIORef . stateConf
|
||||
|
||||
getTime :: AppState -> IO UTCTime
|
||||
getTime = stateGetTime
|
||||
|
||||
getJwtCacheState :: AppState -> JwtCacheState
|
||||
getJwtCacheState = stateJwtCache
|
||||
|
||||
killApp :: AppState -> IO ()
|
||||
killApp = stateKillApp
|
||||
|
||||
isConnEstablished :: AppState -> IO Bool
|
||||
isConnEstablished appState = do
|
||||
AppConfig{..} <- getConfig appState
|
||||
if configDbChannelEnabled then -- if the listener is enabled, we can be sure the connection is up
|
||||
readIORef $ stateIsListenerOn appState
|
||||
else -- otherwise the only way to check the connection is to make a query
|
||||
isRight <$> usePool appState (SQL.sql "SELECT 1")
|
||||
|
||||
putIsListenerOn :: AppState -> Bool -> IO ()
|
||||
putIsListenerOn = atomicWriteIORef . stateIsListenerOn
|
||||
|
||||
isLoaded :: AppState -> IO Bool
|
||||
isLoaded x = do
|
||||
scacheLoaded <- isSchemaCacheLoaded x
|
||||
connEstablished <- isConnEstablished x
|
||||
return $ scacheLoaded && connEstablished
|
||||
|
||||
isPending :: AppState -> IO Bool
|
||||
isPending x = do
|
||||
scacheLoaded <- isSchemaCacheLoaded x
|
||||
connEstablished <- isConnEstablished x
|
||||
return $ not scacheLoaded || not connEstablished
|
||||
|
||||
getObserver :: AppState -> ObservationHandler
|
||||
getObserver = stateObserver
|
||||
|
||||
-- | Try to load the schema cache and retry if it fails.
|
||||
--
|
||||
-- This is done by repeatedly: 1) flushing the pool, 2) querying the version and validating that the postgres version is supported by us, and 3) loading the schema cache.
|
||||
-- It's necessary to flush the pool:
|
||||
--
|
||||
-- + Because connections cache the pg catalog(see #2620)
|
||||
-- + For rapid recovery. Otherwise, the pool idle or lifetime timeout would have to be reached for new healthy connections to be acquired.
|
||||
retryingSchemaCacheLoad :: AppState -> IO ()
|
||||
retryingSchemaCacheLoad appState@AppState{stateObserver=observer} =
|
||||
void $ retrying retryPolicy shouldRetry (\RetryStatus{rsIterNumber, rsPreviousDelay} -> do
|
||||
when (rsIterNumber > 0) $ do
|
||||
let delay = fromMaybe 0 rsPreviousDelay `div` oneSecondInUs
|
||||
observer $ ConnectionRetryObs delay
|
||||
|
||||
(,) <$> qPgVersion <*> (qInDbConfig *> qSchemaCache)
|
||||
)
|
||||
where
|
||||
qPgVersion :: IO (Maybe PgVersion)
|
||||
qPgVersion = do
|
||||
AppConfig{..} <- getConfig appState
|
||||
pgVersion <- usePool appState queryPgVersion
|
||||
case pgVersion of
|
||||
Left e -> do
|
||||
observer $ QueryPgVersionError e
|
||||
unless configDbPoolAutomaticRecovery $ do
|
||||
observer ExitDBNoRecoveryObs
|
||||
killApp appState
|
||||
return Nothing
|
||||
Right actualPgVersion ->
|
||||
if actualPgVersion < minimumPgVersion then do
|
||||
observer $ ExitUnsupportedPgVersion actualPgVersion minimumPgVersion
|
||||
killApp appState
|
||||
return Nothing
|
||||
else do
|
||||
observer $ DBConnectedObs $ pgvFullName actualPgVersion
|
||||
observer $ PoolInit configDbPoolSize
|
||||
putPgVersion appState actualPgVersion
|
||||
return $ Just actualPgVersion
|
||||
|
||||
qInDbConfig :: IO ()
|
||||
qInDbConfig = do
|
||||
AppConfig{..} <- getConfig appState
|
||||
when configDbConfig $ readInDbConfig False appState
|
||||
|
||||
qSchemaCache :: IO (Maybe SchemaCache)
|
||||
qSchemaCache = do
|
||||
conf@AppConfig{..} <- getConfig appState
|
||||
(resultTime, result) <-
|
||||
timeItT $ usePool appState (SQL.transactionNoRetry SQL.ReadCommitted SQL.Read $ querySchemaCache conf)
|
||||
case result of
|
||||
Left e -> do
|
||||
markSchemaCachePending appState
|
||||
observer $ SchemaCacheErrorObs configDbSchemas configDbExtraSearchPath e
|
||||
return Nothing
|
||||
|
||||
Right (sCache, queryTimings) -> do
|
||||
-- IMPORTANT: While the pending schema cache state starts from running the above querySchemaCache, only at this stage we block API requests due to the usage of an
|
||||
-- IORef on putSchemaCache. This is why schema cache status is marked as pending here to signal the Admin server (using isPending) that we're on a recovery state.
|
||||
markSchemaCachePending appState
|
||||
putSchemaCache appState $ Just sCache
|
||||
(loadTime, summary) <- timeItT (evaluate $ showSummary sCache)
|
||||
-- Flush the pool after loading the schema cache to reset any stale session cache entries
|
||||
-- We do it after successfully querying the schema cache (because this can fail and during retries we would flush the pool repeatedly unnecessarily)
|
||||
-- and after marking sCacheStatus as pending,
|
||||
flushPool appState
|
||||
observer $ SchemaCacheQueriedObs resultTime queryTimings
|
||||
observer $ SchemaCacheLoadedObs loadTime summary
|
||||
markSchemaCacheLoaded appState
|
||||
return $ Just sCache
|
||||
|
||||
shouldRetry :: RetryStatus -> (Maybe PgVersion, Maybe SchemaCache) -> IO Bool
|
||||
shouldRetry _ (pgVer, sCache) = do
|
||||
AppConfig{..} <- getConfig appState
|
||||
let itShould = configDbPoolAutomaticRecovery && (isNothing pgVer || isNothing sCache)
|
||||
return itShould
|
||||
|
||||
retryPolicy :: RetryPolicy
|
||||
retryPolicy =
|
||||
let delayMicroseconds = 32*oneSecondInUs {-32 seconds-} in
|
||||
capDelay delayMicroseconds $ exponentialBackoff oneSecondInUs
|
||||
|
||||
oneSecondInUs = 1_000_000 -- one second in microseconds
|
||||
|
||||
newSchemaCacheStatus :: IO SchemaCacheStatus
|
||||
newSchemaCacheStatus = SchemaCacheStatus <$> newEmptyTMVarIO
|
||||
|
||||
markSchemaCachePending :: AppState -> IO ()
|
||||
markSchemaCachePending = atomically . liftA2 (*>) tryTakeTMVar (`putTMVar` False) . getSCStatusTMVar . stateSCacheStatus
|
||||
|
||||
markSchemaCacheLoaded :: AppState -> IO ()
|
||||
markSchemaCacheLoaded = atomically . liftA2 (*>) tryTakeTMVar (`putTMVar` True) . getSCStatusTMVar . stateSCacheStatus
|
||||
|
||||
isSchemaCacheLoaded :: AppState -> IO Bool
|
||||
isSchemaCacheLoaded = atomically . (pure . fromMaybe False <=< tryReadTMVar) . getSCStatusTMVar . stateSCacheStatus
|
||||
|
||||
-- | Wait for initial schema cache load to either finish or retry
|
||||
-- | We wait until scStatusTMVar is not empty.
|
||||
waitForSchemaCacheInit :: AppState -> IO ()
|
||||
waitForSchemaCacheInit = atomically . void . readTMVar . getSCStatusTMVar . stateSCacheStatus
|
||||
|
||||
-- | Reads the in-db config and reads the config file again
|
||||
-- | We don't retry reading the in-db config after it fails immediately, because it could have user errors. We just report the error and continue.
|
||||
readInDbConfig :: Bool -> AppState -> IO ()
|
||||
readInDbConfig startingUp appState@AppState{stateObserver=observer} = do
|
||||
conf <- getConfig appState
|
||||
pgVer <- getPgVersion appState
|
||||
dbSettings <-
|
||||
if configDbConfig conf then do
|
||||
qDbSettings <- usePool appState (queryDbSettings (quoteQi <$> configDbPreConfig conf))
|
||||
case qDbSettings of
|
||||
Left e -> do
|
||||
observer $ ConfigReadErrorObs e
|
||||
pure mempty
|
||||
Right x -> pure x
|
||||
else
|
||||
pure mempty
|
||||
(roleSettings, roleIsolationLvl) <-
|
||||
if configDbConfig conf then do
|
||||
rSettings <- usePool appState (queryRoleSettings pgVer)
|
||||
case rSettings of
|
||||
Left e -> do
|
||||
observer $ QueryRoleSettingsErrorObs e
|
||||
pure (mempty, mempty)
|
||||
Right x -> pure x
|
||||
else
|
||||
pure mempty
|
||||
readAppConfig dbSettings (configFilePath conf) (Just $ configDbUri conf) roleSettings roleIsolationLvl >>= \case
|
||||
Left err ->
|
||||
if startingUp then
|
||||
panic err -- die on invalid config if the program is starting up
|
||||
else
|
||||
observer $ ConfigInvalidObs err
|
||||
Right newConf -> do
|
||||
putConfig appState newConf
|
||||
-- After the config has reloaded, jwt-secret might have changed, so
|
||||
-- if it has changed, it is important to invalidate the jwt cache
|
||||
-- entries, because they were cached using the old secret
|
||||
update (getJwtCacheState appState) newConf
|
||||
|
||||
if startingUp then
|
||||
pass
|
||||
else
|
||||
observer ConfigSucceededObs
|
||||
@@ -0,0 +1,34 @@
|
||||
{-|
|
||||
Module : PostgREST.Auth
|
||||
Description : PostgREST authentication functions.
|
||||
|
||||
This module provides functions to deal with the JWT authentication (http://jwt.io).
|
||||
It also can be used to define other authentication functions,
|
||||
in the future Oauth, LDAP and similar integrations can be coded here.
|
||||
|
||||
Authentication should always be implemented in an external service.
|
||||
In the test suite there is an example of simple login function that can be used for a
|
||||
very simple authentication system inside the PostgreSQL database.
|
||||
-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module PostgREST.Auth
|
||||
( getAuthResult )
|
||||
where
|
||||
|
||||
import PostgREST.AppState (AppState, getConfig, getJwtCacheState,
|
||||
getTime)
|
||||
import PostgREST.Auth.Jwt (parseClaims)
|
||||
import PostgREST.Auth.JwtCache (lookupJwtCache)
|
||||
import PostgREST.Auth.Types (AuthResult)
|
||||
import PostgREST.Error (Error)
|
||||
|
||||
import Protolude
|
||||
|
||||
-- | Perform authentication and authorization
|
||||
-- Parse JWT and return AuthResult
|
||||
getAuthResult :: (MonadError Error m, MonadIO m) => AppState -> Maybe ByteString -> m AuthResult
|
||||
getAuthResult appState token = do
|
||||
conf <- liftIO $ getConfig appState
|
||||
time <- liftIO $ getTime appState
|
||||
|
||||
parseClaims conf time =<< lookupJwtCache (getJwtCacheState appState) token
|
||||
@@ -0,0 +1,125 @@
|
||||
{-|
|
||||
Module : PostgREST.Auth.Jwt
|
||||
Description : PostgREST JWT support functions.
|
||||
|
||||
This module provides functions to deal with JWT parsing and validation (http://jwt.io).
|
||||
-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ImpredicativeTypes #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE QuantifiedConstraints #-}
|
||||
|
||||
module PostgREST.Auth.Jwt
|
||||
( parseAndDecodeClaims
|
||||
, parseClaims) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Internal as BS
|
||||
import qualified Data.ByteString.Lazy.Char8 as LBS
|
||||
import qualified Data.Scientific as Sci
|
||||
import qualified Jose.Jwk as JWT
|
||||
import qualified Jose.Jwt as JWT
|
||||
|
||||
import Control.Monad.Except (liftEither)
|
||||
import Data.Either.Combinators (mapLeft)
|
||||
import Data.Text ()
|
||||
import Data.Time.Clock (UTCTime, nominalDiffTimeToSeconds)
|
||||
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
|
||||
|
||||
import PostgREST.Auth.Types (AuthResult (..))
|
||||
import PostgREST.Config (AppConfig (..), audMatchesCfg)
|
||||
import PostgREST.Config.JSPath (evaluateJSPath)
|
||||
import PostgREST.Error (Error (..), JwtClaimsError (..),
|
||||
JwtDecodeError (..), JwtError (..))
|
||||
|
||||
import Data.Aeson ((.:?))
|
||||
import Data.Aeson.Types (parseMaybe)
|
||||
import Jose.Jwk (JwkSet)
|
||||
import Protolude hiding (first)
|
||||
|
||||
parseAndDecodeClaims :: (MonadError Error m, MonadIO m) => JwkSet -> ByteString -> m JSON.Object
|
||||
parseAndDecodeClaims jwkSet token = parseToken jwkSet token >>= decodeClaims
|
||||
|
||||
decodeClaims :: MonadError Error m => JWT.JwtContent -> m JSON.Object
|
||||
decodeClaims (JWT.Jws (_, claims)) = maybe (throwError (JwtErr $ JwtClaimsErr ParsingClaimsFailed)) pure (JSON.decodeStrict claims)
|
||||
decodeClaims _ = throwError $ JwtErr $ JwtDecodeErr UnsupportedTokenType
|
||||
|
||||
validateClaims :: MonadError Error m => UTCTime -> (Text -> Bool) -> JSON.Object -> m ()
|
||||
validateClaims time audMatches claims = liftEither $ maybeToLeft () (fmap JwtErr . getAlt $ JwtClaimsErr <$> checkForErrors time audMatches claims)
|
||||
|
||||
data ValidAud = VAString Text | VAArray [Text] deriving Generic
|
||||
instance JSON.FromJSON ValidAud where
|
||||
parseJSON = JSON.genericParseJSON JSON.defaultOptions { JSON.sumEncoding = JSON.UntaggedValue }
|
||||
|
||||
checkForErrors :: (Applicative m, Monoid (m JwtClaimsError)) => UTCTime -> (Text -> Bool) -> JSON.Object -> m JwtClaimsError
|
||||
checkForErrors time audMatches = mconcat
|
||||
[
|
||||
claim "exp" ExpClaimNotNumber $ inThePast JWTExpired
|
||||
, claim "nbf" NbfClaimNotNumber $ inTheFuture JWTNotYetValid
|
||||
, claim "iat" IatClaimNotNumber $ inTheFuture JWTIssuedAtFuture
|
||||
, claim "aud" AudClaimNotStringOrArray $ checkValue (not . validAud) JWTNotInAudience
|
||||
]
|
||||
where
|
||||
allowedSkewSeconds = 30 :: Int64
|
||||
sciToInt = fromMaybe 0 . Sci.toBoundedInteger
|
||||
toSec = floor . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds
|
||||
now = toSec time
|
||||
|
||||
inTheFuture = checkTime ((now + allowedSkewSeconds) <)
|
||||
inThePast = checkTime ((now - allowedSkewSeconds) >)
|
||||
|
||||
checkTime cond = checkValue (cond. sciToInt)
|
||||
|
||||
validAud = \case
|
||||
(VAString aud) -> audMatches aud
|
||||
(VAArray auds) -> null auds || any audMatches auds
|
||||
|
||||
checkValue invalid msg val =
|
||||
if invalid val then
|
||||
pure msg
|
||||
else
|
||||
mempty
|
||||
|
||||
claim key parseError checkParsed = maybe (pure parseError) (maybe mempty checkParsed) . parseMaybe (.:? key)
|
||||
|
||||
-- | Receives the JWT secret and audience (from config) and a JWT and returns a
|
||||
-- JSON object of JWT claims.
|
||||
parseToken :: (MonadError Error m, MonadIO m) => JwkSet -> ByteString -> m JWT.JwtContent
|
||||
parseToken _ "" = throwError $ JwtErr $ JwtDecodeErr EmptyAuthHeader
|
||||
parseToken secret tkn = do
|
||||
tknWith3Parts <- hasThreeParts tkn
|
||||
eitherContent <- liftIO $ JWT.decode (JWT.keys secret) Nothing tknWith3Parts
|
||||
liftEither . mapLeft (JwtErr . jwtDecodeError) $ eitherContent
|
||||
where
|
||||
hasThreeParts token = case length $ BS.split (BS.c2w '.') token of
|
||||
3 -> pure token
|
||||
n -> throwError $ JwtErr $ JwtDecodeErr $ UnexpectedParts n
|
||||
|
||||
jwtDecodeError :: JWT.JwtError -> JwtError
|
||||
-- The only errors we can get from JWT.decode function are:
|
||||
-- BadAlgorithm
|
||||
-- KeyError
|
||||
-- BadCrypto
|
||||
jwtDecodeError (JWT.KeyError m) = JwtDecodeErr $ KeyError m
|
||||
jwtDecodeError (JWT.BadAlgorithm m) = JwtDecodeErr $ BadAlgorithm m
|
||||
jwtDecodeError JWT.BadCrypto = JwtDecodeErr BadCrypto
|
||||
-- Control never reaches here, the decode function only returns the above three
|
||||
jwtDecodeError _ = JwtDecodeErr UnreachableDecodeError
|
||||
|
||||
parseClaims :: (MonadError Error m, MonadIO m) => AppConfig -> UTCTime -> JSON.Object -> m AuthResult
|
||||
parseClaims cfg@AppConfig{configJwtRoleClaimKey, configDbAnonRole} time mclaims = do
|
||||
validateClaims time (audMatchesCfg cfg) mclaims
|
||||
-- role defaults to anon if not specified in jwt
|
||||
role <- liftEither . maybeToRight (JwtErr JwtTokenRequired) $
|
||||
unquoted <$> evaluateJSPath (Just $ JSON.Object mclaims) configJwtRoleClaimKey <|> configDbAnonRole
|
||||
pure AuthResult
|
||||
{ authClaims = mclaims
|
||||
, authRole = role
|
||||
}
|
||||
where
|
||||
unquoted :: JSON.Value -> BS.ByteString
|
||||
unquoted (JSON.String t) = encodeUtf8 t
|
||||
unquoted v = LBS.toStrict $ JSON.encode v
|
||||
@@ -0,0 +1,115 @@
|
||||
{-|
|
||||
Module : PostgREST.Auth.JwtCache
|
||||
Description : PostgREST JWT validation results Cache.
|
||||
|
||||
This module provides functions to deal with the JWT cache.
|
||||
-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module PostgREST.Auth.JwtCache
|
||||
( init
|
||||
, update
|
||||
, JwtCacheState
|
||||
, lookupJwtCache
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
|
||||
import PostgREST.Error (Error (..), JwtError (JwtSecretMissing))
|
||||
|
||||
import Control.Concurrent.STM (newTVarIO, readTVar,
|
||||
writeTVar)
|
||||
import Control.Concurrent.STM.TVar (TVar)
|
||||
import Control.Monad.Error.Class (liftEither)
|
||||
import Data.ByteString hiding (all, init)
|
||||
import Data.IORef (IORef, newIORef,
|
||||
readIORef, writeIORef)
|
||||
import Jose.Jwk (JwkSet)
|
||||
import PostgREST.Auth.Jwt (parseAndDecodeClaims)
|
||||
import PostgREST.Cache.Sieve (alwaysValid)
|
||||
import qualified PostgREST.Cache.Sieve as SC
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.Observation (Observation (JwtCacheEviction, JwtCacheLookup),
|
||||
ObservationHandler)
|
||||
import Protolude
|
||||
|
||||
data JwtCacheState = JwtCacheState ObservationHandler (IORef JwtCache)
|
||||
|
||||
class CacheVariant m v where
|
||||
cached :: (MonadError Error n, MonadIO n) => SC.Cache m ByteString v -> ByteString -> n JSON.Object
|
||||
|
||||
{-|
|
||||
Jwt caching can have three different configurations:
|
||||
* missing JWT Key (no caching and throw error when JWT token present in the request)
|
||||
* JWT cache turned off
|
||||
* JWT cache turned on
|
||||
|
||||
All three options are represented by JwtCache data type.
|
||||
|
||||
Handling of reconfiguration is centralized in this module.
|
||||
-}
|
||||
data JwtCache =
|
||||
JwtNoJwks |
|
||||
JwtNoCache JwkSet |
|
||||
forall m v. CacheVariant m v => JwtCache JwkSet (TVar Int) (SC.Cache m ByteString v)
|
||||
|
||||
instance CacheVariant IO (Either Error JSON.Object) where
|
||||
cached c = liftIO . SC.cached c >=> liftEither
|
||||
|
||||
instance CacheVariant (ExceptT Error IO) JSON.Object where
|
||||
cached c = liftIO . runExceptT . SC.cached c >=> liftEither
|
||||
|
||||
decode :: (MonadError Error m, MonadIO m) => JwtCache -> ByteString -> m JSON.Object
|
||||
decode JwtNoJwks = const $ throwError (JwtErr JwtSecretMissing)
|
||||
decode (JwtNoCache key) = parseAndDecodeClaims key
|
||||
decode (JwtCache _ _ c) = cached c
|
||||
|
||||
-- | Reconfigure JWT caching and update JwtCacheState accordingly
|
||||
update :: JwtCacheState -> AppConfig -> IO ()
|
||||
update (JwtCacheState observationHandler jwtCacheState) config@AppConfig{configJWKS, configJwtCacheMaxEntries} =
|
||||
let reinitialize =
|
||||
newJwtCache config observationHandler
|
||||
>>= writeIORef jwtCacheState
|
||||
in
|
||||
readIORef jwtCacheState >>= \case
|
||||
(JwtCache decodingKey maxSize _) ->
|
||||
if configJWKS /= Just decodingKey || configJwtCacheMaxEntries <= 0 then
|
||||
-- reinitialize if key changed or cache disabled
|
||||
reinitialize
|
||||
else
|
||||
-- max size changed - set it and let the cache shrink itself if necessary
|
||||
atomically $ writeTVar maxSize configJwtCacheMaxEntries
|
||||
|
||||
_ -> reinitialize
|
||||
|
||||
init :: AppConfig -> ObservationHandler -> IO JwtCacheState
|
||||
init config = fmap (<$>) JwtCacheState <*> (newJwtCache config >=> newIORef)
|
||||
|
||||
-- | Initialize JwtCacheState
|
||||
newJwtCache :: AppConfig -> ObservationHandler -> IO JwtCache
|
||||
newJwtCache AppConfig{configJWKS, configJwtCacheMaxEntries} observationHandler = do
|
||||
maybe (pure JwtNoJwks) initCache configJWKS
|
||||
where
|
||||
initCache key = if configJwtCacheMaxEntries <= 0 then pure (JwtNoCache key) else createCache key configJwtCacheMaxEntries
|
||||
|
||||
createCache key maxSize = do
|
||||
maxSizeTVar <- newTVarIO maxSize
|
||||
JwtCache key maxSizeTVar <$>
|
||||
notCachingErrors (readTVar maxSizeTVar) key
|
||||
|
||||
notCachingErrors :: STM Int -> JwkSet -> IO (SC.Cache (ExceptT Error IO) ByteString JSON.Object)
|
||||
notCachingErrors maxSize key = SC.cacheIO (SC.CacheConfig maxSize
|
||||
(parseAndDecodeClaims key)
|
||||
(lift . observationHandler . JwtCacheLookup) -- lookup metrics
|
||||
(const . const $ lift $ observationHandler JwtCacheEviction) -- evictions metrics
|
||||
alwaysValid) -- no invalidation for now
|
||||
|
||||
lookupJwtCache :: (MonadError Error m, MonadIO m) => JwtCacheState -> Maybe ByteString -> m JSON.Object
|
||||
lookupJwtCache (JwtCacheState _ cacheState) k = liftIO (readIORef cacheState) >>= flip (maybe (pure KM.empty)) k . decode
|
||||
@@ -0,0 +1,15 @@
|
||||
module PostgREST.Auth.Types
|
||||
( AuthResult (..) )
|
||||
where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import qualified Data.ByteString as BS
|
||||
|
||||
-- |
|
||||
-- Parse and store result for JWT Claims. Can be accessed in
|
||||
-- db through GUCs (for RLS etc)
|
||||
data AuthResult = AuthResult
|
||||
{ authClaims :: KM.KeyMap JSON.Value
|
||||
, authRole :: BS.ByteString
|
||||
}
|
||||
@@ -0,0 +1,144 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module PostgREST.CLI
|
||||
( main
|
||||
, CLI (..)
|
||||
, Command (..)
|
||||
, readCLIShowHelp
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Hasql.Transaction.Sessions as SQL
|
||||
import qualified Options.Applicative as O
|
||||
|
||||
import PostgREST.AppState (AppState)
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.Observation (Observation (..))
|
||||
import PostgREST.SchemaCache (querySchemaCache)
|
||||
import PostgREST.Version (prettyVersion)
|
||||
|
||||
import qualified PostgREST.App as App
|
||||
import qualified PostgREST.AppState as AppState
|
||||
import qualified PostgREST.Client as Client
|
||||
import qualified PostgREST.Config as Config
|
||||
|
||||
import Protolude
|
||||
|
||||
|
||||
main :: CLI -> IO ()
|
||||
main CLI{cliCommand, cliPath} = do
|
||||
conf <-
|
||||
either panic identity <$> Config.readAppConfig mempty cliPath Nothing mempty mempty
|
||||
case cliCommand of
|
||||
Client adminCmd -> runClientCommand conf adminCmd
|
||||
Run runCmd -> runAppCommand conf runCmd
|
||||
|
||||
-- | Run command using http-client to communicate with an already running postgrest
|
||||
runClientCommand :: AppConfig -> ClientCommand -> IO ()
|
||||
runClientCommand conf CmdReady = Client.ready conf
|
||||
|
||||
-- | Run postgrest with command
|
||||
runAppCommand :: AppConfig -> RunCommand -> IO ()
|
||||
runAppCommand conf@AppConfig{..} runCmd = do
|
||||
mainThreadId <- myThreadId
|
||||
mainThreadIdRef <- mkWeakThreadId mainThreadId
|
||||
-- Per https://github.com/PostgREST/postgrest/issues/268, we want to
|
||||
-- explicitly close the connections to PostgreSQL on shutdown.
|
||||
-- 'AppState.destroy' takes care of that.
|
||||
bracket
|
||||
(AppState.init conf (killThread mainThreadId))
|
||||
AppState.destroy
|
||||
(\appState -> case runCmd of
|
||||
CmdDumpConfig -> do
|
||||
when configDbConfig $ AppState.readInDbConfig True appState
|
||||
putStr . Config.toText =<< AppState.getConfig appState
|
||||
CmdDumpSchema -> do
|
||||
when configDbConfig $ AppState.readInDbConfig True appState
|
||||
putStrLn =<< dumpSchema appState
|
||||
CmdRun -> App.run appState mainThreadIdRef)
|
||||
|
||||
-- | Dump SchemaCache schema to JSON
|
||||
dumpSchema :: AppState -> IO LBS.ByteString
|
||||
dumpSchema appState = do
|
||||
conf@AppConfig{..} <- AppState.getConfig appState
|
||||
result <-
|
||||
AppState.usePool appState (SQL.transactionNoRetry SQL.ReadCommitted SQL.Read $ querySchemaCache conf)
|
||||
case result of
|
||||
Left e -> do
|
||||
let observer = AppState.getObserver appState
|
||||
observer $ SchemaCacheErrorObs configDbSchemas configDbExtraSearchPath e
|
||||
exitFailure
|
||||
Right (sCache, _) -> return $ JSON.encode sCache
|
||||
|
||||
-- | Command line interface options
|
||||
data CLI = CLI
|
||||
{ cliCommand :: Command
|
||||
, cliPath :: Maybe FilePath
|
||||
}
|
||||
|
||||
data Command
|
||||
= Client ClientCommand
|
||||
| Run RunCommand
|
||||
|
||||
data ClientCommand
|
||||
= CmdReady
|
||||
|
||||
data RunCommand
|
||||
= CmdRun
|
||||
| CmdDumpConfig
|
||||
| CmdDumpSchema
|
||||
|
||||
-- | Read command line interface options. Also prints help.
|
||||
readCLIShowHelp :: IO CLI
|
||||
readCLIShowHelp =
|
||||
O.customExecParser prefs opts
|
||||
where
|
||||
prefs = O.prefs $ O.showHelpOnError <> O.showHelpOnEmpty
|
||||
opts = O.info parser $ O.fullDesc <> progDesc
|
||||
parser = O.helper <*> versionFlag <*> exampleParser <*> cliParser
|
||||
|
||||
progDesc =
|
||||
O.progDesc $
|
||||
"PostgREST "
|
||||
<> BS.unpack prettyVersion
|
||||
<> " / create a REST API to an existing Postgres database"
|
||||
|
||||
versionFlag =
|
||||
O.infoOption ("PostgREST " <> BS.unpack prettyVersion) $
|
||||
O.long "version"
|
||||
<> O.short 'v'
|
||||
<> O.help "Show the version information"
|
||||
|
||||
exampleParser =
|
||||
O.infoOption Config.exampleConfigFile $
|
||||
O.long "example"
|
||||
<> O.short 'e'
|
||||
<> O.help "Show an example configuration file"
|
||||
|
||||
cliParser :: O.Parser CLI
|
||||
cliParser =
|
||||
CLI
|
||||
<$> (dumpConfigFlag <|> dumpSchemaFlag <|> readyFlag)
|
||||
<*> O.optional configFileOption
|
||||
|
||||
configFileOption =
|
||||
O.strArgument $
|
||||
O.metavar "FILENAME"
|
||||
<> O.help "Path to configuration file"
|
||||
|
||||
dumpConfigFlag =
|
||||
O.flag (Run CmdRun) (Run CmdDumpConfig) $
|
||||
O.long "dump-config"
|
||||
<> O.help "Dump loaded configuration and exit"
|
||||
|
||||
dumpSchemaFlag =
|
||||
O.flag (Run CmdRun) (Run CmdDumpSchema) $
|
||||
O.long "dump-schema"
|
||||
<> O.help "Dump loaded schema as JSON and exit (for debugging, output structure is unstable)"
|
||||
|
||||
readyFlag =
|
||||
O.flag (Run CmdRun) (Client CmdReady) $
|
||||
O.long "ready"
|
||||
<> O.help "Checks the health of PostgREST by doing a request on the admin server /ready endpoint"
|
||||
@@ -0,0 +1,218 @@
|
||||
{-|
|
||||
Module : PostgREST.Cache.Sieve
|
||||
Description : PostgREST cache implementation based on Sieve algorithm.
|
||||
|
||||
This module provides implementation of a mutable cache on Sieve algorithm.
|
||||
-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module PostgREST.Cache.Sieve (
|
||||
Cache
|
||||
, CacheConfig (..)
|
||||
, Discard (..)
|
||||
, alwaysValid
|
||||
, cache
|
||||
, cacheIO
|
||||
, cached
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad.Extra (whileM)
|
||||
import Data.Some
|
||||
import qualified Focus as F
|
||||
import Protolude hiding (elem, head)
|
||||
import qualified StmHamt.SizedHamt as SH
|
||||
|
||||
data ListNode k v (b :: Bool) = ListNode {
|
||||
nextPtr :: NodePtr k v,
|
||||
prevNextPtrPtr :: NodePtrPtr k v,
|
||||
elem :: NodeElem k v b
|
||||
}
|
||||
|
||||
data NodeElem :: Type -> Type -> Bool -> Type where
|
||||
Head :: {
|
||||
entries :: SH.SizedHamt (HamtEntry k v),
|
||||
finger :: NodePtrPtr k v
|
||||
} -> NodeElem k v False
|
||||
Entry :: Hashable k => {
|
||||
visited :: TVar Bool,
|
||||
ekey :: k,
|
||||
entryValue :: v
|
||||
} -> NodeElem k v True
|
||||
|
||||
type HamtEntry k v = ListNode k v True
|
||||
type AnyNode k v = Some (ListNode k v)
|
||||
type NodePtr k v = TVar (AnyNode k v)
|
||||
type NodePtrPtr k v = TVar (NodePtr k v)
|
||||
|
||||
data Discard m v = Refresh (m ()) | Invalid (m v)
|
||||
|
||||
data Cache m k v = (MonadIO m, Hashable k) => Cache (ListNode k v False) (CacheConfig m k v)
|
||||
|
||||
data CacheConfig m k v = CacheConfig {
|
||||
maxSize :: STM Int,
|
||||
load :: k -> m v,
|
||||
requestListener :: Bool -> m (),
|
||||
evictionListener :: k -> v -> m (),
|
||||
validator :: m (k -> v -> Maybe (Discard m v))
|
||||
}
|
||||
|
||||
alwaysValid :: Applicative m => m (k -> v -> Maybe (Discard m v))
|
||||
alwaysValid = pure (const . const Nothing)
|
||||
|
||||
cacheIO :: (MonadIO m, Hashable k) => CacheConfig m k v -> IO (Cache m k v)
|
||||
cacheIO = atomically . cache
|
||||
|
||||
cache :: (MonadIO m, Hashable k) => CacheConfig m k v -> STM (Cache m k v)
|
||||
cache cacheConfig = mdo
|
||||
tail <- newTVar (Some head)
|
||||
entries <- SH.new
|
||||
finger <- newTVar tail
|
||||
head <- ListNode tail <$> newTVar tail <*> pure Head {..}
|
||||
pure $ Cache head cacheConfig
|
||||
|
||||
cached :: Cache m k v -> k -> m v
|
||||
cached (Cache head@ListNode{prevNextPtrPtr=neck, elem=Head{..}} CacheConfig{..}) k = do
|
||||
checkValid <- validator
|
||||
tryMaybe
|
||||
-- Fast path: lookup value, update stats and return the value if found and valid
|
||||
((liftIO . atomically) (lookup checkValid) >>= notify (requestListener . isJust) >>= validate)
|
||||
-- Slow path: load/calculate value and insert it (if still not found)
|
||||
(do
|
||||
value <- load k
|
||||
whileM (not <$> tryInsert value)
|
||||
pure value)
|
||||
where
|
||||
tryMaybe f notFound = f >>= maybe notFound pure
|
||||
|
||||
notify = ((<$) <*>)
|
||||
|
||||
validate = fmap join . traverse (\case
|
||||
-- valid value
|
||||
(Right v) -> pure $ Just v
|
||||
-- refresh value
|
||||
(Left (Refresh act)) -> act $> Nothing
|
||||
-- discard value and return alt result
|
||||
(Left (Invalid res)) -> Just <$> res)
|
||||
|
||||
lookup checkValid = SH.focus focus (ekey . elem) k entries
|
||||
where
|
||||
focus = F.Focus
|
||||
-- not found
|
||||
(pure (Nothing, F.Leave))
|
||||
-- found
|
||||
-- check entry validity
|
||||
(\e@ListNode{elem=Entry{visited, entryValue}} ->
|
||||
maybe
|
||||
-- entry valid
|
||||
(mark visited True $> (Just $ Right entryValue, F.Leave))
|
||||
-- entry invalid
|
||||
-- remove it
|
||||
((removeEntry e $>) . (, F.Remove) . Just . Left)
|
||||
(checkValid k entryValue)
|
||||
)
|
||||
|
||||
mark t b = whenM ((/= b) <$> readTVar t) (writeTVar t b)
|
||||
|
||||
-- perform a single entry eviction and possibly insertion atomically
|
||||
-- returning False if could not insert
|
||||
-- (either because entry currently pointed by the finger was visited
|
||||
-- or because after this entry eviction the cache is still full)
|
||||
-- so that other threads don't have to wait when visiting entries.
|
||||
-- First check if entry is still not in the cache - this time inside transaction.
|
||||
--
|
||||
-- Execute evictionListener if an entry was evicted
|
||||
tryInsert value = do
|
||||
(result, evicted) <- liftIO . atomically $ do
|
||||
-- Use SH.focus to performa a single lookup instead of 2
|
||||
-- we cannot modify Hamt from inside focus
|
||||
-- so if there is any entry to remove
|
||||
-- we need to delete it after
|
||||
(res, evictedKey) <- SH.focus focus (ekey . elem) k entries
|
||||
case evictedKey of
|
||||
(Just Entry{ekey=entryKey, entryValue}) -> do
|
||||
SH.focus F.delete (ekey . elem) entryKey entries
|
||||
pure (res, evictionListener entryKey entryValue)
|
||||
Nothing -> pure (res, pure ())
|
||||
|
||||
evicted $> result
|
||||
where
|
||||
focus = F.Focus (do
|
||||
(hasSpace, evictedKey) <- evictionStep
|
||||
if hasSpace then do
|
||||
entry <- newLinkedEntry value
|
||||
-- done, maybe evicted, insert entry
|
||||
pure ((True, evictedKey), F.Set entry)
|
||||
else
|
||||
-- not done, maybe evicted, don't modify entries
|
||||
pure ((False, evictedKey), F.Leave))
|
||||
-- Entry found case
|
||||
(\ListNode{elem=Entry{visited}} -> do
|
||||
-- mark as visited
|
||||
mark visited True
|
||||
-- done, no evictions, don't modify entries
|
||||
pure ((True, Nothing), F.Leave))
|
||||
|
||||
-- if the cache is full precoesses a single node
|
||||
-- removing it if it is marked as unvisited
|
||||
-- or clearing visited mark
|
||||
-- returns True if there is space in the cache
|
||||
-- puts evictionListener in state if an entry was evicted
|
||||
evictionStep = do
|
||||
currDiff <- liftA2 (-) (SH.size entries) (max 1 <$> maxSize)
|
||||
if currDiff >= 0 then do
|
||||
-- no space in the cache
|
||||
-- need to evict an entry
|
||||
(nextFinger, evictedKey) <- readTVar finger >>= evict
|
||||
writeTVar finger nextFinger
|
||||
-- return if enough space and evicted key if any
|
||||
pure (isJust evictedKey && currDiff == 0, evictedKey)
|
||||
else
|
||||
-- there is space in the cache
|
||||
pure (True, Nothing)
|
||||
|
||||
evict :: TVar (Some (ListNode k v)) -> STM (NodePtr k v, Maybe (NodeElem k v True))
|
||||
evict = readTVar >=> \case
|
||||
(Some e@ListNode{nextPtr, prevNextPtrPtr, elem=elem@Entry{visited}}) -> do
|
||||
ifM (readTVar visited)
|
||||
|
||||
(writeTVar visited False $> (nextPtr, Nothing))
|
||||
|
||||
(unlinkEntry e *> fmap (, Just elem) (readTVar prevNextPtrPtr))
|
||||
-- skip head
|
||||
(Some ListNode{nextPtr, elem=Head{}}) -> evict nextPtr
|
||||
|
||||
unlinkEntry :: HamtEntry k v -> STM ()
|
||||
unlinkEntry (ListNode{nextPtr, prevNextPtrPtr=currPrev}) = do
|
||||
nextEntry <- readTVar nextPtr
|
||||
withSome nextEntry $ \e -> do
|
||||
prevNextPtr <- readTVar currPrev
|
||||
writeTVar (prevNextPtrPtr e) prevNextPtr
|
||||
writeTVar prevNextPtr nextEntry
|
||||
|
||||
newLinkedEntry v = do
|
||||
oldNeckNextPtr <- readTVar neck
|
||||
newNeckNextPtr <- newTVar (Some head)
|
||||
newNeck <- ListNode newNeckNextPtr <$>
|
||||
newTVar oldNeckNextPtr <*>
|
||||
(Entry <$> newTVar False <*> pure k <*> pure v)
|
||||
-- update pointers
|
||||
writeTVar oldNeckNextPtr (Some newNeck)
|
||||
writeTVar neck newNeckNextPtr
|
||||
-- return HAMT entry
|
||||
pure newNeck
|
||||
|
||||
removeEntry = fmap (*>) unlinkEntry <*> adjustFinger
|
||||
|
||||
adjustFinger ListNode{nextPtr, prevNextPtrPtr} =
|
||||
whenM ((nextPtr ==) <$> readTVar finger) $
|
||||
readTVar prevNextPtrPtr >>= writeTVar finger
|
||||
@@ -0,0 +1,100 @@
|
||||
{-|
|
||||
Module : PostgREST.Client
|
||||
Description : PostgREST HTTP client
|
||||
-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
module PostgREST.Client
|
||||
( ready
|
||||
) where
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Network.HTTP.Client as HC
|
||||
import qualified Network.HTTP.Types.Status as HTTP
|
||||
|
||||
import Network.HTTP.Client (HttpException (..))
|
||||
import System.IO (hFlush)
|
||||
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.Network (isSpecialHostName)
|
||||
|
||||
import Protolude
|
||||
|
||||
data PgrstClientError
|
||||
= NoAdminServer
|
||||
| NoSpecialHostNamesAllowed Text
|
||||
| PostgRESTNotReady Text
|
||||
| HTTPConnectionRefused Text
|
||||
| HTTPExceptionInvalidURL Text
|
||||
|
||||
-- | This is invoked by the CLI "--ready" flag.
|
||||
-- The http-client sends and a request to /ready endpoint
|
||||
-- and exits with success or failure.
|
||||
ready :: AppConfig -> IO ()
|
||||
ready AppConfig{configAdminServerHost, configAdminServerPort} = do
|
||||
|
||||
client <- HC.newManager HC.defaultManagerSettings
|
||||
readyURL <- getURL
|
||||
req <- HC.parseRequest (T.unpack readyURL) `catch` handleHttpException
|
||||
resp <- HC.httpLbs req client `catch` handleHttpException
|
||||
|
||||
let status = HC.responseStatus resp
|
||||
|
||||
if status >= HTTP.status200 && status < HTTP.status300
|
||||
then printAndExitWithSuccess $ "OK: " <> readyURL
|
||||
else printAndExitWithFailure $ clientErrorMsg (PostgRESTNotReady readyURL)
|
||||
where
|
||||
getURL :: IO Text
|
||||
getURL =
|
||||
-- Here, we have three cases:
|
||||
-- 1. If the admin port config is not defined, we exit
|
||||
-- with "no admin server error"
|
||||
-- 2. Otherwise, if admin server is running, then we check if
|
||||
-- postgrest server-host is configured with special hostname like "*4",
|
||||
-- if it is, we fail with "no special hostname allowed with "--ready".
|
||||
-- The reason for this is that we can't know the actual address.
|
||||
-- 3. Finally, if we know the "actual" hostname and the port, then we
|
||||
-- construct the URL and return it.
|
||||
case configAdminServerPort of
|
||||
Nothing -> printAndExitWithFailure $ clientErrorMsg NoAdminServer
|
||||
Just port ->
|
||||
if isSpecialHostName configAdminServerHost
|
||||
then printAndExitWithFailure $ clientErrorMsg (NoSpecialHostNamesAllowed configAdminServerHost)
|
||||
else return $ makeReadyUrl port
|
||||
|
||||
-- NOTE: http-client automatically resolves hostnames
|
||||
makeReadyUrl :: Int -> Text
|
||||
makeReadyUrl p = "http://" <> wrapIfIpv6 configAdminServerHost <> ":" <> (T.pack . show) p <> "/ready"
|
||||
where
|
||||
-- IPv6 needs to wrapped in [], it has ':' as separator
|
||||
wrapIfIpv6 :: Text -> Text
|
||||
wrapIfIpv6 s
|
||||
| T.any (== ':') s = "[" <> s <> "]"
|
||||
| otherwise = s
|
||||
|
||||
-- | Handle HTTP exception for "http-client" requests
|
||||
handleHttpException :: HttpException -> IO a
|
||||
handleHttpException (HttpExceptionRequest req _) = do
|
||||
let url = show (HC.getUri req)
|
||||
printAndExitWithFailure $ clientErrorMsg (HTTPConnectionRefused $ T.pack url)
|
||||
handleHttpException (InvalidUrlException url _) = do
|
||||
printAndExitWithFailure $ clientErrorMsg (HTTPExceptionInvalidURL $ T.pack url)
|
||||
|
||||
-- | Print the message on stdout and exit with success
|
||||
printAndExitWithSuccess :: Text -> IO a
|
||||
printAndExitWithSuccess msg = putStrLn (T.unpack msg) >> hFlush stdout >> exitSuccess
|
||||
|
||||
-- | Print the message on stderr and exit with failure
|
||||
printAndExitWithFailure :: Text -> IO a
|
||||
printAndExitWithFailure msg = hPutStrLn stderr (T.unpack msg) >> hFlush stderr >> exitWith (ExitFailure 1)
|
||||
|
||||
-- | Pgrst client error to error message
|
||||
clientErrorMsg :: PgrstClientError -> Text
|
||||
clientErrorMsg err = "ERROR: " <>
|
||||
case err of
|
||||
NoAdminServer -> "Admin server is not running. Please check admin-server-port config."
|
||||
NoSpecialHostNamesAllowed host ->
|
||||
"The `--ready` flag cannot be used when server-host is configured as \"" <> host <> "\". "
|
||||
<> "Please update your server-host config to \"localhost\"."
|
||||
PostgRESTNotReady url -> url
|
||||
HTTPConnectionRefused url -> "connection refused to " <> url
|
||||
HTTPExceptionInvalidURL url -> "invalid url - " <> url
|
||||
@@ -0,0 +1,806 @@
|
||||
{-|
|
||||
Module : PostgREST.Config
|
||||
Description : Manages PostgREST configuration type and parser.
|
||||
|
||||
-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module PostgREST.Config
|
||||
( AppConfig (..)
|
||||
, Environment
|
||||
, JSPath
|
||||
, defaultRoleJSPathKey
|
||||
, LogLevel(..)
|
||||
, OpenAPIMode(..)
|
||||
, Proxy(..)
|
||||
, toText
|
||||
, isMalformedProxyUri
|
||||
, readAppConfig
|
||||
, readPGRSTEnvironment
|
||||
, toURI
|
||||
, parseSecret
|
||||
, addFallbackAppName
|
||||
, addTargetSessionAttrs
|
||||
, toConnectionSettings
|
||||
, exampleConfigFile
|
||||
, audMatchesCfg
|
||||
, Verbosity (..)
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Configurator as C
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.String as S
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Hasql.Connection.Setting as SQL
|
||||
import qualified Hasql.Connection.Setting.Connection as SQL
|
||||
import qualified Jose.Jwa as JWT
|
||||
import qualified Jose.Jwk as JWT
|
||||
|
||||
import Control.Monad (fail)
|
||||
import Data.Either.Combinators (mapLeft)
|
||||
import Data.List (lookup)
|
||||
import Data.List.NonEmpty (fromList, toList)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Scientific (floatingOrInteger)
|
||||
import Jose.Jwk (Jwk, JwkSet)
|
||||
import Network.URI (escapeURIString, isURI,
|
||||
isUnescapedInURIComponent)
|
||||
import Numeric (readOct, showOct)
|
||||
import System.Environment (getEnvironment)
|
||||
import System.Posix.Types (FileMode)
|
||||
|
||||
import PostgREST.Config.Database (RoleIsolationLvl,
|
||||
RoleSettings)
|
||||
import PostgREST.Config.JSPath (JSPath (..),
|
||||
defaultRoleJSPathKey,
|
||||
dumpJSPath, pRoleClaimKey)
|
||||
import PostgREST.Config.Proxy (Proxy (..),
|
||||
isMalformedProxyUri, toURI)
|
||||
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..),
|
||||
toQi)
|
||||
|
||||
import PostgREST.Version (prettyVersion)
|
||||
import Protolude hiding (Proxy, toList)
|
||||
|
||||
audMatchesCfg :: AppConfig -> Text -> Bool
|
||||
audMatchesCfg = maybe (const True) (==) . configJwtAudience
|
||||
|
||||
data AppConfig = AppConfig
|
||||
{ configAppSettings :: [(Text, Text)]
|
||||
, configClientErrorVerbosity :: Verbosity
|
||||
, configDbAggregates :: Bool
|
||||
, configDbAnonRole :: Maybe BS.ByteString
|
||||
, configDbChannel :: Text
|
||||
, configDbChannelEnabled :: Bool
|
||||
, configDbExtraSearchPath :: [Text]
|
||||
, configDbHoistedTxSettings :: [Text]
|
||||
, configDbMaxRows :: Maybe Integer
|
||||
, configDbPlanEnabled :: Bool
|
||||
, configDbPoolSize :: Int
|
||||
, configDbPoolAcquisitionTimeout :: Int
|
||||
, configDbPoolMaxLifetime :: Int
|
||||
, configDbPoolMaxIdletime :: Int
|
||||
, configDbPoolAutomaticRecovery :: Bool
|
||||
, configDbPreRequest :: Maybe QualifiedIdentifier
|
||||
, configDbPreparedStatements :: Bool
|
||||
, configDbRootSpec :: Maybe QualifiedIdentifier
|
||||
, configDbSchemas :: NonEmpty Text
|
||||
, configDbConfig :: Bool
|
||||
, configDbPreConfig :: Maybe QualifiedIdentifier
|
||||
, configDbTimezoneEnabled :: Bool
|
||||
, configDbTxAllowOverride :: Bool
|
||||
, configDbTxRollbackAll :: Bool
|
||||
, configDbUri :: Text
|
||||
, configFilePath :: Maybe FilePath
|
||||
, configJWKS :: Maybe JwkSet
|
||||
, configJwtAudience :: Maybe Text
|
||||
, configJwtRoleClaimKey :: JSPath
|
||||
, configJwtSecret :: Maybe BS.ByteString
|
||||
, configJwtSecretIsBase64 :: Bool
|
||||
, configJwtCacheMaxEntries :: Int
|
||||
, configLogLevel :: LogLevel
|
||||
, configLogQuery :: Bool
|
||||
, configOpenApiMode :: OpenAPIMode
|
||||
, configOpenApiSecurityActive :: Bool
|
||||
, configOpenApiServerProxyUri :: Maybe Text
|
||||
, configServerCorsAllowedOrigins :: [Text]
|
||||
, configServerHost :: Text
|
||||
, configServerPort :: Int
|
||||
, configServerTraceHeader :: Maybe (CI.CI BS.ByteString)
|
||||
, configServerTimingEnabled :: Bool
|
||||
, configServerUnixSocket :: Maybe FilePath
|
||||
, configServerUnixSocketMode :: FileMode
|
||||
, configUrlUseLegacyTargetNames :: Bool
|
||||
, configAdminServerHost :: Text
|
||||
, configAdminServerPort :: Maybe Int
|
||||
, configAdminServerUnixSocket :: Maybe FilePath
|
||||
, configAdminServerUnixSocketMode :: FileMode
|
||||
, configRoleSettings :: RoleSettings
|
||||
, configRoleIsoLvl :: RoleIsolationLvl
|
||||
, configInternalSCQuerySleepFst :: Maybe Int32
|
||||
, configInternalSCQuerySleepSnd :: Maybe Int32
|
||||
}
|
||||
|
||||
data LogLevel = LogCrit | LogError | LogWarn | LogInfo | LogDebug
|
||||
deriving (Eq, Ord)
|
||||
|
||||
dumpLogLevel :: LogLevel -> Text
|
||||
dumpLogLevel = \case
|
||||
LogCrit -> "crit"
|
||||
LogError -> "error"
|
||||
LogWarn -> "warn"
|
||||
LogInfo -> "info"
|
||||
LogDebug -> "debug"
|
||||
|
||||
data Verbosity
|
||||
= Minimal
|
||||
| Verbose
|
||||
|
||||
dumpClientErrorVerbosity :: Verbosity -> Text
|
||||
dumpClientErrorVerbosity = \case
|
||||
Minimal -> "minimal"
|
||||
Verbose -> "verbose"
|
||||
|
||||
data OpenAPIMode = OAFollowPriv | OAIgnorePriv | OADisabled
|
||||
deriving Eq
|
||||
|
||||
dumpOpenApiMode :: OpenAPIMode -> Text
|
||||
dumpOpenApiMode = \case
|
||||
OAFollowPriv -> "follow-privileges"
|
||||
OAIgnorePriv -> "ignore-privileges"
|
||||
OADisabled -> "disabled"
|
||||
|
||||
-- | Dump the config
|
||||
toText :: AppConfig -> Text
|
||||
toText conf =
|
||||
unlines $ sort $ (\(k, v) -> k <> " = " <> v) <$> pgrstSettings ++ appSettings
|
||||
where
|
||||
-- apply conf to all pgrst settings
|
||||
pgrstSettings = (\(k, v) -> (k, v conf)) <$>
|
||||
[("client-error-verbosity", q . dumpClientErrorVerbosity . configClientErrorVerbosity)
|
||||
,("db-aggregates-enabled", T.toLower . show . configDbAggregates)
|
||||
,("db-anon-role", q . T.decodeUtf8 . fromMaybe "" . configDbAnonRole)
|
||||
,("db-channel", q . configDbChannel)
|
||||
,("db-channel-enabled", T.toLower . show . configDbChannelEnabled)
|
||||
,("db-extra-search-path", q . T.intercalate "," . configDbExtraSearchPath)
|
||||
,("db-hoisted-tx-settings", q . T.intercalate "," . configDbHoistedTxSettings)
|
||||
,("db-max-rows", maybe "\"\"" show . configDbMaxRows)
|
||||
,("db-plan-enabled", T.toLower . show . configDbPlanEnabled)
|
||||
,("db-pool", show . configDbPoolSize)
|
||||
,("db-pool-acquisition-timeout", show . configDbPoolAcquisitionTimeout)
|
||||
,("db-pool-max-lifetime", show . configDbPoolMaxLifetime)
|
||||
,("db-pool-max-idletime", show . configDbPoolMaxIdletime)
|
||||
,("db-pool-automatic-recovery", T.toLower . show . configDbPoolAutomaticRecovery)
|
||||
,("db-pre-request", q . maybe mempty dumpQi . configDbPreRequest)
|
||||
,("db-prepared-statements", T.toLower . show . configDbPreparedStatements)
|
||||
,("db-root-spec", q . maybe mempty dumpQi . configDbRootSpec)
|
||||
,("db-schemas", q . T.intercalate "," . toList . configDbSchemas)
|
||||
,("db-config", T.toLower . show . configDbConfig)
|
||||
,("db-pre-config", q . maybe mempty dumpQi . configDbPreConfig)
|
||||
,("db-timezone-enabled", T.toLower . show . configDbTimezoneEnabled)
|
||||
,("db-tx-end", q . showTxEnd)
|
||||
,("db-uri", q . configDbUri)
|
||||
,("jwt-aud", q . fromMaybe mempty . configJwtAudience)
|
||||
,("jwt-role-claim-key", q . dumpJSPath . configJwtRoleClaimKey)
|
||||
,("jwt-secret", q . T.decodeUtf8 . showJwtSecret)
|
||||
,("jwt-secret-is-base64", T.toLower . show . configJwtSecretIsBase64)
|
||||
,("jwt-cache-max-entries", show . configJwtCacheMaxEntries)
|
||||
,("log-level", q . dumpLogLevel . configLogLevel)
|
||||
,("log-query", T.toLower . show . configLogQuery)
|
||||
,("openapi-mode", q . dumpOpenApiMode . configOpenApiMode)
|
||||
,("openapi-security-active", T.toLower . show . configOpenApiSecurityActive)
|
||||
,("openapi-server-proxy-uri", q . fromMaybe mempty . configOpenApiServerProxyUri)
|
||||
,("server-cors-allowed-origins", q . T.intercalate "," . configServerCorsAllowedOrigins)
|
||||
,("server-host", q . configServerHost)
|
||||
,("server-port", show . configServerPort)
|
||||
,("server-trace-header", q . T.decodeUtf8 . maybe mempty CI.original . configServerTraceHeader)
|
||||
,("server-timing-enabled", T.toLower . show . configServerTimingEnabled)
|
||||
,("server-unix-socket", q . maybe mempty T.pack . configServerUnixSocket)
|
||||
,("server-unix-socket-mode", q . T.pack . showSocketMode)
|
||||
,("url-use-legacy-target-names", T.toLower . show . configUrlUseLegacyTargetNames)
|
||||
,("admin-server-host", q . configAdminServerHost)
|
||||
,("admin-server-port", maybe "\"\"" show . configAdminServerPort)
|
||||
,("admin-server-unix-socket", q . maybe mempty T.pack . configAdminServerUnixSocket)
|
||||
,("admin-server-unix-socket-mode", q . T.pack . showAdminSocketMode)
|
||||
]
|
||||
|
||||
-- quote all app.settings
|
||||
appSettings = second q <$> configAppSettings conf
|
||||
|
||||
-- quote strings and replace " with \"
|
||||
q s = "\"" <> T.replace "\"" "\\\"" s <> "\""
|
||||
|
||||
dumpQi :: QualifiedIdentifier -> Text
|
||||
dumpQi (QualifiedIdentifier s i) =
|
||||
(if T.null s then mempty else s <> ".") <> i
|
||||
|
||||
showTxEnd c = case (configDbTxRollbackAll c, configDbTxAllowOverride c) of
|
||||
( False, False ) -> "commit"
|
||||
( False, True ) -> "commit-allow-override"
|
||||
( True , False ) -> "rollback"
|
||||
( True , True ) -> "rollback-allow-override"
|
||||
showJwtSecret c
|
||||
| configJwtSecretIsBase64 c = B64.encode secret
|
||||
| otherwise = secret
|
||||
where
|
||||
secret = fromMaybe mempty $ configJwtSecret c
|
||||
showSocketMode c = showOct (configServerUnixSocketMode c) mempty
|
||||
showAdminSocketMode c = showOct (configAdminServerUnixSocketMode c) mempty
|
||||
|
||||
-- This class is needed for the polymorphism of overrideFromDbOrEnvironment
|
||||
-- because C.required and C.optional have different signatures
|
||||
class JustIfMaybe a b where
|
||||
justIfMaybe :: a -> b
|
||||
|
||||
instance JustIfMaybe a a where
|
||||
justIfMaybe = identity
|
||||
|
||||
instance JustIfMaybe a (Maybe a) where
|
||||
justIfMaybe = Just
|
||||
|
||||
-- | Reads and parses the config and overrides its parameters from env vars,
|
||||
-- files or db settings.
|
||||
readAppConfig :: [(Text, Text)] -> Maybe FilePath -> Maybe Text -> RoleSettings -> RoleIsolationLvl -> IO (Either Text AppConfig)
|
||||
readAppConfig dbSettings optPath prevDbUri roleSettings roleIsolationLvl = do
|
||||
env <- readPGRSTEnvironment
|
||||
-- if no filename provided, start with an empty map to read config from environment
|
||||
conf <- maybe (return $ Right M.empty) loadConfig optPath
|
||||
|
||||
case C.runParser (parser optPath env dbSettings roleSettings roleIsolationLvl) =<< mapLeft show conf of
|
||||
Left err ->
|
||||
return . Left $ "Error in config " <> err
|
||||
Right parsedConfig ->
|
||||
mapLeft show <$> decodeLoadFiles parsedConfig
|
||||
where
|
||||
-- Both C.ParseError and IOError are shown here
|
||||
loadConfig :: FilePath -> IO (Either SomeException C.Config)
|
||||
loadConfig = try . C.load
|
||||
|
||||
decodeLoadFiles :: AppConfig -> IO (Either IOException AppConfig)
|
||||
decodeLoadFiles parsedConfig = try $
|
||||
decodeJWKS =<<
|
||||
decodeSecret =<<
|
||||
readSecretFile =<<
|
||||
readDbUriFile prevDbUri parsedConfig
|
||||
|
||||
parser :: Maybe FilePath -> Environment -> [(Text, Text)] -> RoleSettings -> RoleIsolationLvl -> C.Parser C.Config AppConfig
|
||||
parser optPath env dbSettings roleSettings roleIsolationLvl =
|
||||
AppConfig
|
||||
<$> parseAppSettings "app.settings"
|
||||
<*> parseErrorVerbosity "client-error-verbosity"
|
||||
<*> (fromMaybe False <$> optBool "db-aggregates-enabled")
|
||||
<*> (fmap encodeUtf8 <$> optString "db-anon-role")
|
||||
<*> (fromMaybe "pgrst" <$> optString "db-channel")
|
||||
<*> (fromMaybe True <$> optBool "db-channel-enabled")
|
||||
<*> (maybe ["public"] splitOnCommasEmptyable <$> optStringEmptyable "db-extra-search-path")
|
||||
<*> (maybe defaultHoistedAllowList splitOnCommas <$> optString "db-hoisted-tx-settings")
|
||||
<*> optWithAlias (optInt "db-max-rows")
|
||||
(optInt "max-rows")
|
||||
<*> (fromMaybe False <$> optBool "db-plan-enabled")
|
||||
<*> (fromMaybe 10 <$> optInt "db-pool")
|
||||
<*> (fromMaybe 10 <$> optInt "db-pool-acquisition-timeout")
|
||||
<*> (fromMaybe 1800 <$> optInt "db-pool-max-lifetime")
|
||||
<*> (fromMaybe 30 <$> optWithAlias (optInt "db-pool-timeout")
|
||||
(optInt "db-pool-max-idletime"))
|
||||
<*> (fromMaybe True <$> optBool "db-pool-automatic-recovery")
|
||||
<*> (fmap toQi <$> optWithAlias (optString "db-pre-request")
|
||||
(optString "pre-request"))
|
||||
<*> (fromMaybe True <$> optBool "db-prepared-statements")
|
||||
<*> (fmap toQi <$> optWithAlias (optString "db-root-spec")
|
||||
(optString "root-spec"))
|
||||
<*> parseDbSchemas "db-schemas" "db-schema"
|
||||
<*> (fromMaybe True <$> optBool "db-config")
|
||||
<*> (fmap toQi <$> optString "db-pre-config")
|
||||
<*> (fromMaybe True <$> optBool "db-timezone-enabled")
|
||||
<*> parseTxEnd "db-tx-end" snd
|
||||
<*> parseTxEnd "db-tx-end" fst
|
||||
<*> (fromMaybe "postgresql://" <$> optString "db-uri")
|
||||
<*> pure optPath
|
||||
<*> pure Nothing
|
||||
<*> optStringOrURI "jwt-aud"
|
||||
<*> parseRoleClaimKey "jwt-role-claim-key" "role-claim-key"
|
||||
<*> (fmap encodeUtf8 <$> optString "jwt-secret")
|
||||
<*> (fromMaybe False <$> optWithAlias
|
||||
(optBool "jwt-secret-is-base64")
|
||||
(optBool "secret-is-base64"))
|
||||
<*> (fromMaybe 1000 <$> optInt "jwt-cache-max-entries")
|
||||
<*> parseLogLevel "log-level"
|
||||
<*> (fromMaybe False <$> optBool "log-query")
|
||||
<*> parseOpenAPIMode "openapi-mode"
|
||||
<*> (fromMaybe False <$> optBool "openapi-security-active")
|
||||
<*> parseOpenAPIServerProxyURI "openapi-server-proxy-uri"
|
||||
<*> parseCORSAllowedOrigins "server-cors-allowed-origins"
|
||||
<*> (defaultServerHost <$> optString "server-host")
|
||||
<*> parseServerPort "server-port"
|
||||
<*> (fmap (CI.mk . encodeUtf8) <$> optString "server-trace-header")
|
||||
<*> (fromMaybe False <$> optBool "server-timing-enabled")
|
||||
<*> (fmap T.unpack <$> optString "server-unix-socket")
|
||||
<*> parseSocketFileMode "server-unix-socket-mode"
|
||||
<*> (fromMaybe True <$> optBool "url-use-legacy-target-names")
|
||||
<*> (defaultServerHost <$> optWithAlias (optString "admin-server-host")
|
||||
(optString "server-host"))
|
||||
<*> parseAdminServerPort "admin-server-port"
|
||||
<*> (fmap T.unpack <$> optString "admin-server-unix-socket")
|
||||
<*> parseSocketFileMode "admin-server-unix-socket-mode"
|
||||
<*> pure roleSettings
|
||||
<*> pure roleIsolationLvl
|
||||
<*> optInt "internal-schema-cache-query-sleep-before-queries"
|
||||
<*> optInt "internal-schema-cache-query-sleep"
|
||||
where
|
||||
parseErrorVerbosity :: C.Key -> C.Parser C.Config Verbosity
|
||||
parseErrorVerbosity k =
|
||||
optString k >>= \case
|
||||
Nothing -> pure Verbose -- default
|
||||
Just "minimal" -> pure Minimal
|
||||
Just "verbose" -> pure Verbose
|
||||
Just _ -> fail "Invalid client-error-verbosity. Check your configuration."
|
||||
|
||||
parseAppSettings :: C.Key -> C.Parser C.Config [(Text, Text)]
|
||||
parseAppSettings key = addFromEnv . fmap (fmap coerceText) <$> C.subassocs key C.value
|
||||
where
|
||||
addFromEnv f = M.toList $ M.union fromEnv $ M.fromList f
|
||||
fromEnv = M.mapKeys fromJust $ M.filterWithKey (\k _ -> isJust k) $ M.mapKeys normalize env
|
||||
normalize k = ("app.settings." <>) <$> T.stripPrefix "PGRST_APP_SETTINGS_" (toS k)
|
||||
|
||||
parseServerPort :: C.Key -> C.Parser C.Config Int
|
||||
parseServerPort k = fromMaybe 3000 <$> optInt k
|
||||
|
||||
parseAdminServerPort :: C.Key -> C.Parser C.Config (Maybe Int)
|
||||
parseAdminServerPort k = do
|
||||
serverPort <- parseServerPort "server-port"
|
||||
optInt k >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just asp | asp == serverPort -> fail "admin-server-port cannot be the same as server-port"
|
||||
| otherwise -> pure $ Just asp
|
||||
|
||||
parseDbSchemas :: C.Key -> C.Key -> C.Parser C.Config (NonEmpty Text)
|
||||
parseDbSchemas k al =
|
||||
optWithAlias (optString k) (optString al) >>= \case
|
||||
Nothing -> pure $ fromList ["public"]
|
||||
Just s
|
||||
| "pg_catalog" `elem` schemas -> fail (errMsg "pg_catalog")
|
||||
| "information_schema" `elem` schemas -> fail (errMsg "information_schema")
|
||||
| otherwise -> pure $ fromList schemas
|
||||
where
|
||||
schemas = splitOnCommas s
|
||||
errMsg x = "db-schemas does not allow schema: '" <> x <> "'"
|
||||
|
||||
parseSocketFileMode :: C.Key -> C.Parser C.Config FileMode
|
||||
parseSocketFileMode k =
|
||||
optString k >>= \case
|
||||
Nothing -> pure 432 -- return default 660 mode if no value was provided
|
||||
Just fileModeText ->
|
||||
case readOct $ T.unpack fileModeText of
|
||||
[] ->
|
||||
fail $ "Invalid " <> T.unpack k <> ": not an octal"
|
||||
(fileMode, _):_ ->
|
||||
if fileMode < 384 || fileMode > 511
|
||||
then fail $ "Invalid " <> T.unpack k <> ": needs to be between 600 and 777"
|
||||
else pure fileMode
|
||||
|
||||
parseOpenAPIMode :: C.Key -> C.Parser C.Config OpenAPIMode
|
||||
parseOpenAPIMode k =
|
||||
optString k >>= \case
|
||||
Nothing -> pure OAFollowPriv
|
||||
Just "follow-privileges" -> pure OAFollowPriv
|
||||
Just "ignore-privileges" -> pure OAIgnorePriv
|
||||
Just "disabled" -> pure OADisabled
|
||||
Just _ -> fail "Invalid openapi-mode. Check your configuration."
|
||||
|
||||
parseOpenAPIServerProxyURI :: C.Key -> C.Parser C.Config (Maybe Text)
|
||||
parseOpenAPIServerProxyURI k =
|
||||
optString k >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just val | isMalformedProxyUri val -> fail "Malformed proxy uri, a correct example: https://example.com:8443/basePath"
|
||||
| otherwise -> pure $ Just val
|
||||
|
||||
parseLogLevel :: C.Key -> C.Parser C.Config LogLevel
|
||||
parseLogLevel k =
|
||||
optString k >>= \case
|
||||
Nothing -> pure LogError
|
||||
Just "crit" -> pure LogCrit
|
||||
Just "error" -> pure LogError
|
||||
Just "warn" -> pure LogWarn
|
||||
Just "info" -> pure LogInfo
|
||||
Just "debug" -> pure LogDebug
|
||||
Just _ -> fail "Invalid logging level. Check your configuration."
|
||||
|
||||
parseTxEnd :: C.Key -> ((Bool, Bool) -> Bool) -> C.Parser C.Config Bool
|
||||
parseTxEnd k f =
|
||||
optString k >>= \case
|
||||
-- RollbackAll AllowOverride
|
||||
Nothing -> pure $ f (False, False)
|
||||
Just "commit" -> pure $ f (False, False)
|
||||
Just "commit-allow-override" -> pure $ f (False, True)
|
||||
Just "rollback" -> pure $ f (True, False)
|
||||
Just "rollback-allow-override" -> pure $ f (True, True)
|
||||
Just _ -> fail "Invalid transaction termination. Check your configuration."
|
||||
|
||||
parseRoleClaimKey :: C.Key -> C.Key -> C.Parser C.Config JSPath
|
||||
parseRoleClaimKey k al =
|
||||
optWithAlias (optString k) (optString al) >>= \case
|
||||
Nothing -> pure defaultRoleJSPathKey -- $.role
|
||||
Just rck -> either (fail . show) pure $ pRoleClaimKey rck
|
||||
|
||||
parseCORSAllowedOrigins k =
|
||||
optString k >>= \case
|
||||
Nothing -> pure []
|
||||
Just orig -> pure (T.strip <$> T.splitOn "," orig)
|
||||
|
||||
optWithAlias :: C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a)
|
||||
optWithAlias orig alias =
|
||||
orig >>= \case
|
||||
Just v -> pure $ Just v
|
||||
Nothing -> alias
|
||||
|
||||
optString :: C.Key -> C.Parser C.Config (Maybe Text)
|
||||
optString k = mfilter (/= "") <$> overrideFromDbOrEnvironment C.optional k coerceText
|
||||
|
||||
optStringEmptyable :: C.Key -> C.Parser C.Config (Maybe Text)
|
||||
optStringEmptyable k = overrideFromDbOrEnvironment C.optional k coerceText
|
||||
|
||||
optStringOrURI :: C.Key -> C.Parser C.Config (Maybe Text)
|
||||
optStringOrURI k = do
|
||||
stringOrURI <- mfilter (/= "") <$> overrideFromDbOrEnvironment C.optional k coerceText
|
||||
-- If the string contains ':' then it should
|
||||
-- be a valid URI according to RFC 3986
|
||||
case stringOrURI of
|
||||
Just s -> if T.isInfixOf ":" s then validateURI s else return (Just s)
|
||||
Nothing -> return Nothing
|
||||
where
|
||||
validateURI :: Text -> C.Parser C.Config (Maybe Text)
|
||||
validateURI s = if isURI (T.unpack s)
|
||||
then return $ Just s
|
||||
else fail "jwt-aud should be a string or a valid URI"
|
||||
|
||||
optInt :: (Read i, Integral i) => C.Key -> C.Parser C.Config (Maybe i)
|
||||
optInt k = join <$> overrideFromDbOrEnvironment C.optional k coerceInt
|
||||
|
||||
optBool :: C.Key -> C.Parser C.Config (Maybe Bool)
|
||||
optBool k = join <$> overrideFromDbOrEnvironment C.optional k coerceBool
|
||||
|
||||
overrideFromDbOrEnvironment :: JustIfMaybe a b =>
|
||||
(C.Key -> C.Parser C.Value a -> C.Parser C.Config b) ->
|
||||
C.Key -> (C.Value -> a) -> C.Parser C.Config b
|
||||
overrideFromDbOrEnvironment necessity key coercion =
|
||||
case dbConf <|> M.lookup envVarName env of
|
||||
Just dbOrEnvVal -> pure $ justIfMaybe $ coercion $ C.String dbOrEnvVal
|
||||
Nothing -> necessity key (coercion <$> C.value)
|
||||
where
|
||||
dashToUnderscore '-' = '_'
|
||||
dashToUnderscore c = c
|
||||
envVarName = "PGRST_" <> (toUpper . dashToUnderscore <$> toS key)
|
||||
dbConf = lookup (T.pack $ dashToUnderscore <$> toS key) dbSettings
|
||||
|
||||
coerceText :: C.Value -> Text
|
||||
coerceText (C.String s) = s
|
||||
coerceText v = show v
|
||||
|
||||
coerceInt :: (Read i, Integral i) => C.Value -> Maybe i
|
||||
coerceInt (C.Number x) = rightToMaybe $ floatingOrInteger x
|
||||
coerceInt (C.String x) = readMaybe x
|
||||
coerceInt _ = Nothing
|
||||
|
||||
coerceBool :: C.Value -> Maybe Bool
|
||||
coerceBool (C.Bool b) = Just b
|
||||
coerceBool (C.String s) =
|
||||
-- parse all kinds of text: True, true, TRUE, "true", ...
|
||||
case readMaybe $ T.toTitle $ T.filter isAlpha $ toS s of
|
||||
Just b -> Just b
|
||||
-- numeric instead?
|
||||
Nothing -> (> 0) <$> (readMaybe s :: Maybe Integer)
|
||||
coerceBool _ = Nothing
|
||||
|
||||
splitOnCommas :: Text -> [Text]
|
||||
splitOnCommas s = T.strip <$> T.splitOn "," s
|
||||
|
||||
splitOnCommasEmptyable :: Text -> [Text]
|
||||
splitOnCommasEmptyable "" = []
|
||||
splitOnCommasEmptyable s = T.strip <$> T.splitOn "," s
|
||||
|
||||
defaultHoistedAllowList = ["statement_timeout","plan_filter.statement_cost_limit","default_transaction_isolation"]
|
||||
|
||||
defaultServerHost :: Maybe Text -> Text
|
||||
defaultServerHost = fromMaybe "!4"
|
||||
|
||||
-- | Read the JWT secret from a file if configJwtSecret is actually a
|
||||
-- filepath(has @ as its prefix). To check if the JWT secret is provided is
|
||||
-- in fact a file path, it must be decoded as 'Text' to be processed.
|
||||
readSecretFile :: AppConfig -> IO AppConfig
|
||||
readSecretFile conf =
|
||||
maybe (return conf) readSecret maybeFilename
|
||||
where
|
||||
maybeFilename = T.stripPrefix "@" . decodeUtf8 =<< configJwtSecret conf
|
||||
readSecret filename = do
|
||||
jwtSecret <- chomp <$> BS.readFile (toS filename)
|
||||
return $ conf { configJwtSecret = Just jwtSecret }
|
||||
chomp bs = fromMaybe bs (BS.stripSuffix "\n" bs)
|
||||
|
||||
decodeSecret :: AppConfig -> IO AppConfig
|
||||
decodeSecret conf@AppConfig{..} =
|
||||
case (configJwtSecretIsBase64, configJwtSecret) of
|
||||
(True, Just secret) ->
|
||||
either fail (return . updateSecret) $ decodeB64 secret
|
||||
_ -> return conf
|
||||
where
|
||||
updateSecret bs = conf { configJwtSecret = Just bs }
|
||||
decodeB64 = B64.decode . encodeUtf8 . T.strip . replaceUrlChars . decodeUtf8
|
||||
replaceUrlChars = T.replace "_" "/" . T.replace "-" "+" . T.replace "." "="
|
||||
|
||||
-- | Parse `jwt-secret` configuration option and turn into a JWKS.
|
||||
--
|
||||
-- There are three ways to specify `jwt-secret`: text secret, JSON Web Key
|
||||
-- (JWK), or JSON Web Key Set (JWKS). The first two are converted into a JwkSet
|
||||
-- with one key and the last is converted as is.
|
||||
decodeJWKS :: AppConfig -> IO AppConfig
|
||||
decodeJWKS conf = do
|
||||
jwks <- case configJwtSecret conf of
|
||||
Just s -> either fail (pure . Just) $ parseSecret s
|
||||
Nothing -> pure Nothing
|
||||
return $ conf { configJWKS = jwks }
|
||||
|
||||
parseSecret :: ByteString -> Either [Char] JwkSet
|
||||
parseSecret bytes =
|
||||
case maybeJWKSet of
|
||||
Just jwk -> Right jwk
|
||||
Nothing -> maybe validateSecret (\jwk' -> Right $ JWT.JwkSet [jwk']) maybeJWK
|
||||
where
|
||||
maybeJWKSet = JSON.decodeStrict bytes :: Maybe JwkSet
|
||||
maybeJWK = JSON.decodeStrict bytes :: Maybe Jwk
|
||||
secret = JWT.JwkSet [JWT.SymmetricJwk bytes Nothing (Just JWT.Sig) (Just $ JWT.Signed JWT.HS256)]
|
||||
validateSecret
|
||||
| BS.length bytes < 32 = Left "The JWT secret must be at least 32 characters long."
|
||||
| otherwise = Right secret
|
||||
|
||||
-- | Read database uri from a separate file if `db-uri` is a filepath.
|
||||
readDbUriFile :: Maybe Text -> AppConfig -> IO AppConfig
|
||||
readDbUriFile maybeDbUri conf =
|
||||
case maybeDbUri of
|
||||
Just prevDbUri ->
|
||||
pure $ conf { configDbUri = prevDbUri }
|
||||
Nothing ->
|
||||
case T.stripPrefix "@" $ configDbUri conf of
|
||||
Nothing -> return conf
|
||||
Just filename -> do
|
||||
dbUri <- T.strip <$> readFile (toS filename)
|
||||
return $ conf { configDbUri = dbUri }
|
||||
|
||||
type Environment = M.Map [Char] Text
|
||||
|
||||
-- | Read environment variables that start with PGRST_
|
||||
readPGRSTEnvironment :: IO Environment
|
||||
readPGRSTEnvironment =
|
||||
M.map T.pack . M.fromList . filter (isPrefixOf "PGRST_" . fst) <$> getEnvironment
|
||||
|
||||
data PGConnString = PGURI | PGKeyVal
|
||||
|
||||
-- Uses same logic as libpq recognized_connection_string
|
||||
-- https://github.com/postgres/postgres/blob/5eafacd2797dc0b04a0bde25fbf26bf79903e7c2/src/interfaces/libpq/fe-connect.c#L5923-L5936
|
||||
pgConnString :: Text -> Maybe PGConnString
|
||||
pgConnString conn | uriDesignator `T.isPrefixOf` conn || shortUriDesignator `T.isPrefixOf` conn = Just PGURI
|
||||
| "=" `T.isInfixOf` conn = Just PGKeyVal
|
||||
| otherwise = Nothing
|
||||
where
|
||||
uriDesignator = "postgresql://"
|
||||
shortUriDesignator = "postgres://"
|
||||
|
||||
-- | Adds a `fallback_application_name` value to the connection string. This allows querying the PostgREST version on pg_stat_activity.
|
||||
--
|
||||
-- >>> import Protolude
|
||||
-- >>> let ver = "11.1.0 (5a04ec7)"::ByteString
|
||||
-- >>> let strangeVer = "11'1&0@#$%,.:\"[]{}?+^()=asdfqwer"::ByteString
|
||||
--
|
||||
-- >>> addFallbackAppName ver "postgres://user:pass@host:5432/postgres"
|
||||
-- "postgres://user:pass@host:5432/postgres?fallback_application_name=PostgREST%2011.1.0%20%285a04ec7%29"
|
||||
--
|
||||
-- >>> addFallbackAppName ver "postgres://user:pass@host:5432/postgres?"
|
||||
-- "postgres://user:pass@host:5432/postgres?fallback_application_name=PostgREST%2011.1.0%20%285a04ec7%29"
|
||||
--
|
||||
-- >>> addFallbackAppName ver "postgres:///postgres?host=server&port=5432"
|
||||
-- "postgres:///postgres?host=server&port=5432&fallback_application_name=PostgREST%2011.1.0%20%285a04ec7%29"
|
||||
--
|
||||
-- >>> addFallbackAppName ver "postgresql://"
|
||||
-- "postgresql://?fallback_application_name=PostgREST%2011.1.0%20%285a04ec7%29"
|
||||
--
|
||||
-- >>> addFallbackAppName strangeVer "postgres:///postgres?host=server&port=5432"
|
||||
-- "postgres:///postgres?host=server&port=5432&fallback_application_name=PostgREST%2011%271%260%40%23%24%25%2C.%3A%22%5B%5D%7B%7D%3F%2B%5E%28%29%3Dasdfqwer"
|
||||
--
|
||||
-- >>> addFallbackAppName ver "postgres://user:invalid_chars[]#@host:5432/postgres"
|
||||
-- "postgres://user:invalid_chars[]#@host:5432/postgres?fallback_application_name=PostgREST%2011.1.0%20%285a04ec7%29"
|
||||
--
|
||||
-- >>> addFallbackAppName ver "host=localhost port=5432 dbname=postgres"
|
||||
-- "host=localhost port=5432 dbname=postgres fallback_application_name='PostgREST 11.1.0 (5a04ec7)'"
|
||||
--
|
||||
-- >>> addFallbackAppName strangeVer "host=localhost port=5432 dbname=postgres"
|
||||
-- "host=localhost port=5432 dbname=postgres fallback_application_name='PostgREST 11\\'1&0@#$%,.:\"[]{}?+^()=asdfqwer'"
|
||||
--
|
||||
-- works with passwords containing `?`
|
||||
-- >>> addFallbackAppName ver "postgres://admin2:?pass?special?@localhost:5432/postgres"
|
||||
-- "postgres://admin2:?pass?special?@localhost:5432/postgres?fallback_application_name=PostgREST%2011.1.0%20%285a04ec7%29"
|
||||
--
|
||||
-- >>> addFallbackAppName ver "postgresql://?dbname=postgres&host=/run/user/1000/postgrest/postgrest-with-postgresql-16-BuR/socket&user=some_protected_user&password=invalid_pass"
|
||||
-- "postgresql://?dbname=postgres&host=/run/user/1000/postgrest/postgrest-with-postgresql-16-BuR/socket&user=some_protected_user&password=invalid_pass&fallback_application_name=PostgREST%2011.1.0%20%285a04ec7%29"
|
||||
--
|
||||
-- >>> addFallbackAppName ver "postgresql:///postgres?host=/run/user/1000/postgrest/postgrest-with-postgresql-16-BuR/socket&user=some_protected_user&password=invalid_pass"
|
||||
-- "postgresql:///postgres?host=/run/user/1000/postgrest/postgrest-with-postgresql-16-BuR/socket&user=some_protected_user&password=invalid_pass&fallback_application_name=PostgREST%2011.1.0%20%285a04ec7%29"
|
||||
addFallbackAppName :: ByteString -> Text -> Text
|
||||
addFallbackAppName version dbUri = addConnStringOption dbUri "fallback_application_name" pgrstVer
|
||||
where
|
||||
pgrstVer = "PostgREST " <> T.decodeUtf8 version
|
||||
|
||||
-- | Adds `target_session_attrs=read-write` to the connection string. This allows using PostgREST listener when multiple hosts are specified in the connection string.
|
||||
--
|
||||
-- >>> addTargetSessionAttrs "postgres:///postgres?host=/dir/0kN/socket_replica_24378,/dir/0kN/socket"
|
||||
-- "postgres:///postgres?host=/dir/0kN/socket_replica_24378,/dir/0kN/socket&target_session_attrs=read-write"
|
||||
--
|
||||
-- >>> addTargetSessionAttrs "postgresql://host1:123,host2:456/somedb"
|
||||
-- "postgresql://host1:123,host2:456/somedb?target_session_attrs=read-write"
|
||||
--
|
||||
-- >>> addTargetSessionAttrs "postgresql://host1:123,host2:456/somedb?fallback_application_name=foo"
|
||||
-- "postgresql://host1:123,host2:456/somedb?fallback_application_name=foo&target_session_attrs=read-write"
|
||||
--
|
||||
-- adds target_session_attrs despite one existing
|
||||
-- >>> addTargetSessionAttrs "postgresql://host1:123,host2:456/somedb?target_session_attrs=read-only"
|
||||
-- "postgresql://host1:123,host2:456/somedb?target_session_attrs=read-only&target_session_attrs=read-write"
|
||||
--
|
||||
-- >>> addTargetSessionAttrs "host=localhost port=5432 dbname=postgres"
|
||||
-- "host=localhost port=5432 dbname=postgres target_session_attrs='read-write'"
|
||||
addTargetSessionAttrs :: Text -> Text
|
||||
addTargetSessionAttrs dbUri = addConnStringOption dbUri "target_session_attrs" "read-write"
|
||||
|
||||
toConnectionSettings :: (Text -> Text) -> AppConfig -> [SQL.Setting]
|
||||
toConnectionSettings transformUri AppConfig{configDbUri, configDbPreparedStatements} =
|
||||
[ SQL.connection $ SQL.string $ transformUri . addFallbackAppName prettyVersion $ configDbUri
|
||||
, SQL.usePreparedStatements configDbPreparedStatements
|
||||
]
|
||||
|
||||
addConnStringOption :: Text -> Text -> Text -> Text
|
||||
addConnStringOption dbUri key val = dbUri <>
|
||||
case pgConnString dbUri of
|
||||
Nothing -> mempty
|
||||
Just PGKeyVal -> " " <> keyValFmt
|
||||
Just PGURI -> case lookAtOptions dbUri of
|
||||
(_, "") -> "?" <> uriFmt
|
||||
(_, "?") -> uriFmt
|
||||
(_, _) -> "&" <> uriFmt
|
||||
where
|
||||
uriFmt = key <> "=" <> toS (escapeURIString isUnescapedInURIComponent $ toS val)
|
||||
keyValFmt = key <> "=" <> "'" <> T.replace "'" "\\'" val <> "'"
|
||||
lookAtOptions x = T.breakOn "?" . snd $ T.breakOnEnd "@" x -- start from after `@` to not mess passwords that include `?`, see https://www.postgresql.org/docs/current/libpq-connect.html#LIBPQ-CONNSTRING-URIS
|
||||
|
||||
-- | Example config file displayed on postgrest "--example" flag
|
||||
exampleConfigFile :: [Char]
|
||||
exampleConfigFile = S.unlines
|
||||
[ "## Admin server used for checks. It's disabled by default unless a port is specified."
|
||||
, "# admin-server-port = 3001"
|
||||
, ""
|
||||
, "# PostgREST error json verbosity config"
|
||||
, "# client-error-verbosity = \"verbose\""
|
||||
, ""
|
||||
, "## The database role to use when no client authentication is provided"
|
||||
, "# db-anon-role = \"anon\""
|
||||
, ""
|
||||
, "## Notification channel for reloading the schema cache"
|
||||
, "db-channel = \"pgrst\""
|
||||
, ""
|
||||
, "## Enable or disable the notification channel"
|
||||
, "db-channel-enabled = true"
|
||||
, ""
|
||||
, "## Enable in-database configuration"
|
||||
, "db-config = true"
|
||||
, ""
|
||||
, "## Function for in-database configuration"
|
||||
, "## db-pre-config = \"postgrest.pre_config\""
|
||||
, ""
|
||||
, "## Extra schemas to add to the search_path of every request"
|
||||
, "db-extra-search-path = \"public\""
|
||||
, ""
|
||||
, "## Limit rows in response"
|
||||
, "# db-max-rows = 1000"
|
||||
, ""
|
||||
, "## Allow getting the EXPLAIN plan through the `Accept: application/vnd.pgrst.plan` header"
|
||||
, "# db-plan-enabled = false"
|
||||
, ""
|
||||
, "## Number of open connections in the pool"
|
||||
, "db-pool = 10"
|
||||
, ""
|
||||
, "## Time in seconds to wait to acquire a slot from the connection pool"
|
||||
, "# db-pool-acquisition-timeout = 10"
|
||||
, ""
|
||||
, "## Time in seconds after which to recycle pool connections"
|
||||
, "# db-pool-max-lifetime = 1800"
|
||||
, ""
|
||||
, "## Time in seconds after which to recycle unused pool connections"
|
||||
, "# db-pool-max-idletime = 30"
|
||||
, ""
|
||||
, "## Allow automatic database connection retrying"
|
||||
, "# db-pool-automatic-recovery = true"
|
||||
, ""
|
||||
, "## Stored proc to exec immediately after auth"
|
||||
, "# db-pre-request = \"stored_proc_name\""
|
||||
, ""
|
||||
, "## Enable or disable prepared statements. disabling is only necessary when behind a connection pooler."
|
||||
, "## When disabled, statements will be parametrized but won't be prepared."
|
||||
, "db-prepared-statements = true"
|
||||
, ""
|
||||
, "## The name of which database schema to expose to REST clients"
|
||||
, "db-schemas = \"public\""
|
||||
, ""
|
||||
, "## Enable quering pg_timezone_names from db"
|
||||
, "# db-timezone-enabled = true"
|
||||
, ""
|
||||
, "## How to terminate database transactions"
|
||||
, "## Possible values are:"
|
||||
, "## commit (default)"
|
||||
, "## Transaction is always committed, this can not be overridden"
|
||||
, "## commit-allow-override"
|
||||
, "## Transaction is committed, but can be overridden with Prefer tx=rollback header"
|
||||
, "## rollback"
|
||||
, "## Transaction is always rolled back, this can not be overridden"
|
||||
, "## rollback-allow-override"
|
||||
, "## Transaction is rolled back, but can be overridden with Prefer tx=commit header"
|
||||
, "db-tx-end = \"commit\""
|
||||
, ""
|
||||
, "## The standard connection URI format, documented at"
|
||||
, "## https://www.postgresql.org/docs/current/libpq-connect.html#LIBPQ-CONNSTRING"
|
||||
, "db-uri = \"postgresql://\""
|
||||
, ""
|
||||
, "# jwt-aud = \"your_audience_claim\""
|
||||
, ""
|
||||
, "## Jspath to the role claim key"
|
||||
, "jwt-role-claim-key = \".role\""
|
||||
, ""
|
||||
, "## Choose a secret, JSON Web Key (or set) to enable JWT auth"
|
||||
, "## (use \"@filename\" to load from separate file)"
|
||||
, "# jwt-secret = \"secret_with_at_least_32_characters\""
|
||||
, "jwt-secret-is-base64 = false"
|
||||
, ""
|
||||
, "## Enables JWT Cache and sets its max size, disables caching with 0"
|
||||
, "# jwt-cache-max-entries = 0"
|
||||
, ""
|
||||
, "## Logging level, the admitted values are: crit, error, warn, info and debug."
|
||||
, "log-level = \"error\""
|
||||
, ""
|
||||
, "## Log the SQL query at the current log-level."
|
||||
, "log-query = false"
|
||||
, ""
|
||||
, "## Determine if the OpenAPI output should follow or ignore role privileges or be disabled entirely."
|
||||
, "## Admitted values: follow-privileges, ignore-privileges, disabled"
|
||||
, "openapi-mode = \"follow-privileges\""
|
||||
, ""
|
||||
, "## Base url for the OpenAPI output"
|
||||
, "openapi-server-proxy-uri = \"\""
|
||||
, ""
|
||||
, "## Configurable CORS origins"
|
||||
, "# server-cors-allowed-origins = \"\""
|
||||
, ""
|
||||
, "server-host = \"!4\""
|
||||
, "server-port = 3000"
|
||||
, ""
|
||||
, "## Allow getting the request-response timing information through the `Server-Timing` header"
|
||||
, "server-timing-enabled = false"
|
||||
, ""
|
||||
, "## Unix socket location"
|
||||
, "## if specified it takes precedence over server-port"
|
||||
, "# server-unix-socket = \"/tmp/pgrst.sock\""
|
||||
, ""
|
||||
, "## Unix socket file mode"
|
||||
, "## When none is provided, 660 is applied by default"
|
||||
, "# server-unix-socket-mode = \"660\""
|
||||
, ""
|
||||
, "## Use legacy target names in relationship filters"
|
||||
, "## If active, allows using the target name of the relationship in filters even if it has an alias."
|
||||
, "## Otherwise it only allows the alias in filters"
|
||||
, "url-use-legacy-target-names = true"
|
||||
]
|
||||
@@ -0,0 +1,207 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module PostgREST.Config.Database
|
||||
( pgVersionStatement
|
||||
, queryDbSettings
|
||||
, queryPgVersion
|
||||
, queryRoleSettings
|
||||
, RoleSettings
|
||||
, RoleIsolationLvl
|
||||
, TimezoneNames
|
||||
, toIsolationLevel
|
||||
) where
|
||||
|
||||
import Control.Arrow ((***))
|
||||
|
||||
import PostgREST.Config.PgVersion (PgVersion (..), pgVersion150)
|
||||
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Text as T
|
||||
|
||||
import qualified Hasql.Decoders as HD
|
||||
import qualified Hasql.Encoders as HE
|
||||
import Hasql.Session (Session, statement)
|
||||
import qualified Hasql.Statement as SQL
|
||||
import qualified Hasql.Transaction as SQL
|
||||
import qualified Hasql.Transaction.Sessions as SQL
|
||||
|
||||
import NeatInterpolation (trimming)
|
||||
|
||||
import Protolude
|
||||
|
||||
type RoleSettings = (HM.HashMap ByteString (HM.HashMap ByteString ByteString))
|
||||
type RoleIsolationLvl = HM.HashMap ByteString SQL.IsolationLevel
|
||||
type TimezoneNames = Set Text -- cache timezone names for prefer timezone=
|
||||
|
||||
toIsolationLevel :: Text -> SQL.IsolationLevel
|
||||
toIsolationLevel a = case T.toLower a of
|
||||
"repeatable read" -> SQL.RepeatableRead
|
||||
"serializable" -> SQL.Serializable
|
||||
_ -> SQL.ReadCommitted
|
||||
|
||||
prefix :: Text
|
||||
prefix = "pgrst."
|
||||
|
||||
-- | In-db settings names
|
||||
dbSettingsNames :: [Text]
|
||||
dbSettingsNames =
|
||||
(prefix <>) <$>
|
||||
["db_aggregates_enabled"
|
||||
,"client_error_verbosity"
|
||||
,"db_anon_role"
|
||||
,"db_pre_config"
|
||||
,"db_extra_search_path"
|
||||
,"db_max_rows"
|
||||
,"db_plan_enabled"
|
||||
,"db_pre_request"
|
||||
,"db_prepared_statements"
|
||||
,"db_root_spec"
|
||||
,"db_schemas"
|
||||
,"db_timezone_enabled"
|
||||
,"db_tx_end"
|
||||
,"db_hoisted_tx_settings"
|
||||
,"jwt_aud"
|
||||
,"jwt_role_claim_key"
|
||||
,"jwt_secret"
|
||||
,"jwt_secret_is_base64"
|
||||
,"jwt_cache_max_lifetime"
|
||||
,"openapi_mode"
|
||||
,"openapi_security_active"
|
||||
,"openapi_server_proxy_uri"
|
||||
,"server_cors_allowed_origins"
|
||||
,"server_trace_header"
|
||||
,"server_timing_enabled"
|
||||
,"url_use_legacy_target_names"
|
||||
]
|
||||
|
||||
queryPgVersion :: Session PgVersion
|
||||
queryPgVersion = statement mempty $ pgVersionStatement False
|
||||
|
||||
pgVersionStatement :: Bool -> SQL.Statement () PgVersion
|
||||
pgVersionStatement = SQL.Statement sql HE.noParams versionRow
|
||||
where
|
||||
sql = "SELECT current_setting('server_version_num')::integer, current_setting('server_version'), version()"
|
||||
versionRow = HD.singleRow $ PgVersion <$> column HD.int4 <*> column HD.text <*> column HD.text
|
||||
|
||||
-- | Query the in-database configuration. The settings have the following priorities:
|
||||
--
|
||||
-- 1. Role + with database-specific settings:
|
||||
-- ALTER ROLE authenticator IN DATABASE postgres SET <prefix>jwt_aud = 'val';
|
||||
-- 2. Role + with settings:
|
||||
-- ALTER ROLE authenticator SET <prefix>jwt_aud = 'overridden';
|
||||
-- 3. pre-config function:
|
||||
-- CREATE FUNCTION pre_config() .. PERFORM set_config(<prefix>jwt_aud, 'pre_config_aud'..)
|
||||
--
|
||||
-- The example above will result in <prefix>jwt_aud = 'val'
|
||||
-- A setting on the database only will have no effect: ALTER DATABASE postgres SET <prefix>jwt_aud = 'xx'
|
||||
queryDbSettings :: Maybe Text -> Session [(Text, Text)]
|
||||
queryDbSettings preConfFunc =
|
||||
SQL.transactionNoRetry SQL.ReadCommitted SQL.Read $ SQL.statement dbSettingsNames $ SQL.Statement sql (arrayParam HE.text) decodeSettings True
|
||||
where
|
||||
sql = encodeUtf8 [trimming|
|
||||
WITH
|
||||
role_setting AS (
|
||||
SELECT setdatabase as database,
|
||||
unnest(setconfig) as setting
|
||||
FROM pg_catalog.pg_db_role_setting
|
||||
WHERE setrole = quote_ident(CURRENT_USER)::regrole::oid
|
||||
AND setdatabase IN (0, (SELECT oid FROM pg_catalog.pg_database WHERE datname = CURRENT_CATALOG))
|
||||
),
|
||||
kv_settings AS (
|
||||
SELECT database,
|
||||
substr(setting, 1, strpos(setting, '=') - 1) as k,
|
||||
substr(setting, strpos(setting, '=') + 1) as v
|
||||
FROM role_setting
|
||||
${preConfigF}
|
||||
)
|
||||
SELECT DISTINCT ON (key)
|
||||
replace(k, '${prefix}', '') AS key,
|
||||
v AS value
|
||||
FROM kv_settings
|
||||
WHERE k = ANY($$1) AND v IS NOT NULL
|
||||
ORDER BY key, database DESC NULLS LAST;
|
||||
|]
|
||||
preConfigF = case preConfFunc of
|
||||
Nothing -> mempty
|
||||
Just func -> [trimming|
|
||||
UNION
|
||||
SELECT
|
||||
null as database,
|
||||
x as k,
|
||||
current_setting(x, true) as v
|
||||
FROM unnest($$1) x
|
||||
JOIN ${func}() _ ON TRUE
|
||||
|]::Text
|
||||
decodeSettings = HD.rowList $ (,) <$> column HD.text <*> column HD.text
|
||||
|
||||
queryRoleSettings :: PgVersion -> Session (RoleSettings, RoleIsolationLvl)
|
||||
queryRoleSettings pgVer =
|
||||
SQL.transactionNoRetry SQL.ReadCommitted SQL.Read $ SQL.statement mempty $ SQL.Statement sql HE.noParams (processRows <$> rows) True
|
||||
where
|
||||
sql = encodeUtf8 [trimming|
|
||||
with
|
||||
role_setting as (
|
||||
select r.rolname, unnest(r.rolconfig) as setting
|
||||
from pg_auth_members m
|
||||
join pg_roles r on r.oid = m.roleid
|
||||
where member = quote_ident(current_user)::regrole::oid
|
||||
),
|
||||
kv_settings AS (
|
||||
SELECT
|
||||
rolname,
|
||||
substr(setting, 1, strpos(setting, '=') - 1) as key,
|
||||
substr(setting, strpos(setting, '=') + 1) as value
|
||||
FROM role_setting
|
||||
),
|
||||
iso_setting AS (
|
||||
SELECT rolname, value
|
||||
FROM kv_settings
|
||||
WHERE key = 'default_transaction_isolation'
|
||||
)
|
||||
select
|
||||
kv.rolname,
|
||||
i.value as iso_lvl,
|
||||
coalesce(array_agg(row(kv.key, kv.value)) filter (where key <> 'default_transaction_isolation'), '{}') as role_settings
|
||||
from kv_settings kv
|
||||
join pg_settings ps on ps.name = kv.key and (ps.context = 'user' ${hasParameterPrivilege})
|
||||
left join iso_setting i on i.rolname = kv.rolname
|
||||
group by kv.rolname, i.value;
|
||||
|]
|
||||
|
||||
hasParameterPrivilege
|
||||
| pgVer >= pgVersion150 = "or has_parameter_privilege(quote_ident(current_user)::regrole::oid, ps.name, 'set')"
|
||||
| otherwise = ""
|
||||
|
||||
processRows :: [(Text, Maybe Text, [(Text, Text)])] -> (RoleSettings, RoleIsolationLvl)
|
||||
processRows rs =
|
||||
let
|
||||
rowsWRoleSettings = [ (x, z) | (x, _, z) <- rs ]
|
||||
rowsWIsolation = [ (x, y) | (x, Just y, _) <- rs ]
|
||||
in
|
||||
( HM.fromList $ bimap encodeUtf8 (HM.fromList . ((encodeUtf8 *** encodeUtf8) <$>)) <$> rowsWRoleSettings
|
||||
, HM.fromList $ (encodeUtf8 *** toIsolationLevel) <$> rowsWIsolation
|
||||
)
|
||||
|
||||
rows :: HD.Result [(Text, Maybe Text, [(Text, Text)])]
|
||||
rows = HD.rowList $ (,,) <$> column HD.text <*> nullableColumn HD.text <*> compositeArrayColumn ((,) <$> compositeField HD.text <*> compositeField HD.text)
|
||||
|
||||
column :: HD.Value a -> HD.Row a
|
||||
column = HD.column . HD.nonNullable
|
||||
|
||||
nullableColumn :: HD.Value a -> HD.Row (Maybe a)
|
||||
nullableColumn = HD.column . HD.nullable
|
||||
|
||||
compositeField :: HD.Value a -> HD.Composite a
|
||||
compositeField = HD.field . HD.nonNullable
|
||||
|
||||
compositeArrayColumn :: HD.Composite a -> HD.Row [a]
|
||||
compositeArrayColumn = arrayColumn . HD.composite
|
||||
|
||||
arrayColumn :: HD.Value a -> HD.Row [a]
|
||||
arrayColumn = column . HD.listArray . HD.nonNullable
|
||||
|
||||
param :: HE.Value a -> HE.Params a
|
||||
param = HE.param . HE.nonNullable
|
||||
|
||||
arrayParam :: HE.Value a -> HE.Params [a]
|
||||
arrayParam = param . HE.foldableArray . HE.nonNullable
|
||||
@@ -0,0 +1,60 @@
|
||||
{-|
|
||||
Module : PostgREST.Config.JSPath
|
||||
Description : Parsing and evaluation logic of JSPath
|
||||
-}
|
||||
module PostgREST.Config.JSPath
|
||||
( JSPath(..)
|
||||
, defaultRoleJSPathKey
|
||||
, dumpJSPath
|
||||
, pRoleClaimKey
|
||||
, evaluateJSPath
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.JSONPath as JSP
|
||||
import qualified Data.Aeson.JSONPath.Parser as JSP
|
||||
import qualified Data.Aeson.JSONPath.Types as JSP
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
import qualified Text.ParserCombinators.Parsec as P
|
||||
|
||||
import Data.Either.Combinators (mapLeft)
|
||||
import Data.Either.Extra (fromRight')
|
||||
import Text.ParserCombinators.Parsec ((<?>))
|
||||
|
||||
import Protolude
|
||||
|
||||
|
||||
-- | full jspath, e.g. "$.property[0].attr.detail[?(@ == "role1")]"
|
||||
newtype JSPath = JSPath JSP.Query
|
||||
|
||||
-- | Default value for "jwt-role-claim-key" config
|
||||
defaultRoleJSPathKey :: JSPath
|
||||
defaultRoleJSPathKey = fromRight' $ P.parse pJSPath "" "$.role"
|
||||
|
||||
-- | Dump JSPath
|
||||
-- e.g. "$.property[0].attr.detail[?(@ == "role1")]"
|
||||
dumpJSPath :: JSPath -> Text
|
||||
dumpJSPath (JSPath query) = (escapeDollarChar . escapeDoubleQuotes) jsPathDump
|
||||
where
|
||||
jsPathDump = JSP.dumpQuery query
|
||||
escapeDoubleQuotes = T.replace "\"" "\\\""
|
||||
-- When dumping, $ must be escaped
|
||||
escapeDollarChar = T.replace "$" "$$"
|
||||
|
||||
-- |
|
||||
-- Evaluate JSPath on a JSON
|
||||
-- The result of JSON Path query is a Vector, we select the first
|
||||
-- string element as the role.
|
||||
evaluateJSPath :: Maybe JSON.Value -> JSPath -> Maybe JSON.Value
|
||||
evaluateJSPath Nothing _ = Nothing
|
||||
evaluateJSPath (Just json) (JSPath query) = JSP.queryQQ query json V.!? 0
|
||||
|
||||
-- Used for the config value "role-claim-key"
|
||||
pRoleClaimKey :: Text -> Either Text JSPath
|
||||
pRoleClaimKey selStr =
|
||||
mapLeft show $ P.parse pJSPath ("failed to parse role-claim-key value (" <> toS selStr <> ")") (toS selStr)
|
||||
|
||||
-- | Parse RFC 9535 JSPath: $.roles[0]
|
||||
pJSPath :: P.Parser JSPath
|
||||
pJSPath = JSPath <$> JSP.pQuery <?> "pJSPath: JSPath root query"
|
||||
@@ -0,0 +1,40 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
module PostgREST.Config.PgVersion
|
||||
( PgVersion(..)
|
||||
, minimumPgVersion
|
||||
, pgVersion150
|
||||
, pgVersion180
|
||||
, pgVersion190
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
|
||||
import Protolude
|
||||
|
||||
|
||||
data PgVersion = PgVersion
|
||||
{ pgvNum :: Int32
|
||||
, pgvName :: Text
|
||||
, pgvFullName :: Text
|
||||
}
|
||||
deriving (Eq, Generic, JSON.ToJSON)
|
||||
|
||||
instance Ord PgVersion where
|
||||
(PgVersion v1 _ _) `compare` (PgVersion v2 _ _) = v1 `compare` v2
|
||||
|
||||
-- | Tells the minimum PostgreSQL version required by this version of PostgREST
|
||||
minimumPgVersion :: PgVersion
|
||||
minimumPgVersion = pgVersion140
|
||||
|
||||
pgVersion140 :: PgVersion
|
||||
pgVersion140 = PgVersion 140000 "14.0" "14.0"
|
||||
|
||||
pgVersion150 :: PgVersion
|
||||
pgVersion150 = PgVersion 150000 "15.0" "15.0"
|
||||
|
||||
pgVersion180 :: PgVersion
|
||||
pgVersion180 = PgVersion 180000 "18.0" "18.0"
|
||||
|
||||
pgVersion190 :: PgVersion
|
||||
pgVersion190 = PgVersion 190000 "19.0" "19.0"
|
||||
@@ -0,0 +1,77 @@
|
||||
{-|
|
||||
Module : PostgREST.Private.ProxyUri
|
||||
Description : Proxy Uri validator
|
||||
-}
|
||||
module PostgREST.Config.Proxy
|
||||
( Proxy(..)
|
||||
, isMalformedProxyUri
|
||||
, toURI
|
||||
) where
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
import Network.URI (URI (..), URIAuth (..), isAbsoluteURI, parseURI)
|
||||
|
||||
import Protolude hiding (Proxy)
|
||||
|
||||
data Proxy = Proxy
|
||||
{ proxyScheme :: Text
|
||||
, proxyHost :: Text
|
||||
, proxyPort :: Integer
|
||||
, proxyPath :: Text
|
||||
}
|
||||
|
||||
{-|
|
||||
Test whether a proxy uri is malformed or not.
|
||||
A valid proxy uri should be an absolute uri without query and user info,
|
||||
only http(s) schemes are valid, port number range is 1-65535.
|
||||
|
||||
For example
|
||||
http://postgrest.com/openapi.json
|
||||
https://postgrest.com:8080/openapi.json
|
||||
-}
|
||||
isMalformedProxyUri :: Text -> Bool
|
||||
isMalformedProxyUri uri
|
||||
| isAbsoluteURI (toS uri) = not $ isUriValid $ toURI uri
|
||||
| otherwise = True
|
||||
|
||||
toURI :: Text -> URI
|
||||
toURI uri = fromJust $ parseURI (toS uri)
|
||||
|
||||
isUriValid:: URI -> Bool
|
||||
isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid]
|
||||
|
||||
fAnd :: [a -> Bool] -> a -> Bool
|
||||
fAnd fs x = all ($ x) fs
|
||||
|
||||
isSchemeValid :: URI -> Bool
|
||||
isSchemeValid URI {uriScheme = s}
|
||||
| T.toLower (T.pack s) == "https:" = True
|
||||
| T.toLower (T.pack s) == "http:" = True
|
||||
| otherwise = False
|
||||
|
||||
isQueryValid :: URI -> Bool
|
||||
isQueryValid URI {uriQuery = ""} = True
|
||||
isQueryValid _ = False
|
||||
|
||||
isAuthorityValid :: URI -> Bool
|
||||
isAuthorityValid URI {uriAuthority = a}
|
||||
| isJust a = fAnd [isUserInfoValid, isHostValid, isPortValid] $ fromJust a
|
||||
| otherwise = False
|
||||
|
||||
isUserInfoValid :: URIAuth -> Bool
|
||||
isUserInfoValid URIAuth {uriUserInfo = ""} = True
|
||||
isUserInfoValid _ = False
|
||||
|
||||
isHostValid :: URIAuth -> Bool
|
||||
isHostValid URIAuth {uriRegName = ""} = False
|
||||
isHostValid _ = True
|
||||
|
||||
isPortValid :: URIAuth -> Bool
|
||||
isPortValid URIAuth {uriPort = ""} = True
|
||||
isPortValid URIAuth {uriPort = (':':p)} =
|
||||
case readMaybe p of
|
||||
Just i -> i > (0 :: Integer) && i < 65536
|
||||
Nothing -> False
|
||||
isPortValid _ = False
|
||||
@@ -0,0 +1,50 @@
|
||||
{-|
|
||||
Module : PostgREST.Cors
|
||||
Description : Wai Middleware to set cors policy.
|
||||
-}
|
||||
module PostgREST.Cors (middleware) where
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Network.Wai as Wai
|
||||
import qualified Network.Wai.Middleware.Cors as Wai
|
||||
|
||||
import Data.List (lookup)
|
||||
|
||||
import PostgREST.AppState (AppState, getConfig)
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
|
||||
import Protolude
|
||||
|
||||
middleware :: AppState -> Wai.Middleware
|
||||
middleware appState app req res = do
|
||||
conf <- getConfig appState
|
||||
Wai.cors (corsPolicy $ configServerCorsAllowedOrigins conf) app req res
|
||||
|
||||
-- | CORS policy to be used in by Wai Cors middleware
|
||||
corsPolicy :: [Text] -> Wai.Request -> Maybe Wai.CorsResourcePolicy
|
||||
corsPolicy corsAllowedOrigins req = case lookup "origin" headers of
|
||||
Just _ ->
|
||||
Just Wai.CorsResourcePolicy
|
||||
{ Wai.corsOrigins = case corsAllowedOrigins of
|
||||
[] -> Nothing
|
||||
origins -> Just (map T.encodeUtf8 origins, True)
|
||||
, Wai.corsMethods = ["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"]
|
||||
, Wai.corsRequestHeaders = "Authorization" : accHeaders
|
||||
, Wai.corsExposedHeaders = Just
|
||||
[ "Content-Encoding", "Content-Location", "Content-Range", "Content-Type"
|
||||
, "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"]
|
||||
, Wai.corsMaxAge = Just $ 60*60*24
|
||||
, Wai.corsVaryOrigin = False
|
||||
, Wai.corsRequireOrigin = False
|
||||
, Wai.corsIgnoreFailures = True
|
||||
}
|
||||
Nothing -> Nothing
|
||||
where
|
||||
headers = Wai.requestHeaders req
|
||||
accHeaders = case lookup "access-control-request-headers" headers of
|
||||
Just hdrs -> map (CI.mk . BS.strip) $ BS.split ',' hdrs
|
||||
-- Impossible case, Middleware.Cors will not evaluate this when
|
||||
-- the Access-Control-Request-Headers header is not set.
|
||||
Nothing -> []
|
||||
@@ -0,0 +1,19 @@
|
||||
module PostgREST.Debounce
|
||||
( makeDebouncer) where
|
||||
|
||||
import Protolude
|
||||
|
||||
-- | Make a new debouncer action. An internal "worker" thread runs forever
|
||||
-- ensuring "action" runs when the "trigger" is called. The "action" is only
|
||||
-- executed once over a burst of calls.
|
||||
makeDebouncer :: IO () -> IO (IO ())
|
||||
makeDebouncer action = do
|
||||
flag <- newEmptyMVar
|
||||
|
||||
let worker = forever $ do
|
||||
takeMVar flag
|
||||
action
|
||||
trigger = void $ tryPutMVar flag ()
|
||||
|
||||
void $ forkIO worker
|
||||
pure trigger
|
||||
@@ -0,0 +1,721 @@
|
||||
{-|
|
||||
Module : PostgREST.Error
|
||||
Description : PostgREST error HTTP responses
|
||||
-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module PostgREST.Error
|
||||
( errorResponseFor
|
||||
, ApiRequestError(..)
|
||||
, QPError(..)
|
||||
, RangeError(..)
|
||||
, SchemaCacheError(..)
|
||||
, PgError(..)
|
||||
, Error(..)
|
||||
, JwtError (..)
|
||||
, JwtDecodeError(..)
|
||||
, JwtClaimsError(..)
|
||||
, errorPayload
|
||||
, status
|
||||
, noRelBetweenHint
|
||||
, noRpcHint
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.FuzzySet as Fuzzy
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Map.Internal as M
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Hasql.Pool as SQL
|
||||
import qualified Hasql.Session as SQL
|
||||
import qualified Network.HTTP.Types.Status as HTTP
|
||||
|
||||
import Data.Aeson ((.:), (.:?), (.=))
|
||||
import Network.Wai (Response, responseLBS)
|
||||
|
||||
import Network.HTTP.Types.Header (Header)
|
||||
|
||||
import PostgREST.MediaType (MediaType (..))
|
||||
import qualified PostgREST.MediaType as MediaType
|
||||
|
||||
import PostgREST.Config (Verbosity (..))
|
||||
import PostgREST.SchemaCache (SchemaCache (SchemaCache, dbTablesFuzzyIndex))
|
||||
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..),
|
||||
Schema)
|
||||
import PostgREST.SchemaCache.Relationship (Cardinality (..),
|
||||
Junction (..),
|
||||
Relationship (..),
|
||||
RelationshipsMap)
|
||||
import PostgREST.SchemaCache.Routine (Routine (..),
|
||||
RoutineParam (..))
|
||||
|
||||
import PostgREST.Error.Types
|
||||
|
||||
import Protolude
|
||||
|
||||
-- $setup
|
||||
-- >>> import qualified Data.HashMap.Strict as HM
|
||||
-- >>> import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..))
|
||||
-- >>> import PostgREST.SchemaCache.Relationship (Relationship (..))
|
||||
-- >>> import PostgREST.SchemaCache.Routine (Routine (..), RoutineParam (..))
|
||||
|
||||
-- | Encode Error to ByteString
|
||||
errorPayload :: (ErrorBody a, ErrorHeaders a) => Verbosity -> a -> LByteString
|
||||
errorPayload verb = JSON.encode . toJsonPgrstError verb
|
||||
where
|
||||
toJsonPgrstError :: (ErrorBody a, ErrorHeaders a) => Verbosity -> a -> JSON.Value
|
||||
toJsonPgrstError Verbose err = JSON.object [
|
||||
"code" .= code err
|
||||
, "message" .= message err
|
||||
, "details" .= details err
|
||||
, "hint" .= hint err
|
||||
]
|
||||
toJsonPgrstError Minimal err = JSON.object [
|
||||
"code" .= code err
|
||||
, "message" .= message err
|
||||
]
|
||||
|
||||
-- | Create HTTP response from Error
|
||||
errorResponseFor :: (ErrorBody a, ErrorHeaders a) => Verbosity -> a -> Response
|
||||
errorResponseFor verb err =
|
||||
let
|
||||
baseHeader = MediaType.toContentType MTApplicationJSON
|
||||
cLHeader body = (,) "Content-Length" (show $ LBS.length body) :: Header
|
||||
pSHeader code' = ("Proxy-Status", "PostgREST; error=" <> T.encodeUtf8 code')
|
||||
in
|
||||
responseLBS (status err) (baseHeader : cLHeader (errorPayload verb err) : pSHeader (code err) : headers err) $ errorPayload verb err
|
||||
|
||||
class ErrorHeaders a where
|
||||
status :: a -> HTTP.Status
|
||||
headers :: a -> [Header]
|
||||
|
||||
class ErrorBody a where
|
||||
code :: a -> Text
|
||||
message :: a -> Text
|
||||
details :: a -> Maybe JSON.Value
|
||||
hint :: a -> Maybe JSON.Value
|
||||
|
||||
instance ErrorHeaders ApiRequestError where
|
||||
status AggregatesNotAllowed{} = HTTP.status400
|
||||
status MediaTypeError{} = HTTP.status406
|
||||
status InvalidBody{} = HTTP.status400
|
||||
status InvalidFilters = HTTP.status405
|
||||
status InvalidPreferences{} = HTTP.status400
|
||||
status InvalidRpcMethod{} = HTTP.status405
|
||||
status InvalidRange{} = HTTP.status416
|
||||
|
||||
status NotEmbedded{} = HTTP.status400
|
||||
status NotImplemented{} = HTTP.status400
|
||||
status PutLimitNotAllowedError = HTTP.status400
|
||||
status QueryParamError{} = HTTP.status400
|
||||
status RelatedOrderNotToOne{} = HTTP.status400
|
||||
status UnacceptableFilter{} = HTTP.status400
|
||||
status UnacceptableSchema{} = HTTP.status406
|
||||
status UnsupportedMethod{} = HTTP.status405
|
||||
status GucHeadersError = HTTP.status500
|
||||
status GucStatusError = HTTP.status500
|
||||
status PutMatchingPkError = HTTP.status400
|
||||
status SingularityError{} = HTTP.status406
|
||||
status PGRSTParseError{} = HTTP.status500
|
||||
status MaxAffectedViolationError{} = HTTP.status400
|
||||
status InvalidResourcePath = HTTP.status404
|
||||
status OpenAPIDisabled = HTTP.status404
|
||||
status MaxAffectedRpcViolation = HTTP.status400
|
||||
|
||||
headers _ = mempty
|
||||
|
||||
-- Error codes:
|
||||
--
|
||||
-- Error codes are grouped by common modules or characteristics
|
||||
-- New group of errors will be added at the end of all the groups and will have the next prefix in the sequence
|
||||
-- Keep the "PGRST" prefix in every code for an easier search/grep
|
||||
-- They are grouped as following:
|
||||
--
|
||||
-- PGRST0xx -> Connection Error
|
||||
-- PGRST1xx -> ApiRequest Error
|
||||
-- PGRST2xx -> SchemaCache Error
|
||||
-- PGRST3xx -> JWT authentication Error
|
||||
-- PGRSTXxx -> Internal Hasql Error
|
||||
|
||||
instance ErrorBody ApiRequestError where
|
||||
-- CODE: Text
|
||||
code QueryParamError{} = "PGRST100"
|
||||
code InvalidRpcMethod{} = "PGRST101"
|
||||
code InvalidBody{} = "PGRST102"
|
||||
code InvalidRange{} = "PGRST103"
|
||||
-- code ParseRequestError = "PGRST104" -- no longer used
|
||||
code InvalidFilters = "PGRST105"
|
||||
code UnacceptableSchema{} = "PGRST106"
|
||||
code MediaTypeError{} = "PGRST107"
|
||||
code NotEmbedded{} = "PGRST108"
|
||||
-- code LimitNoOrderError = "PGRST109" -- no longer used
|
||||
-- code OffLimitsChangesError = "PGRST110" -- no longer used
|
||||
code GucHeadersError = "PGRST111"
|
||||
code GucStatusError = "PGRST112"
|
||||
-- code BinaryFieldError = "PGRST113" -- no longer used
|
||||
code PutLimitNotAllowedError = "PGRST114"
|
||||
code PutMatchingPkError = "PGRST115"
|
||||
code SingularityError{} = "PGRST116"
|
||||
code UnsupportedMethod{} = "PGRST117"
|
||||
code RelatedOrderNotToOne{} = "PGRST118"
|
||||
-- code SpreadNotToOne = "PGRST109" -- no longer used
|
||||
code UnacceptableFilter{} = "PGRST120"
|
||||
code PGRSTParseError{} = "PGRST121"
|
||||
code InvalidPreferences{} = "PGRST122"
|
||||
code AggregatesNotAllowed = "PGRST123"
|
||||
code MaxAffectedViolationError{} = "PGRST124"
|
||||
code InvalidResourcePath = "PGRST125"
|
||||
code OpenAPIDisabled = "PGRST126"
|
||||
code NotImplemented{} = "PGRST127"
|
||||
code MaxAffectedRpcViolation = "PGRST128"
|
||||
|
||||
-- MESSAGE: Text
|
||||
message (QueryParamError (QPError msg _)) = msg
|
||||
message (InvalidRpcMethod method) = "Cannot use the " <> T.decodeUtf8 method <> " method on RPC"
|
||||
message (InvalidBody errorMessage) = T.decodeUtf8 errorMessage
|
||||
message (InvalidRange _) = "Requested range not satisfiable"
|
||||
message InvalidFilters = "Filters must include all and only primary key columns with 'eq' operators"
|
||||
message (UnacceptableSchema sch _) = "Invalid schema: " <> sch
|
||||
message (MediaTypeError cts) = "None of these media types are available: " <> T.intercalate ", " (map T.decodeUtf8 cts)
|
||||
message (NotEmbedded resource _) = "'" <> resource <> "' is not an embedded resource in this request"
|
||||
message GucHeadersError = "response.headers guc must be a JSON array composed of objects with a single key and a string value"
|
||||
message GucStatusError = "response.status guc must be a valid status code"
|
||||
message PutLimitNotAllowedError = "limit/offset querystring parameters are not allowed for PUT"
|
||||
message PutMatchingPkError = "Payload values do not match URL in primary key column(s)"
|
||||
message (SingularityError _) = "Cannot coerce the result to a single JSON object"
|
||||
message (UnsupportedMethod method) = "Unsupported HTTP method: " <> T.decodeUtf8 method
|
||||
message (RelatedOrderNotToOne _ target) = "A related order on '" <> target <> "' is not possible"
|
||||
message (UnacceptableFilter target) = "Bad operator on the '" <> target <> "' embedded resource"
|
||||
message (PGRSTParseError _) = "Could not parse JSON in the \"RAISE SQLSTATE 'PGRST'\" error"
|
||||
message (InvalidPreferences _) = "Invalid preferences given with handling=strict"
|
||||
message AggregatesNotAllowed = "Use of aggregate functions is not allowed"
|
||||
message (MaxAffectedViolationError _) = "Query result exceeds max-affected preference constraint"
|
||||
message InvalidResourcePath = "Invalid path specified in request URL"
|
||||
message OpenAPIDisabled = "Root endpoint metadata is disabled"
|
||||
message (NotImplemented _) = "Feature not implemented"
|
||||
message MaxAffectedRpcViolation = "Function must return SETOF or TABLE when max-affected preference is used with handling=strict"
|
||||
|
||||
-- DETAILS: Maybe JSON.Value
|
||||
details (QueryParamError (QPError _ dets)) = Just $ JSON.String dets
|
||||
details (InvalidRange rangeError) = Just $
|
||||
case rangeError of
|
||||
NegativeLimit -> "Limit should be greater than or equal to zero."
|
||||
LowerGTUpper -> "The lower boundary must be lower than or equal to the upper boundary in the Range header."
|
||||
OutOfBounds lower total -> JSON.String $ "An offset of " <> lower <> " was requested, but there are only " <> total <> " rows."
|
||||
details (SingularityError n) = Just $ JSON.String $ T.unwords ["The result contains", show n, "rows"]
|
||||
details (RelatedOrderNotToOne origin target) = Just $ JSON.String $ "'" <> origin <> "' and '" <> target <> "' do not form a many-to-one or one-to-one relationship"
|
||||
details (UnacceptableFilter _) = Just "Only is null or not is null filters are allowed on embedded resources"
|
||||
details (PGRSTParseError raiseErr) = Just $ JSON.String $ pgrstParseErrorDetails raiseErr
|
||||
details (InvalidPreferences prefs) = Just $ JSON.String $ T.decodeUtf8 ("Invalid preferences: " <> BS.intercalate ", " prefs)
|
||||
details (MaxAffectedViolationError n) = Just $ JSON.String $ T.unwords ["The query affects", show n, "rows"]
|
||||
details (NotImplemented details') = Just $ JSON.String details'
|
||||
details (NotEmbedded _ (Just _)) = Just $ JSON.String "Target names are not allowed in filters if they have an alias"
|
||||
|
||||
details _ = Nothing
|
||||
|
||||
-- HINT: Maybe JSON.Value
|
||||
hint (NotEmbedded resource Nothing) = Just $ JSON.String $ "Verify that '" <> resource <> "' is included in the 'select' query parameter."
|
||||
hint (NotEmbedded _ (Just (name, alias))) = Just $ JSON.String $ "Change '" <> name <> "' to '" <> alias <> "' in filters, orders or limits."
|
||||
hint (PGRSTParseError raiseErr) = Just $ JSON.String $ pgrstParseErrorHint raiseErr
|
||||
hint (UnacceptableSchema _ schemas) = Just $ JSON.String $ "Only the following schemas are exposed: " <> T.intercalate ", " schemas
|
||||
|
||||
hint _ = Nothing
|
||||
|
||||
instance ErrorHeaders SchemaCacheError where
|
||||
status AmbiguousRelBetween{} = HTTP.status300
|
||||
status AmbiguousRpc{} = HTTP.status300
|
||||
status NoRelBetween{} = HTTP.status400
|
||||
status NoRpc{} = HTTP.status404
|
||||
status ColumnNotFound{} = HTTP.status400
|
||||
status TableNotFound{} = HTTP.status404
|
||||
|
||||
headers _ = mempty
|
||||
|
||||
instance ErrorBody SchemaCacheError where
|
||||
code NoRelBetween{} = "PGRST200"
|
||||
code AmbiguousRelBetween{} = "PGRST201"
|
||||
code NoRpc{} = "PGRST202"
|
||||
code AmbiguousRpc{} = "PGRST203"
|
||||
code ColumnNotFound{} = "PGRST204"
|
||||
code TableNotFound{} = "PGRST205"
|
||||
|
||||
message (NoRelBetween parent child _ _ _) = "Could not find a relationship between '" <> parent <> "' and '" <> child <> "' in the schema cache"
|
||||
message (AmbiguousRelBetween parent child _) = "Could not embed because more than one relationship was found for '" <> parent <> "' and '" <> child <> "'"
|
||||
message (NoRpc schema procName argumentKeys contentType isInvPost _ _) = "Could not find the function " <> func <> (if onlySingleParams then "" else fmtPrms prmsMsg) <> " in the schema cache"
|
||||
where
|
||||
onlySingleParams = isInvPost && contentType `elem` [MTTextPlain, MTTextXML, MTOctetStream]
|
||||
func = schema <> "." <> procName
|
||||
prms = T.intercalate ", " argumentKeys
|
||||
prmsMsg = "(" <> prms <> ")"
|
||||
fmtPrms p = if null argumentKeys then " without parameters" else p
|
||||
message (AmbiguousRpc procs) = "Could not choose the best candidate function between: " <> T.intercalate ", " [pdSchema p <> "." <> pdName p <> "(" <> T.intercalate ", " [ppName a <> " => " <> ppType a | a <- pdParams p] <> ")" | p <- procs]
|
||||
message (ColumnNotFound rel col) = "Could not find the '" <> col <> "' column of '" <> rel <> "' in the schema cache"
|
||||
message (TableNotFound schemaName relName _) = "Could not find the table '" <> schemaName <> "." <> relName <> "' in the schema cache"
|
||||
|
||||
details (NoRelBetween parent child embedHint schema _) = Just $ JSON.String $ "Searched for a foreign key relationship between '" <> parent <> "' and '" <> child <> maybe mempty ("' using the hint '" <>) embedHint <> "' in the schema '" <> schema <> "', but no matches were found."
|
||||
details (AmbiguousRelBetween _ _ rels) = Just $ JSON.toJSONList (compressedRel <$> rels)
|
||||
details (NoRpc schema procName argumentKeys contentType isInvPost _ _) =
|
||||
Just $ JSON.String $ "Searched for the function " <> func <>
|
||||
(case (isInvPost, contentType) of
|
||||
(True, MTTextPlain) -> " with a single unnamed text parameter"
|
||||
(True, MTTextXML) -> " with a single unnamed xml parameter"
|
||||
(True, MTOctetStream) -> " with a single unnamed bytea parameter"
|
||||
(True, MTApplicationJSON) -> fmtPrms prmsDet <> " or with a single unnamed json/jsonb parameter"
|
||||
_ -> fmtPrms prmsDet
|
||||
) <> ", but no matches were found in the schema cache."
|
||||
where
|
||||
func = schema <> "." <> procName
|
||||
prms = T.intercalate ", " argumentKeys
|
||||
prmsDet = " with parameter" <> (if length argumentKeys > 1 then "s " else " ") <> prms
|
||||
fmtPrms p = if null argumentKeys then " without parameters" else p
|
||||
|
||||
details _ = Nothing
|
||||
|
||||
hint (NoRelBetween parent child _ schema allRels) = JSON.String <$> noRelBetweenHint parent child schema allRels
|
||||
hint (AmbiguousRelBetween _ child rels) = Just $ JSON.String $ "Try changing '" <> child <> "' to one of the following: " <> relHint rels <> ". Find the desired relationship in the 'details' key."
|
||||
-- The hint will be null in the case of single unnamed parameter functions
|
||||
hint (NoRpc schema procName argumentKeys contentType isInvPost allProcs overloadedProcs) =
|
||||
if onlySingleParams
|
||||
then Nothing
|
||||
else JSON.String <$> noRpcHint schema procName argumentKeys allProcs overloadedProcs
|
||||
where
|
||||
onlySingleParams = isInvPost && contentType `elem` [MTTextPlain, MTTextXML, MTOctetStream]
|
||||
hint (AmbiguousRpc _) = Just "Try renaming the parameters or the function itself in the database so function overloading can be resolved"
|
||||
hint (TableNotFound schemaName relName schemaCache) = JSON.String <$> tableNotFoundHint schemaName relName schemaCache
|
||||
|
||||
hint _ = Nothing
|
||||
|
||||
-- |
|
||||
-- If no relationship is found then:
|
||||
--
|
||||
-- Looks for parent suggestions if parent not found
|
||||
-- Looks for child suggestions if parent is found but child is not
|
||||
-- Gives no suggestions if both are found (it means that there is a problem with the embed hint)
|
||||
--
|
||||
-- >>> :set -Wno-missing-fields
|
||||
-- >>> let qi t = QualifiedIdentifier "api" t
|
||||
-- >>> let rel ft = Relationship{relForeignTable = qi ft}
|
||||
-- >>> let rels = HM.fromList [((qi "films", "api"), [rel "directors", rel "roles", rel "actors"])]
|
||||
--
|
||||
-- >>> noRelBetweenHint "film" "directors" "api" rels
|
||||
-- Just "Perhaps you meant 'films' instead of 'film'."
|
||||
--
|
||||
-- >>> noRelBetweenHint "films" "role" "api" rels
|
||||
-- Just "Perhaps you meant 'roles' instead of 'role'."
|
||||
--
|
||||
-- >>> noRelBetweenHint "films" "actors" "api" rels
|
||||
-- Nothing
|
||||
--
|
||||
-- >>> noRelBetweenHint "noclosealternative" "roles" "api" rels
|
||||
-- Nothing
|
||||
--
|
||||
-- >>> noRelBetweenHint "films" "noclosealternative" "api" rels
|
||||
-- Nothing
|
||||
--
|
||||
-- >>> noRelBetweenHint "films" "noclosealternative" "noclosealternative" rels
|
||||
-- Nothing
|
||||
--
|
||||
noRelBetweenHint :: Text -> Text -> Schema -> RelationshipsMap -> Maybe Text
|
||||
noRelBetweenHint parent child schema allRels = ("Perhaps you meant '" <>) <$>
|
||||
if isJust findParent
|
||||
then (<> "' instead of '" <> child <> "'.") <$> suggestChild
|
||||
else (<> "' instead of '" <> parent <> "'.") <$> suggestParent
|
||||
where
|
||||
findParent = HM.lookup (QualifiedIdentifier schema parent, schema) allRels
|
||||
fuzzySetOfParents = Fuzzy.fromList [qiName (fst p) | p <- HM.keys allRels, snd p == schema]
|
||||
fuzzySetOfChildren = Fuzzy.fromList [qiName (relForeignTable c) | c <- fromMaybe [] findParent]
|
||||
suggestParent = Fuzzy.getOne fuzzySetOfParents parent
|
||||
-- Do not give suggestion if the child is found in the relations (weight = 1.0)
|
||||
suggestChild = headMay [snd k | k <- Fuzzy.get fuzzySetOfChildren child, fst k < 1.0]
|
||||
|
||||
-- |
|
||||
-- If no function is found with the given name, it does a fuzzy search to all the functions
|
||||
-- in the same schema and shows the best match as hint.
|
||||
--
|
||||
-- >>> :set -Wno-missing-fields
|
||||
-- >>> let procs = [(QualifiedIdentifier "api" "test"), (QualifiedIdentifier "api" "another"), (QualifiedIdentifier "private" "other")]
|
||||
--
|
||||
-- >>> noRpcHint "api" "testt" ["val", "param", "name"] procs []
|
||||
-- Just "Perhaps you meant to call the function api.test"
|
||||
--
|
||||
-- >>> noRpcHint "api" "other" [] procs []
|
||||
-- Nothing
|
||||
--
|
||||
-- >>> noRpcHint "api" "noclosealternative" [] procs []
|
||||
-- Nothing
|
||||
--
|
||||
-- If a function is found with the given name, but no params match, then it does a fuzzy search
|
||||
-- to all the overloaded functions' params using the form "param1, param2, param3, ..."
|
||||
-- and shows the best match as hint.
|
||||
--
|
||||
-- >>> let procsDesc = [Function {pdParams = [RoutineParam {ppName="val"}, RoutineParam {ppName="param"}, RoutineParam {ppName="name"}]}, Function {pdParams = [RoutineParam {ppName="id"}, RoutineParam {ppName="attr"}]}]
|
||||
--
|
||||
-- >>> noRpcHint "api" "test" ["vall", "pqaram", "nam"] procs procsDesc
|
||||
-- Just "Perhaps you meant to call the function api.test(name, param, val)"
|
||||
--
|
||||
-- >>> noRpcHint "api" "test" ["val", "param"] procs procsDesc
|
||||
-- Just "Perhaps you meant to call the function api.test(name, param, val)"
|
||||
--
|
||||
-- >>> noRpcHint "api" "test" ["id", "attrs"] procs procsDesc
|
||||
-- Just "Perhaps you meant to call the function api.test(attr, id)"
|
||||
--
|
||||
-- >>> noRpcHint "api" "test" ["id"] procs procsDesc
|
||||
-- Just "Perhaps you meant to call the function api.test(attr, id)"
|
||||
--
|
||||
-- >>> noRpcHint "api" "test" ["noclosealternative"] procs procsDesc
|
||||
-- Nothing
|
||||
--
|
||||
noRpcHint :: Text -> Text -> [Text] -> [QualifiedIdentifier] -> [Routine] -> Maybe Text
|
||||
noRpcHint schema procName params allProcs overloadedProcs =
|
||||
fmap (("Perhaps you meant to call the function " <> schema <> ".") <>) possibleProcs
|
||||
where
|
||||
fuzzySetOfProcs = Fuzzy.fromList [qiName k | k <- allProcs, qiSchema k == schema]
|
||||
fuzzySetOfParams = Fuzzy.fromList $ listToText <$> [[ppName prm | prm <- pdParams ov] | ov <- overloadedProcs]
|
||||
-- Cannot do a fuzzy search like: Fuzzy.getOne [[Text]] [Text], where [[Text]] is the list of params for each
|
||||
-- overloaded function and [Text] the given params. This converts those lists to text to make fuzzy search possible.
|
||||
-- E.g. ["val", "param", "name"] into "(name, param, val)"
|
||||
listToText = ("(" <>) . (<> ")") . T.intercalate ", " . sort
|
||||
possibleProcs
|
||||
| null overloadedProcs = getFuzzyHint HintProcedure fuzzySetOfProcs procName
|
||||
| otherwise = (procName <>) <$> getFuzzyHint HintParams fuzzySetOfParams (listToText params)
|
||||
|
||||
-- |
|
||||
-- Do a fuzzy search in all tables in the same schema and return closest result
|
||||
tableNotFoundHint :: Text -> Text -> SchemaCache -> Maybe Text
|
||||
tableNotFoundHint schema tblName SchemaCache{dbTablesFuzzyIndex}
|
||||
= fmap (\tbl -> "Perhaps you meant the table '" <> schema <> "." <> tbl <> "'") perhapsTable
|
||||
where
|
||||
perhapsTable = (\fuzzySet -> getFuzzyHint HintTable fuzzySet tblName) =<< HM.lookup schema dbTablesFuzzyIndex
|
||||
|
||||
data HintType
|
||||
= HintTable
|
||||
| HintProcedure
|
||||
| HintParams
|
||||
|
||||
-- | Get hint using Fuzzy Search with at least 0.75 similarity score
|
||||
getFuzzyHint :: HintType -> Fuzzy.FuzzySet -> Text -> Maybe Text
|
||||
getFuzzyHint hintType =
|
||||
let minScore = 0.75 :: Double -- used for table and procedure name hints
|
||||
in case hintType of
|
||||
HintTable -> Fuzzy.getOneWithMinScore minScore
|
||||
HintProcedure -> Fuzzy.getOneWithMinScore minScore
|
||||
HintParams -> Fuzzy.getOne -- For params, we stick to `getOne` which defaults to 0.33 min score, not a security risk to reveal params
|
||||
|
||||
compressedRel :: Relationship -> JSON.Value
|
||||
-- An ambiguousness error cannot happen for computed relationships TODO refactor so this mempty is not needed
|
||||
compressedRel ComputedRelationship{} = JSON.object mempty
|
||||
compressedRel Relationship{..} =
|
||||
let
|
||||
fmtEls els = "(" <> T.intercalate ", " els <> ")"
|
||||
in
|
||||
JSON.object $
|
||||
("embedding" .= (qiName relTable <> " with " <> qiName relForeignTable :: Text))
|
||||
: case relCardinality of
|
||||
M2M Junction{..} -> [
|
||||
"cardinality" .= ("many-to-many" :: Text)
|
||||
, "relationship" .= (qiName junTable <> " using " <> junConstraint1 <> fmtEls (snd <$> junColsSource) <> " and " <> junConstraint2 <> fmtEls (snd <$> junColsTarget))
|
||||
]
|
||||
M2O cons relColumns -> [
|
||||
"cardinality" .= ("many-to-one" :: Text)
|
||||
, "relationship" .= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns))
|
||||
]
|
||||
O2O cons relColumns _ -> [
|
||||
"cardinality" .= ("one-to-one" :: Text)
|
||||
, "relationship" .= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns))
|
||||
]
|
||||
O2M cons relColumns -> [
|
||||
"cardinality" .= ("one-to-many" :: Text)
|
||||
, "relationship" .= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns))
|
||||
]
|
||||
|
||||
relHint :: [Relationship] -> Text
|
||||
relHint rels = T.intercalate ", " (hintList <$> rels)
|
||||
where
|
||||
hintList Relationship{..} =
|
||||
let buildHint rel = "'" <> qiName relForeignTable <> "!" <> rel <> "'" in
|
||||
case relCardinality of
|
||||
M2M Junction{..} -> buildHint (qiName junTable)
|
||||
M2O cons _ -> buildHint cons
|
||||
O2O cons _ _ -> buildHint cons
|
||||
O2M cons _ -> buildHint cons
|
||||
-- An ambiguousness error cannot happen for computed relationships TODO refactor so this mempty is not needed
|
||||
hintList ComputedRelationship{} = mempty
|
||||
|
||||
pgrstParseErrorDetails :: RaiseError -> Text
|
||||
pgrstParseErrorDetails err = case err of
|
||||
MsgParseError m -> "Invalid JSON value for MESSAGE: '" <> T.decodeUtf8 m <> "'"
|
||||
DetParseError d -> "Invalid JSON value for DETAIL: '" <> T.decodeUtf8 d <> "'"
|
||||
NoDetail -> "DETAIL is missing in the RAISE statement"
|
||||
|
||||
pgrstParseErrorHint :: RaiseError -> Text
|
||||
pgrstParseErrorHint err = case err of
|
||||
MsgParseError _ -> "MESSAGE must be a JSON object with obligatory keys: 'code', 'message' and optional keys: 'details', 'hint'."
|
||||
_ -> "DETAIL must be a JSON object with obligatory keys: 'status', 'headers' and optional key: 'status_text'."
|
||||
|
||||
instance ErrorHeaders PgError where
|
||||
status (PgError authed usageError) = pgErrorStatus authed usageError
|
||||
|
||||
headers (PgError _ (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError (SQL.ServerError "PGRST" m d _ _p))))) =
|
||||
case parseRaisePGRST m d of
|
||||
Right (_, r) -> map intoHeader (M.toList $ getHeaders r)
|
||||
Left e -> headers e
|
||||
where
|
||||
intoHeader (k,v) = (CI.mk $ T.encodeUtf8 k, T.encodeUtf8 v)
|
||||
|
||||
headers err =
|
||||
if status err == HTTP.status401
|
||||
then [("WWW-Authenticate", "Bearer") :: Header]
|
||||
else mempty
|
||||
|
||||
instance ErrorBody PgError where
|
||||
code (PgError _ usageError) = code usageError
|
||||
message (PgError _ usageError) = message usageError
|
||||
details (PgError _ usageError) = details usageError
|
||||
hint (PgError _ usageError) = hint usageError
|
||||
|
||||
instance ErrorBody SQL.UsageError where
|
||||
code (SQL.ConnectionUsageError _) = "PGRST000"
|
||||
code (SQL.SessionUsageError (SQL.PipelineError e)) = code e
|
||||
code (SQL.SessionUsageError (SQL.QueryError _ _ e)) = code e
|
||||
code SQL.AcquisitionTimeoutUsageError = "PGRST003"
|
||||
|
||||
message (SQL.ConnectionUsageError _) = "Database connection error."
|
||||
message (SQL.SessionUsageError (SQL.PipelineError e)) = message e
|
||||
message (SQL.SessionUsageError (SQL.QueryError _ _ e)) = message e
|
||||
message SQL.AcquisitionTimeoutUsageError = "Timed out acquiring connection from connection pool."
|
||||
|
||||
details (SQL.ConnectionUsageError e) = JSON.String . T.decodeUtf8 <$> e
|
||||
details (SQL.SessionUsageError (SQL.PipelineError e)) = details e
|
||||
details (SQL.SessionUsageError (SQL.QueryError _ _ e)) = details e
|
||||
details SQL.AcquisitionTimeoutUsageError = Nothing
|
||||
|
||||
hint (SQL.ConnectionUsageError _) = Nothing
|
||||
hint (SQL.SessionUsageError (SQL.PipelineError e)) = hint e
|
||||
hint (SQL.SessionUsageError (SQL.QueryError _ _ e)) = hint e
|
||||
hint SQL.AcquisitionTimeoutUsageError = Nothing
|
||||
|
||||
instance ErrorBody SQL.CommandError where
|
||||
-- Special error raised with code PGRST, to allow full response control
|
||||
code (SQL.ResultError (SQL.ServerError "PGRST" m d _ _)) =
|
||||
case parseRaisePGRST m d of
|
||||
Right (r, _) -> getCode r
|
||||
Left e -> code e
|
||||
code (SQL.ResultError (SQL.ServerError c _ _ _ _)) = T.decodeUtf8 c
|
||||
|
||||
code (SQL.ResultError _) = "PGRSTX00" -- Internal Error
|
||||
|
||||
code (SQL.ClientError _) = "PGRST001"
|
||||
|
||||
message (SQL.ResultError (SQL.ServerError "PGRST" m d _ _)) =
|
||||
case parseRaisePGRST m d of
|
||||
Right (r, _) -> getMessage r
|
||||
Left e -> message e
|
||||
message (SQL.ResultError (SQL.ServerError _ m _ _ _)) = T.decodeUtf8 m
|
||||
message (SQL.ResultError resultError) = show resultError -- We never really return this error, because we kill pgrst thread early in App.hs
|
||||
message (SQL.ClientError _) = "Database client error. Retrying the connection."
|
||||
|
||||
details (SQL.ResultError (SQL.ServerError "PGRST" m d _ _)) =
|
||||
case parseRaisePGRST m d of
|
||||
Right (r, _) -> JSON.String <$> getDetails r
|
||||
Left e -> details e
|
||||
details (SQL.ResultError (SQL.ServerError _ _ d _ _)) = JSON.String . T.decodeUtf8 <$> d
|
||||
details (SQL.ClientError d) = JSON.String . T.decodeUtf8 <$> d
|
||||
|
||||
details _ = Nothing
|
||||
|
||||
hint (SQL.ResultError (SQL.ServerError "PGRST" m d _ _p)) =
|
||||
case parseRaisePGRST m d of
|
||||
Right (r, _) -> JSON.String <$> getHint r
|
||||
Left e -> hint e
|
||||
hint (SQL.ResultError (SQL.ServerError _ _ _ h _)) = JSON.String . T.decodeUtf8 <$> h
|
||||
|
||||
hint _ = Nothing
|
||||
|
||||
|
||||
pgErrorStatus :: Bool -> SQL.UsageError -> HTTP.Status
|
||||
pgErrorStatus _ (SQL.ConnectionUsageError _) = HTTP.status503
|
||||
pgErrorStatus _ SQL.AcquisitionTimeoutUsageError = HTTP.status504
|
||||
pgErrorStatus _ (SQL.SessionUsageError (SQL.PipelineError (SQL.ClientError _))) = HTTP.status503
|
||||
pgErrorStatus _ (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ClientError _))) = HTTP.status503
|
||||
pgErrorStatus authed (SQL.SessionUsageError (SQL.PipelineError (SQL.ResultError rError))) = mapSQLtoHTTP authed rError
|
||||
pgErrorStatus authed (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError rError))) = mapSQLtoHTTP authed rError
|
||||
|
||||
mapSQLtoHTTP :: Bool -> SQL.ResultError -> HTTP.Status
|
||||
mapSQLtoHTTP authed rError =
|
||||
case rError of
|
||||
(SQL.ServerError c m d _ _) ->
|
||||
case BS.unpack c of
|
||||
'0':'8':_ -> HTTP.status503 -- pg connection err
|
||||
'0':'9':_ -> HTTP.status500 -- triggered action exception
|
||||
'0':'L':_ -> HTTP.status403 -- invalid grantor
|
||||
'0':'P':_ -> HTTP.status403 -- invalid role specification
|
||||
"23503" -> HTTP.status409 -- foreign_key_violation
|
||||
"23505" -> HTTP.status409 -- unique_violation
|
||||
"25006" -> HTTP.status405 -- read_only_sql_transaction
|
||||
"21000" -> -- cardinality_violation
|
||||
if BS.isSuffixOf "requires a WHERE clause" m
|
||||
then HTTP.status400 -- special case for pg-safeupdate, which we consider as client error
|
||||
else HTTP.status500 -- generic function or view server error, e.g. "more than one row returned by a subquery used as an expression"
|
||||
"22023" -> -- invalid_parameter_value. Catch nonexistent role error, see https://github.com/PostgREST/postgrest/issues/3601
|
||||
if BS.isPrefixOf "role" m && BS.isSuffixOf "does not exist" m
|
||||
then HTTP.status401 -- role in jwt does not exist
|
||||
else HTTP.status400
|
||||
'2':'5':_ -> HTTP.status500 -- invalid tx state
|
||||
'2':'8':_ -> HTTP.status403 -- invalid auth specification
|
||||
'2':'D':_ -> HTTP.status500 -- invalid tx termination
|
||||
'3':'8':_ -> HTTP.status500 -- external routine exception
|
||||
'3':'9':_ -> HTTP.status500 -- external routine invocation
|
||||
'3':'B':_ -> HTTP.status500 -- savepoint exception
|
||||
'4':'0':_ -> HTTP.status500 -- tx rollback
|
||||
"53400" -> HTTP.status500 -- config limit exceeded
|
||||
'5':'3':_ -> HTTP.status503 -- insufficient resources
|
||||
'5':'4':_ -> HTTP.status500 -- too complex
|
||||
'5':'5':_ -> HTTP.status500 -- obj not on prereq state
|
||||
"57P01" -> HTTP.status503 -- terminating connection due to administrator command
|
||||
'5':'7':_ -> HTTP.status500 -- operator intervention
|
||||
'5':'8':_ -> HTTP.status500 -- system error
|
||||
'F':'0':_ -> HTTP.status500 -- conf file error
|
||||
'H':'V':_ -> HTTP.status500 -- foreign data wrapper error
|
||||
"P0001" -> HTTP.status400 -- default code for "raise"
|
||||
'P':'0':_ -> HTTP.status500 -- PL/pgSQL Error
|
||||
'X':'X':_ -> HTTP.status500 -- internal Error
|
||||
"42883"-> if BS.isPrefixOf "function xmlagg(" m
|
||||
then HTTP.status406
|
||||
else HTTP.status404 -- undefined function
|
||||
"42P01" -> HTTP.status404 -- undefined table
|
||||
"42P17" -> HTTP.status500 -- infinite recursion
|
||||
"42501" -> if authed then HTTP.status403 else HTTP.status401 -- insufficient privilege
|
||||
'P':'T':n -> fromMaybe HTTP.status500 (HTTP.mkStatus <$> readMaybe n <*> pure m)
|
||||
"PGRST" ->
|
||||
case parseRaisePGRST m d of
|
||||
Right (_, r) -> maybe (toEnum $ getStatus r) (HTTP.mkStatus (getStatus r) . T.encodeUtf8) (getStatusText r)
|
||||
Left e -> status e
|
||||
_ -> HTTP.status400
|
||||
|
||||
_ -> HTTP.status500
|
||||
|
||||
|
||||
instance ErrorHeaders Error where
|
||||
status (ApiRequestErr err) = status err
|
||||
status (SchemaCacheErr err) = status err
|
||||
status (JwtErr err) = status err
|
||||
status NoSchemaCacheError = HTTP.status503
|
||||
status (PgErr err) = status err
|
||||
|
||||
headers (ApiRequestErr err) = headers err
|
||||
headers (SchemaCacheErr err) = headers err
|
||||
headers (JwtErr err) = headers err
|
||||
headers (PgErr err) = headers err
|
||||
headers NoSchemaCacheError = mempty
|
||||
|
||||
instance ErrorBody Error where
|
||||
code (ApiRequestErr err) = code err
|
||||
code (SchemaCacheErr err) = code err
|
||||
code (JwtErr err) = code err
|
||||
code NoSchemaCacheError = "PGRST002"
|
||||
code (PgErr err) = code err
|
||||
|
||||
message (ApiRequestErr err) = message err
|
||||
message (SchemaCacheErr err) = message err
|
||||
message (JwtErr err) = message err
|
||||
message NoSchemaCacheError = "Could not query the database for the schema cache. Retrying."
|
||||
message (PgErr err) = message err
|
||||
|
||||
details (ApiRequestErr err) = details err
|
||||
details (SchemaCacheErr err) = details err
|
||||
details (JwtErr err) = details err
|
||||
details NoSchemaCacheError = Nothing
|
||||
details (PgErr err) = details err
|
||||
|
||||
hint (ApiRequestErr err) = hint err
|
||||
hint (SchemaCacheErr err) = hint err
|
||||
hint (JwtErr err) = hint err
|
||||
hint NoSchemaCacheError = Nothing
|
||||
hint (PgErr err) = hint err
|
||||
|
||||
instance ErrorHeaders JwtError where
|
||||
status JwtDecodeErr{} = HTTP.unauthorized401
|
||||
status JwtSecretMissing = HTTP.status500
|
||||
status JwtTokenRequired = HTTP.unauthorized401
|
||||
status JwtClaimsErr{} = HTTP.unauthorized401
|
||||
|
||||
headers e@(JwtDecodeErr _) = [invalidTokenHeader $ message e]
|
||||
headers JwtTokenRequired = [requiredTokenHeader]
|
||||
headers e@(JwtClaimsErr _) = [invalidTokenHeader $ message e]
|
||||
headers _ = mempty
|
||||
|
||||
instance ErrorBody JwtError where
|
||||
code JwtSecretMissing = "PGRST300"
|
||||
code (JwtDecodeErr _) = "PGRST301"
|
||||
code JwtTokenRequired = "PGRST302"
|
||||
code (JwtClaimsErr _) = "PGRST303"
|
||||
|
||||
message JwtSecretMissing = "Server lacks JWT secret"
|
||||
message (JwtDecodeErr e) = case e of
|
||||
EmptyAuthHeader -> "Empty JWT is sent in Authorization header"
|
||||
UnexpectedParts n -> "Expected 3 parts in JWT; got " <> show n
|
||||
KeyError _ -> "No suitable key or wrong key type"
|
||||
BadAlgorithm _ -> "Wrong or unsupported encoding algorithm"
|
||||
BadCrypto -> "JWT cryptographic operation failed"
|
||||
UnsupportedTokenType -> "Unsupported token type"
|
||||
UnreachableDecodeError -> "JWT couldn't be decoded"
|
||||
message JwtTokenRequired = "Anonymous access is disabled"
|
||||
message (JwtClaimsErr e) = case e of
|
||||
JWTExpired -> "JWT expired"
|
||||
JWTNotYetValid -> "JWT not yet valid"
|
||||
JWTIssuedAtFuture -> "JWT issued at future"
|
||||
JWTNotInAudience -> "JWT not in audience"
|
||||
ParsingClaimsFailed -> "Parsing claims failed"
|
||||
ExpClaimNotNumber -> "The JWT 'exp' claim must be a number"
|
||||
NbfClaimNotNumber -> "The JWT 'nbf' claim must be a number"
|
||||
IatClaimNotNumber -> "The JWT 'iat' claim must be a number"
|
||||
AudClaimNotStringOrArray -> "The JWT 'aud' claim must be a string or an array of strings"
|
||||
|
||||
details (JwtDecodeErr jde) = case jde of
|
||||
KeyError dets -> Just $ JSON.String dets
|
||||
BadAlgorithm dets -> Just $ JSON.String dets
|
||||
_ -> Nothing
|
||||
details _ = Nothing
|
||||
|
||||
hint _ = Nothing
|
||||
|
||||
invalidTokenHeader :: Text -> Header
|
||||
invalidTokenHeader m =
|
||||
("WWW-Authenticate", "Bearer error=\"invalid_token\", " <> "error_description=" <> encodeUtf8 (show m))
|
||||
|
||||
requiredTokenHeader :: Header
|
||||
requiredTokenHeader = ("WWW-Authenticate", "Bearer")
|
||||
|
||||
-- For parsing byteString to JSON Object, used for allowing full response control
|
||||
|
||||
instance JSON.FromJSON PgRaiseErrMessage where
|
||||
parseJSON (JSON.Object m) =
|
||||
PgRaiseErrMessage
|
||||
<$> m .: "code"
|
||||
<*> m .: "message"
|
||||
<*> m .:? "details"
|
||||
<*> m .:? "hint"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
instance JSON.FromJSON PgRaiseErrDetails where
|
||||
parseJSON (JSON.Object d) =
|
||||
PgRaiseErrDetails
|
||||
<$> d .: "status"
|
||||
<*> d .:? "status_text"
|
||||
<*> d .: "headers"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
parseRaisePGRST :: ByteString -> Maybe ByteString -> Either ApiRequestError (PgRaiseErrMessage, PgRaiseErrDetails)
|
||||
parseRaisePGRST m d = do
|
||||
msgJson <- maybeToRight (PGRSTParseError $ MsgParseError m) (JSON.decodeStrict m)
|
||||
det <- maybeToRight (PGRSTParseError NoDetail) d
|
||||
detJson <- maybeToRight (PGRSTParseError $ DetParseError det) (JSON.decodeStrict det)
|
||||
return (msgJson, detJson)
|
||||
@@ -0,0 +1,138 @@
|
||||
{-|
|
||||
Module : PostgREST.Error.Types
|
||||
Description : PostgREST Error Data Types
|
||||
-}
|
||||
module PostgREST.Error.Types
|
||||
( ApiRequestError(..)
|
||||
, QPError(..)
|
||||
, RangeError(..)
|
||||
, RaiseError(..)
|
||||
, SchemaCacheError(..)
|
||||
, PgError(..)
|
||||
, Error(..)
|
||||
, JwtError (..)
|
||||
, JwtDecodeError(..)
|
||||
, JwtClaimsError(..)
|
||||
, PgRaiseErrMessage(..)
|
||||
, PgRaiseErrDetails(..)
|
||||
) where
|
||||
|
||||
import qualified Hasql.Pool as SQL
|
||||
|
||||
import PostgREST.MediaType (MediaType (..))
|
||||
import PostgREST.SchemaCache (SchemaCache (..))
|
||||
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..))
|
||||
import PostgREST.SchemaCache.Relationship (Relationship (..),
|
||||
RelationshipsMap)
|
||||
import PostgREST.SchemaCache.Routine (Routine (..))
|
||||
import Protolude
|
||||
|
||||
data Error
|
||||
= ApiRequestErr ApiRequestError
|
||||
| SchemaCacheErr SchemaCacheError
|
||||
| JwtErr JwtError
|
||||
| NoSchemaCacheError
|
||||
| PgErr PgError
|
||||
deriving Show
|
||||
|
||||
-- API REQUEST ERRORS: PGRST1XX
|
||||
data ApiRequestError
|
||||
= AggregatesNotAllowed
|
||||
| MediaTypeError [ByteString]
|
||||
| InvalidBody ByteString
|
||||
| InvalidFilters
|
||||
| InvalidPreferences [ByteString]
|
||||
| InvalidRange RangeError
|
||||
| InvalidRpcMethod ByteString
|
||||
| NotEmbedded Text (Maybe (Text, Text))
|
||||
| NotImplemented Text
|
||||
| PutLimitNotAllowedError
|
||||
| QueryParamError QPError
|
||||
| RelatedOrderNotToOne Text Text
|
||||
| UnacceptableFilter Text
|
||||
| UnacceptableSchema Text [Text]
|
||||
| UnsupportedMethod ByteString
|
||||
| GucHeadersError
|
||||
| GucStatusError
|
||||
| PutMatchingPkError
|
||||
| SingularityError Integer
|
||||
| PGRSTParseError RaiseError
|
||||
| MaxAffectedViolationError Integer
|
||||
| InvalidResourcePath
|
||||
| OpenAPIDisabled
|
||||
| MaxAffectedRpcViolation
|
||||
deriving Show
|
||||
|
||||
data QPError = QPError Text Text
|
||||
deriving Show
|
||||
|
||||
data RaiseError
|
||||
= MsgParseError ByteString
|
||||
| DetParseError ByteString
|
||||
| NoDetail
|
||||
deriving Show
|
||||
|
||||
data RangeError
|
||||
= NegativeLimit
|
||||
| LowerGTUpper
|
||||
| OutOfBounds Text Text
|
||||
deriving Show
|
||||
|
||||
-- SCHEMA CACHE ERRORS: PGRST2XX
|
||||
data SchemaCacheError
|
||||
= AmbiguousRelBetween Text Text [Relationship]
|
||||
| AmbiguousRpc [Routine]
|
||||
| NoRelBetween Text Text (Maybe Text) Text RelationshipsMap
|
||||
| NoRpc Text Text [Text] MediaType Bool [QualifiedIdentifier] [Routine]
|
||||
| ColumnNotFound Text Text
|
||||
| TableNotFound Text Text SchemaCache
|
||||
deriving Show
|
||||
|
||||
-- JWT ERRORS: PGRST3XX
|
||||
data JwtError
|
||||
= JwtDecodeErr JwtDecodeError
|
||||
| JwtSecretMissing
|
||||
| JwtTokenRequired
|
||||
| JwtClaimsErr JwtClaimsError
|
||||
deriving Show
|
||||
|
||||
data JwtDecodeError
|
||||
= EmptyAuthHeader
|
||||
| UnexpectedParts Int
|
||||
| KeyError Text
|
||||
| BadAlgorithm Text
|
||||
| BadCrypto
|
||||
| UnsupportedTokenType
|
||||
| UnreachableDecodeError
|
||||
deriving Show
|
||||
|
||||
data JwtClaimsError
|
||||
= JWTExpired
|
||||
| JWTNotYetValid
|
||||
| JWTIssuedAtFuture
|
||||
| JWTNotInAudience
|
||||
| ParsingClaimsFailed
|
||||
| ExpClaimNotNumber
|
||||
| NbfClaimNotNumber
|
||||
| IatClaimNotNumber
|
||||
| AudClaimNotStringOrArray
|
||||
deriving Show
|
||||
|
||||
-- PG ERRORS
|
||||
type Authenticated = Bool
|
||||
data PgError = PgError Authenticated SQL.UsageError
|
||||
deriving Show
|
||||
|
||||
-- For parsing byteString to JSON Object, used for allowing full response control
|
||||
data PgRaiseErrMessage = PgRaiseErrMessage {
|
||||
getCode :: Text,
|
||||
getMessage :: Text,
|
||||
getDetails :: Maybe Text,
|
||||
getHint :: Maybe Text
|
||||
}
|
||||
|
||||
data PgRaiseErrDetails = PgRaiseErrDetails {
|
||||
getStatus :: Int,
|
||||
getStatusText :: Maybe Text,
|
||||
getHeaders :: Map Text Text
|
||||
}
|
||||
@@ -0,0 +1,118 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module PostgREST.Listener (runListener) where
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
import qualified Hasql.Connection as SQL
|
||||
import qualified Hasql.Notifications as SQL
|
||||
import PostgREST.AppState (AppState, getConfig)
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.Observation (Observation (..))
|
||||
|
||||
import qualified PostgREST.AppState as AppState
|
||||
import qualified PostgREST.Config as Config
|
||||
|
||||
import Control.Arrow ((&&&))
|
||||
import Data.Bitraversable (bisequence)
|
||||
import Data.Either.Combinators (whenRight)
|
||||
import Data.IORef (IORef, newIORef,
|
||||
readIORef, writeIORef)
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.PostgreSQL.LibPQ as LibPQ
|
||||
import qualified Hasql.Session as SQL
|
||||
import PostgREST.Config.Database (queryPgVersion)
|
||||
import PostgREST.Config.PgVersion (pgvFullName)
|
||||
import Protolude
|
||||
|
||||
-- | Starts the Listener in a thread
|
||||
runListener :: AppState -> IO ()
|
||||
runListener appState = do
|
||||
AppConfig{..} <- getConfig appState
|
||||
when configDbChannelEnabled $ do
|
||||
nextDelay <- newIORef 1
|
||||
void . forkIO . void $ retryingListen appState nextDelay False
|
||||
|
||||
-- | Starts a LISTEN connection and handles notifications. It recovers with exponential backoff with a cap of 32 seconds, if the LISTEN connection is lost.
|
||||
-- | This function never returns (but can throw) and return type enforces that.
|
||||
retryingListen :: AppState -> IORef Int -> Bool -> IO Void
|
||||
retryingListen appState nextDelay hasDbListenerBug = do
|
||||
cfg@AppConfig{..} <- AppState.getConfig appState
|
||||
let
|
||||
dbChannel = toS configDbChannel
|
||||
onError err = do
|
||||
AppState.putIsListenerOn appState False
|
||||
observer $ DBListenFail dbChannel (Right err)
|
||||
when (isDbListenerBug err) $
|
||||
observer DBListenBugCallQueryFix
|
||||
unless configDbPoolAutomaticRecovery $
|
||||
AppState.killApp appState
|
||||
|
||||
-- retry the listener
|
||||
delay <- readIORef nextDelay
|
||||
observer $ DBListenRetry delay
|
||||
threadDelay (delay * oneSecondInMicro)
|
||||
unless (delay == maxDelay) $
|
||||
writeIORef nextDelay (delay * 2)
|
||||
-- loop running the listener
|
||||
retryingListen appState nextDelay (isDbListenerBug err)
|
||||
|
||||
-- Execute the listener with error handling
|
||||
handle onError $ do
|
||||
-- Make sure we don't leak connections on errors
|
||||
bracket
|
||||
-- acquire connection
|
||||
(SQL.acquire $
|
||||
Config.toConnectionSettings Config.addTargetSessionAttrs cfg)
|
||||
-- release connection
|
||||
(`whenRight` releaseConnection) $
|
||||
-- use connection
|
||||
\case
|
||||
Right db -> do
|
||||
(pqHost, pqPort) <- SQL.withLibPQConnection db $ bisequence . (LibPQ.host &&& LibPQ.port)
|
||||
pgFullName <- SQL.run queryPgVersion db >>= either throwIO (pure . pgvFullName)
|
||||
when hasDbListenerBug $ SQL.run callNotifQueryUsage db >>= either throwIO pure
|
||||
SQL.listen db $ SQL.toPgIdentifier dbChannel
|
||||
|
||||
AppState.putIsListenerOn appState True
|
||||
|
||||
delay <- readIORef nextDelay
|
||||
when (delay > 1) $ do -- if we did a retry
|
||||
-- assume we lost notifications, refresh the schema cache
|
||||
AppState.schemaCacheLoader appState
|
||||
-- reset the delay
|
||||
writeIORef nextDelay 1
|
||||
|
||||
observer $ DBListenStart pqHost pqPort pgFullName dbChannel
|
||||
|
||||
-- wait for notifications
|
||||
-- this will never return, in case of an error it will throw and be caught by onError
|
||||
forever $ SQL.waitForNotifications handleNotification db
|
||||
|
||||
Left err -> do
|
||||
observer $ DBListenFail dbChannel (Left err)
|
||||
exitFailure
|
||||
where
|
||||
observer = AppState.getObserver appState
|
||||
oneSecondInMicro = 1_000_000
|
||||
maxDelay = 32
|
||||
|
||||
handleNotification channel msg =
|
||||
if | BS.null msg -> observer (DBListenerGotSCacheMsg channel) >> cacheReloader
|
||||
| msg == "reload schema" -> observer (DBListenerGotSCacheMsg channel) >> cacheReloader
|
||||
| msg == "reload config" -> observer (DBListenerGotConfigMsg channel) >> AppState.readInDbConfig False appState
|
||||
| otherwise -> pure () -- Do nothing if anything else than an empty message is sent
|
||||
|
||||
cacheReloader =
|
||||
AppState.schemaCacheLoader appState
|
||||
|
||||
releaseConnection = void . forkIO . handle (observer . DBListenerConnectionCleanupFail) . SQL.release
|
||||
|
||||
isDbListenerBug e = "could not access status of transaction" `T.isInfixOf` show e
|
||||
|
||||
-- Used to fix a Postgres bug in the listener, see: https://github.com/PostgREST/postgrest/issues/3147#issuecomment-3494591361
|
||||
-- This query advances the async notification query tail, which solves this issue.
|
||||
callNotifQueryUsage :: SQL.Session ()
|
||||
callNotifQueryUsage = SQL.sql "SELECT pg_notification_queue_usage();"
|
||||
@@ -0,0 +1,259 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{-|
|
||||
Module : PostgREST.Logger
|
||||
Description : Logging based on the Observation.hs module. Access logs get sent to stdout and server diagnostic get sent to stderr.
|
||||
-}
|
||||
-- TODO log with buffering enabled to not lose throughput on logging levels higher than LogError
|
||||
module PostgREST.Logger
|
||||
(observationLogger
|
||||
, init
|
||||
, LoggerState
|
||||
) where
|
||||
|
||||
import Control.AutoUpdate (defaultUpdateSettings,
|
||||
mkAutoUpdate,
|
||||
updateAction)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Hasql.Decoders as HD
|
||||
import qualified Hasql.DynamicStatements.Snippet as SQL hiding (sql)
|
||||
import qualified Hasql.DynamicStatements.Statement as SQL
|
||||
import qualified Hasql.Statement as SQL
|
||||
|
||||
import Data.Time (ZonedTime, defaultTimeLocale, formatTime,
|
||||
getZonedTime)
|
||||
|
||||
import Network.HTTP.Types.Status (Status, status400, status500)
|
||||
|
||||
import PostgREST.Config (LogLevel (..), Verbosity (..))
|
||||
import PostgREST.Debounce (makeDebouncer)
|
||||
import PostgREST.Logger.Apache (apacheFormat)
|
||||
import PostgREST.Observation
|
||||
import PostgREST.Query (MainQuery (..))
|
||||
import PostgREST.SchemaCache (queryTimingsWLabels)
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.Text as T
|
||||
import qualified Hasql.Connection as SQL
|
||||
import qualified Hasql.Pool as SQL
|
||||
import qualified Hasql.Pool.Observation as SQL
|
||||
import Numeric (showFFloat)
|
||||
import PostgREST.Config.PgVersion (pgvName)
|
||||
import qualified PostgREST.Error as Error
|
||||
import Protolude
|
||||
|
||||
data LoggerState = LoggerState
|
||||
{ stateGetZTime :: IO ZonedTime -- ^ Time with time zone used for logs
|
||||
, stateLogDebouncePoolTimeout :: IO () -- ^ Logs with a debounce
|
||||
}
|
||||
|
||||
init :: IO LoggerState
|
||||
init = mdo
|
||||
let
|
||||
oneSecond = 1_000_000
|
||||
loggerState = LoggerState zTime debouncePoolTimeout
|
||||
zTime <- mkAutoUpdate defaultUpdateSettings { updateAction = getZonedTime }
|
||||
debouncePoolTimeout <- makeDebouncer $
|
||||
logWithZTime loggerState (observationMessages PoolAcqTimeoutObs) *> threadDelay (5 * oneSecond)
|
||||
pure loggerState
|
||||
|
||||
shouldLogResponse :: LogLevel -> Status -> Bool
|
||||
shouldLogResponse logLevel = case logLevel of
|
||||
LogCrit -> const False
|
||||
LogError -> (>= status500)
|
||||
LogWarn -> (>= status400)
|
||||
LogInfo -> const True
|
||||
LogDebug -> const True
|
||||
|
||||
-- All observations are logged except some that depend on the log-level
|
||||
observationLogger :: LoggerState -> LogLevel -> ObservationHandler
|
||||
observationLogger loggerState logLevel obs = case obs of
|
||||
PoolAcqTimeoutObs -> do
|
||||
when (logLevel >= LogError) $
|
||||
stateLogDebouncePoolTimeout loggerState
|
||||
o@(QueryErrorCodeHighObs _) -> do
|
||||
when (logLevel >= LogError) $ do
|
||||
logWithZTime loggerState $ observationMessages o
|
||||
o@SchemaCacheEmptyObs ->
|
||||
when (logLevel >= LogError) $ do
|
||||
logWithZTime loggerState $ observationMessages o
|
||||
o@(HasqlPoolObs _) -> do
|
||||
when (logLevel >= LogDebug) $ do
|
||||
logWithZTime loggerState $ observationMessages o
|
||||
o@(QueryObs _ status) -> do
|
||||
when (shouldLogResponse logLevel status) $
|
||||
logWithZTime loggerState $ observationMessages o
|
||||
o@PoolRequest ->
|
||||
when (logLevel >= LogDebug) $ do
|
||||
logWithZTime loggerState $ observationMessages o
|
||||
o@PoolRequestFullfilled ->
|
||||
when (logLevel >= LogDebug) $ do
|
||||
logWithZTime loggerState $ observationMessages o
|
||||
ResponseObs maybeRole req status contentLen ->
|
||||
when (shouldLogResponse logLevel status) $ do
|
||||
zTime <- stateGetZTime loggerState
|
||||
putStr $ apacheFormat maybeRole (BS.pack $ formatZonedTime zTime) req status contentLen -- putStr prints to stdout
|
||||
o@PoolFlushed ->
|
||||
when (logLevel >= LogDebug) $ do
|
||||
logWithZTime loggerState $ observationMessages o
|
||||
o@JwtCacheEviction ->
|
||||
when (logLevel >= LogDebug) $ do
|
||||
logWithZTime loggerState $ observationMessages o
|
||||
o@(JwtCacheLookup _) ->
|
||||
when (logLevel >= LogDebug) $ do
|
||||
logWithZTime loggerState $ observationMessages o
|
||||
o@(WarpServerObs _) ->
|
||||
when (logLevel >= LogDebug) $ do
|
||||
logWithZTime loggerState $ observationMessages o
|
||||
o ->
|
||||
logWithZTime loggerState $ observationMessages o
|
||||
|
||||
logWithZTime :: LoggerState -> [Text] -> IO ()
|
||||
logWithZTime loggerState txts = do
|
||||
zTime <- stateGetZTime loggerState
|
||||
let prefix = toS (formatZonedTime zTime) <> ": "
|
||||
traverse_ (hPutStrLn stderr . (prefix <>)) txts
|
||||
|
||||
formatZonedTime :: ZonedTime -> [Char]
|
||||
formatZonedTime = formatTime defaultTimeLocale "%d/%b/%Y:%T %z"
|
||||
|
||||
-- TODO: maybe patch upstream hasql-dynamic-statements so we have a less hackish way to convert
|
||||
-- the SQL.Snippet or maybe don't use hasql-dynamic-statements and resort to plain strings for the queries and use regular hasql
|
||||
renderSnippet :: SQL.Snippet -> ByteString
|
||||
renderSnippet snippet =
|
||||
let SQL.Statement sql _ _ _ = SQL.dynamicallyParameterized snippet decoder False
|
||||
decoder = HD.noResult -- unused
|
||||
in
|
||||
sql
|
||||
|
||||
observationMessages :: Observation -> [Text]
|
||||
observationMessages = \case
|
||||
AdminStartObs address ->
|
||||
pure $ "Admin server listening on " <> address
|
||||
AdminServerCrashedObs ex ->
|
||||
pure $ "FAILURE: Admin server crashed unexpectedly: " <> (showOnSingleLine '\t' . show) ex
|
||||
AppStartObs ver ->
|
||||
pure $ "Starting PostgREST " <> T.decodeUtf8 ver <> "..."
|
||||
AppServerAddressObs address ->
|
||||
pure $ "API server listening on " <> address
|
||||
DBConnectedObs ver ->
|
||||
pure $ "Successfully connected to " <> ver
|
||||
ExitUnsupportedPgVersion pgVer minPgVer ->
|
||||
pure $ "Cannot run in this PostgreSQL version (" <> pgvName pgVer <> "), PostgREST needs at least " <> pgvName minPgVer
|
||||
ExitDBNoRecoveryObs ->
|
||||
pure "Automatic recovery disabled, exiting."
|
||||
ExitDBFatalError ServerAuthError usageErr ->
|
||||
pure $ "Failed to establish a connection. " <> jsonMessage usageErr
|
||||
ExitDBFatalError ServerPgrstBug usageErr ->
|
||||
pure $ "This is probably a bug in PostgREST, please report it at https://github.com/PostgREST/postgrest/issues. " <> jsonMessage usageErr
|
||||
ExitDBFatalError ServerError42P05 usageErr ->
|
||||
pure $ "If you are using connection poolers in transaction mode, try setting db-prepared-statements to false. " <> jsonMessage usageErr
|
||||
ExitDBFatalError ServerError08P01 usageErr ->
|
||||
pure $ "Connection poolers in statement mode are not supported." <> jsonMessage usageErr
|
||||
SchemaCacheEmptyObs ->
|
||||
pure $ T.decodeUtf8 . LBS.toStrict . Error.errorPayload Verbose $ Error.NoSchemaCacheError
|
||||
SchemaCacheErrorObs dbSchemas extraPaths usageErr ->
|
||||
pure $ "Failed to load the schema cache using "
|
||||
<> "db-schemas=" <> T.intercalate "," (toList dbSchemas)
|
||||
<> " and "
|
||||
<> "db-extra-search-path=" <> T.intercalate "," extraPaths
|
||||
<> ". " <> jsonMessage usageErr
|
||||
SchemaCacheQueriedObs resultTime timings ->
|
||||
[ "Schema cache queried in " <> showMillis resultTime <> " milliseconds " ] <>
|
||||
let showTimings qt = [ T.intercalate ", " $ (\(l, v) -> T.decodeUtf8 l <> ": " <> v <> " ms") <$> queryTimingsWLabels qt ] in
|
||||
maybe mempty showTimings timings
|
||||
SchemaCacheLoadedObs resultTime summary ->
|
||||
[
|
||||
"Schema cache loaded " <> summary
|
||||
, "Schema cache loaded in " <> showMillis resultTime <> " milliseconds"
|
||||
]
|
||||
ConnectionRetryObs delay ->
|
||||
pure $ "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..."
|
||||
QueryPgVersionError usageErr ->
|
||||
pure $ "Failed to query the PostgreSQL version. " <> jsonMessage usageErr
|
||||
DBListenStart host port fullName channel -> do
|
||||
pure $ "Listener connected to " <> fullName <> " on " <> show (fold $ host <> fmap (":" <>) port) <> " and listening for database notifications on the " <> show channel <> " channel"
|
||||
DBListenFail channel listenErr ->
|
||||
pure $ "Failed listening for database notifications on the " <> show channel <> " channel. " <>
|
||||
either showListenerConnError showListenerException listenErr
|
||||
DBListenRetry delay ->
|
||||
pure $ "Retrying listening for database notifications in " <> (show delay::Text) <> " seconds..."
|
||||
DBListenBugCallQueryFix ->
|
||||
pure "This is likely a PostgreSQL bug in the notification queue, executing the following to try to solve it: SELECT pg_notification_queue_usage();"
|
||||
DBListenerGotSCacheMsg channel ->
|
||||
pure $ "Received a schema cache reload message on the " <> show channel <> " channel"
|
||||
DBListenerGotConfigMsg channel ->
|
||||
pure $ "Received a config reload message on the " <> show channel <> " channel"
|
||||
DBListenerConnectionCleanupFail ex ->
|
||||
pure $ "Failed during listener connection cleanup: " <> showOnSingleLine '\t' (show ex)
|
||||
(QueryObs MainQuery{mqOpenAPI=(x, y, z),..} _) ->
|
||||
let snipts = renderSnippet <$> [mqTxVars, fromMaybe mempty mqPreReq, mqMain, x, y, z, fromMaybe mempty mqExplain]
|
||||
in
|
||||
showOnSingleLine '\n' . T.decodeUtf8 <$> filter (/= mempty) snipts
|
||||
LegacyTargetNameWarningObs (warningMsg, warningHints) requestMethod requestTarget ->
|
||||
[ "WARNING: " <> warningMsg
|
||||
, "Update filters, orders or limits that use " <> warningHints <> " in " <> "`" <> T.decodeUtf8 (requestMethod <> " " <> requestTarget) <> "`"
|
||||
]
|
||||
ConfigReadErrorObs usageErr ->
|
||||
pure $ "Failed to query database settings for the config parameters." <> jsonMessage usageErr
|
||||
QueryRoleSettingsErrorObs usageErr ->
|
||||
pure $ "Failed to query the role settings. " <> jsonMessage usageErr
|
||||
QueryErrorCodeHighObs usageErr ->
|
||||
pure $ jsonMessage usageErr
|
||||
ConfigInvalidObs err ->
|
||||
pure $ "Failed reloading config: " <> err
|
||||
ConfigSucceededObs ->
|
||||
pure "Config reloaded"
|
||||
PoolInit poolSize ->
|
||||
pure $ "Connection Pool initialized with a maximum size of " <> show poolSize <> " connections"
|
||||
PoolAcqTimeoutObs -> pure $ jsonMessage SQL.AcquisitionTimeoutUsageError
|
||||
HasqlPoolObs (SQL.ConnectionObservation uuid status) ->
|
||||
pure $ "Connection " <> show uuid <> (
|
||||
case status of
|
||||
SQL.ConnectingConnectionStatus -> " is being established"
|
||||
SQL.ReadyForUseConnectionStatus reason -> " is available due to " <> case reason of
|
||||
SQL.EstablishedConnectionReadyForUseReason -> "connection establishment"
|
||||
SQL.SessionFailedConnectionReadyForUseReason _ -> "session failure"
|
||||
SQL.SessionSucceededConnectionReadyForUseReason -> "session success"
|
||||
SQL.InUseConnectionStatus -> " is used"
|
||||
SQL.TerminatedConnectionStatus reason -> " is terminated due to " <> case reason of
|
||||
SQL.AgingConnectionTerminationReason -> "max lifetime"
|
||||
SQL.IdlenessConnectionTerminationReason -> "max idletime"
|
||||
SQL.ReleaseConnectionTerminationReason -> "release"
|
||||
SQL.NetworkErrorConnectionTerminationReason _ -> "network error" -- usage error is already logged, no need to repeat the same message.
|
||||
SQL.InitializationErrorTerminationReason _ -> "init failure"
|
||||
)
|
||||
PoolRequest ->
|
||||
pure "Trying to borrow a connection from pool"
|
||||
PoolRequestFullfilled ->
|
||||
pure "Borrowed a connection from the pool"
|
||||
PoolFlushed ->
|
||||
pure "Database connection pool flushed"
|
||||
JwtCacheLookup _ ->
|
||||
pure "Looked up a JWT in JWT cache"
|
||||
JwtCacheEviction ->
|
||||
pure "Evicted entry from JWT cache"
|
||||
TerminationUnixSignalObs signal ->
|
||||
pure $ "Received termination unix signal " <> signal
|
||||
WarpServerObs txt ->
|
||||
pure $ "Warp server: " <> txt
|
||||
ResponseObs {} ->
|
||||
mempty -- Control flow never reaches here, the observation message is returned in observationLogger function
|
||||
where
|
||||
showMillis :: Double -> Text
|
||||
showMillis x = toS $ showFFloat (Just 1) x ""
|
||||
|
||||
jsonMessage err = T.decodeUtf8 . LBS.toStrict . Error.errorPayload Verbose $ Error.PgError False err
|
||||
|
||||
|
||||
showListenerConnError :: SQL.ConnectionError -> Text
|
||||
showListenerConnError = maybe "Connection error" (showOnSingleLine '\t' . T.decodeUtf8)
|
||||
|
||||
showListenerException :: SomeException -> Text
|
||||
showListenerException = showOnSingleLine '\t' . show
|
||||
|
||||
|
||||
showOnSingleLine :: Char -> Text -> Text
|
||||
showOnSingleLine split txt = T.intercalate " " $ T.filter (/= split) <$> T.lines txt -- the errors from hasql-notifications come intercalated with "\t\n"
|
||||
@@ -0,0 +1,48 @@
|
||||
module PostgREST.Logger.Apache
|
||||
( apacheFormat
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Network.Wai.Logger
|
||||
import System.Log.FastLogger
|
||||
|
||||
import Network.HTTP.Types.Status (Status, statusCode)
|
||||
import Network.Wai
|
||||
|
||||
import Protolude
|
||||
|
||||
apacheFormat :: ToLogStr user => Maybe user -> FormattedTime -> Request -> Status -> Maybe Integer -> ByteString
|
||||
apacheFormat maybeUser tmstr req status msize =
|
||||
fromLogStr $ apacheLogStr maybeUser tmstr req status msize
|
||||
|
||||
-- This code is vendored from
|
||||
-- https://github.com/kazu-yamamoto/logger/blob/57bc4d3b26ca094fd0c3a8a8bb4421bcdcdd7061/wai-logger/Network/Wai/Logger/Apache.hs#L44-L45
|
||||
apacheLogStr :: ToLogStr user => Maybe user -> FormattedTime -> Request -> Status -> Maybe Integer -> LogStr
|
||||
apacheLogStr maybeUser tmstr req status msize =
|
||||
toLogStr (getSourceFromSocket req)
|
||||
<> " - "
|
||||
<> maybe "-" toLogStr maybeUser
|
||||
<> " ["
|
||||
<> toLogStr tmstr
|
||||
<> "] \""
|
||||
<> toLogStr (requestMethod req)
|
||||
<> " "
|
||||
<> toLogStr path
|
||||
<> " "
|
||||
<> toLogStr (show (httpVersion req)::Text)
|
||||
<> "\" "
|
||||
<> toLogStr (show (statusCode status)::Text)
|
||||
<> " "
|
||||
<> toLogStr (maybe "-" show msize::Text)
|
||||
<> " \""
|
||||
<> toLogStr (fromMaybe "" mr)
|
||||
<> "\" \""
|
||||
<> toLogStr (fromMaybe "" mua)
|
||||
<> "\"\n"
|
||||
where
|
||||
path = rawPathInfo req <> rawQueryString req
|
||||
mr = requestHeaderReferer req
|
||||
mua = requestHeaderUserAgent req
|
||||
|
||||
getSourceFromSocket :: Request -> ByteString
|
||||
getSourceFromSocket = BS.pack . showSockAddr . remoteHost
|
||||
@@ -0,0 +1,273 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-|
|
||||
Module : PostgREST.MainTx
|
||||
Description : PostgREST transaction executor
|
||||
|
||||
This module parametrizes, prepares, executes SQL queries and decodes their results.
|
||||
-}
|
||||
module PostgREST.MainTx
|
||||
( MainTx (..)
|
||||
, DbResult (..)
|
||||
, ResultSet (..)
|
||||
, mainTx
|
||||
) where
|
||||
|
||||
import Control.Lens ((^?))
|
||||
import Control.Monad.Extra (whenJust)
|
||||
import qualified Data.Aeson.Lens as L
|
||||
import qualified Data.ByteString as BS hiding
|
||||
(break)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Set as S
|
||||
import qualified Hasql.Decoders as HD
|
||||
import qualified Hasql.DynamicStatements.Statement as SQL
|
||||
import qualified Hasql.Session as SQL (Session)
|
||||
import qualified Hasql.Transaction as SQL
|
||||
import qualified Hasql.Transaction.Sessions as SQL
|
||||
|
||||
import qualified PostgREST.Error as Error
|
||||
import qualified PostgREST.SchemaCache as SchemaCache
|
||||
|
||||
|
||||
import PostgREST.ApiRequest (ApiRequest (..))
|
||||
import PostgREST.ApiRequest.Preferences (PreferCount (..),
|
||||
PreferHandling (..),
|
||||
PreferMaxAffected (..),
|
||||
PreferTransaction (..),
|
||||
Preferences (..))
|
||||
import PostgREST.ApiRequest.Types (Mutation (..))
|
||||
import PostgREST.Auth.Types (AuthResult (..))
|
||||
import PostgREST.Config (AppConfig (..),
|
||||
OpenAPIMode (..))
|
||||
import PostgREST.Error (Error)
|
||||
import PostgREST.MediaType (MediaType (..))
|
||||
import PostgREST.Plan (ActionPlan (..),
|
||||
CrudPlan (..),
|
||||
DbActionPlan (..),
|
||||
InfoPlan (..),
|
||||
InspectPlan (..))
|
||||
import PostgREST.Query (MainQuery (..))
|
||||
import PostgREST.SchemaCache (SchemaCache (..))
|
||||
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..))
|
||||
import PostgREST.SchemaCache.Routine (Routine (..), RoutineMap)
|
||||
import PostgREST.SchemaCache.Table (TablesMap)
|
||||
|
||||
import Protolude hiding (Handler)
|
||||
|
||||
type DbHandler = ExceptT Error SQL.Transaction
|
||||
|
||||
data MainTx
|
||||
= DbTx (SQL.Session (Either Error DbResult))
|
||||
| NoDbTx DbResult
|
||||
|
||||
data DbResult
|
||||
= DbCrudResult CrudPlan ResultSet
|
||||
| DbPlanResult MediaType BS.ByteString
|
||||
| MaybeDbResult InspectPlan (Maybe (TablesMap, RoutineMap, Maybe Text))
|
||||
| NoDbResult InfoPlan
|
||||
|
||||
-- | Standard result set format used for the mqMain query
|
||||
data ResultSet
|
||||
= RSStandard
|
||||
{ rsTableTotal :: Maybe Int64
|
||||
-- ^ count of all the table rows
|
||||
, rsQueryTotal :: Int64
|
||||
-- ^ count of the query rows
|
||||
, rsLocation :: [(BS.ByteString, BS.ByteString)]
|
||||
-- ^ The Location header(only used for inserts) is represented as a list of strings containing
|
||||
-- variable bindings like @"k1=eq.42"@, or the empty list if there is no location header.
|
||||
, rsBody :: BS.ByteString
|
||||
-- ^ the aggregated body of the query
|
||||
, rsGucHeaders :: Maybe BS.ByteString
|
||||
-- ^ the HTTP headers to be added to the response
|
||||
, rsGucStatus :: Maybe Text
|
||||
-- ^ the HTTP status to be added to the response
|
||||
, rsInserted :: Maybe Int64
|
||||
-- ^ the number of rows inserted (Only used for upserts)
|
||||
}
|
||||
|
||||
mainTx :: MainQuery -> AppConfig -> AuthResult -> ApiRequest -> ActionPlan -> SchemaCache -> MainTx
|
||||
mainTx _ _ _ _ (NoDb x) _ = NoDbTx $ NoDbResult x
|
||||
mainTx genQ@MainQuery{..} conf@AppConfig{..} AuthResult{..} apiReq (Db plan) sCache =
|
||||
DbTx $ SQL.transactionNoRetry isoLvl txMode $ runExceptT dbHandler
|
||||
where
|
||||
isoLvl = planIsoLvl conf authRole plan
|
||||
txMode = planTxMode plan
|
||||
dbHandler = do
|
||||
lift $ SQL.statement mempty $ SQL.dynamicallyParameterized mqTxVars
|
||||
HD.noResult configDbPreparedStatements
|
||||
lift $ whenJust mqPreReq $ \q ->
|
||||
SQL.statement mempty $ SQL.dynamicallyParameterized q
|
||||
HD.noResult configDbPreparedStatements
|
||||
actionResult genQ plan conf apiReq sCache
|
||||
|
||||
planTxMode :: DbActionPlan -> SQL.Mode
|
||||
planTxMode (DbCrud _ x) = pTxMode x
|
||||
planTxMode (MayUseDb x) = ipTxmode x
|
||||
|
||||
planIsoLvl :: AppConfig -> ByteString -> DbActionPlan -> SQL.IsolationLevel
|
||||
planIsoLvl AppConfig{configRoleIsoLvl} role actPlan = case actPlan of
|
||||
DbCrud _ CallReadPlan{crProc} -> fromMaybe roleIsoLvl $ pdIsoLvl crProc
|
||||
_ -> roleIsoLvl
|
||||
where
|
||||
roleIsoLvl = HM.findWithDefault SQL.ReadCommitted role configRoleIsoLvl
|
||||
|
||||
actionResult :: MainQuery -> DbActionPlan -> AppConfig -> ApiRequest -> SchemaCache -> ExceptT Error SQL.Transaction DbResult
|
||||
actionResult MainQuery{..} (DbCrud True plan) conf@AppConfig{..} apiReq _ = do
|
||||
explRes <- lift $ SQL.statement mempty $ SQL.dynamicallyParameterized mqMain planRow configDbPreparedStatements
|
||||
optionalRollback conf apiReq
|
||||
pure $ DbPlanResult (pMedia plan) explRes
|
||||
|
||||
actionResult MainQuery{..} (DbCrud _ plan@WrappedReadPlan{..}) conf@AppConfig{..} apiReq@ApiRequest{iPreferences=Preferences{..}} _ = do
|
||||
resultSet@RSStandard{rsTableTotal=tableTotal} <- lift $ SQL.statement mempty $ dynStmt (HD.singleRow $ standardRow True)
|
||||
failNotSingular pMedia resultSet
|
||||
optionalRollback conf apiReq
|
||||
explainTotal <- lift . fmap join $ traverse (\snip ->
|
||||
SQL.statement mempty $ SQL.dynamicallyParameterized snip decodeExplain configDbPreparedStatements)
|
||||
mqExplain
|
||||
|
||||
pure $ DbCrudResult plan
|
||||
resultSet{rsTableTotal=case preferCount of
|
||||
Just PlannedCount -> explainTotal
|
||||
Just EstimatedCount -> if tableTotal > (fromIntegral <$> configDbMaxRows)
|
||||
then max <$> tableTotal <*> explainTotal
|
||||
else tableTotal
|
||||
_ -> tableTotal}
|
||||
where
|
||||
dynStmt decod = SQL.dynamicallyParameterized mqMain decod configDbPreparedStatements
|
||||
|
||||
decodeExplain :: HD.Result (Maybe Int64)
|
||||
decodeExplain =
|
||||
let row = HD.singleRow $ column HD.bytea in
|
||||
(^? L.nth 0 . L.key "Plan" . L.key "Plan Rows" . L._Integral) <$> row
|
||||
|
||||
actionResult MainQuery{..} (DbCrud _ plan@MutateReadPlan{..}) conf@AppConfig{..} apiReq@ApiRequest{iPreferences=Preferences{..}} _ = do
|
||||
resultSet <- lift $ SQL.statement mempty $ dynStmt decodeRow
|
||||
failMutation resultSet
|
||||
optionalRollback conf apiReq
|
||||
pure $ DbCrudResult plan resultSet
|
||||
where
|
||||
dynStmt decod = SQL.dynamicallyParameterized mqMain decod configDbPreparedStatements
|
||||
failMutation resultSet = case mrMutation of
|
||||
MutationCreate -> do
|
||||
failNotSingular pMedia resultSet
|
||||
MutationUpdate -> do
|
||||
failNotSingular pMedia resultSet
|
||||
failExceedsMaxAffectedPref (preferMaxAffected,preferHandling) resultSet
|
||||
MutationSingleUpsert -> do
|
||||
failPut resultSet
|
||||
MutationDelete -> do
|
||||
failNotSingular pMedia resultSet
|
||||
failExceedsMaxAffectedPref (preferMaxAffected,preferHandling) resultSet
|
||||
decodeRow = fromMaybe (RSStandard Nothing 0 mempty mempty Nothing Nothing Nothing) <$> HD.rowMaybe (standardRow False)
|
||||
|
||||
actionResult MainQuery{..} (DbCrud _ plan@CallReadPlan{..}) conf@AppConfig{..} apiReq@ApiRequest{iPreferences=Preferences{..}} _ = do
|
||||
resultSet <- lift $ SQL.statement mempty $ dynStmt decodeRow
|
||||
optionalRollback conf apiReq
|
||||
failNotSingular pMedia resultSet
|
||||
failExceedsMaxAffectedPref (preferMaxAffected,preferHandling) resultSet
|
||||
pure $ DbCrudResult plan resultSet
|
||||
where
|
||||
dynStmt decod = SQL.dynamicallyParameterized mqMain decod configDbPreparedStatements
|
||||
decodeRow = fromMaybe (RSStandard (Just 0) 0 mempty mempty Nothing Nothing Nothing) <$> HD.rowMaybe (standardRow True)
|
||||
|
||||
actionResult MainQuery{mqOpenAPI=(tblsQ, funcsQ, schQ)} (MayUseDb plan@InspectPlan{ipSchema=tSchema}) AppConfig{..} _ sCache =
|
||||
mainActionQuery
|
||||
where
|
||||
mainActionQuery = lift $
|
||||
case configOpenApiMode of
|
||||
OAFollowPriv -> do
|
||||
tableAccess <- SQL.statement mempty $ SQL.dynamicallyParameterized tblsQ decodeAccessibleIdentifiers configDbPreparedStatements
|
||||
accFuncs <- SQL.statement mempty $ SQL.dynamicallyParameterized funcsQ SchemaCache.decodeFuncs configDbPreparedStatements
|
||||
schDesc <- SQL.statement mempty $ SQL.dynamicallyParameterized schQ decodeSchemaDesc configDbPreparedStatements
|
||||
let tbls = HM.filterWithKey (\qi _ -> S.member qi tableAccess) $ SchemaCache.dbTables sCache
|
||||
|
||||
pure $ MaybeDbResult plan (Just (tbls, accFuncs, schDesc))
|
||||
OAIgnorePriv -> do
|
||||
schDesc <- SQL.statement mempty (SQL.dynamicallyParameterized schQ decodeSchemaDesc configDbPreparedStatements)
|
||||
|
||||
let tbls = HM.filterWithKey (\(QualifiedIdentifier sch _) _ -> sch == tSchema) (SchemaCache.dbTables sCache)
|
||||
routs = HM.filterWithKey (\(QualifiedIdentifier sch _) _ -> sch == tSchema) (SchemaCache.dbRoutines sCache)
|
||||
|
||||
pure $ MaybeDbResult plan (Just (tbls, routs, schDesc))
|
||||
OADisabled ->
|
||||
pure $ MaybeDbResult plan Nothing
|
||||
|
||||
decodeSchemaDesc :: HD.Result (Maybe Text)
|
||||
decodeSchemaDesc = join <$> HD.rowMaybe (nullableColumn HD.text)
|
||||
|
||||
decodeAccessibleIdentifiers :: HD.Result (S.Set QualifiedIdentifier)
|
||||
decodeAccessibleIdentifiers =
|
||||
let
|
||||
row = QualifiedIdentifier
|
||||
<$> column HD.text
|
||||
<*> column HD.text
|
||||
in
|
||||
S.fromList <$> HD.rowList row
|
||||
|
||||
-- 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
|
||||
failPut :: ResultSet -> DbHandler ()
|
||||
failPut RSStandard{rsQueryTotal=queryTotal} =
|
||||
when (queryTotal /= 1) $ do
|
||||
lift SQL.condemn
|
||||
throwError $ Error.ApiRequestErr Error.PutMatchingPkError
|
||||
|
||||
-- |
|
||||
-- Fail a response if a single JSON object was requested and not exactly one
|
||||
-- was found.
|
||||
failNotSingular :: MediaType -> ResultSet -> DbHandler ()
|
||||
failNotSingular mediaType RSStandard{rsQueryTotal=queryTotal} =
|
||||
when (elem mediaType [MTVndSingularJSON True, MTVndSingularJSON False] && queryTotal /= 1) $ do
|
||||
lift SQL.condemn
|
||||
throwError $ Error.ApiRequestErr . Error.SingularityError $ toInteger queryTotal
|
||||
|
||||
failExceedsMaxAffectedPref :: (Maybe PreferMaxAffected, Maybe PreferHandling) -> ResultSet -> DbHandler ()
|
||||
failExceedsMaxAffectedPref (Nothing,_) _ = pure ()
|
||||
failExceedsMaxAffectedPref (Just (PreferMaxAffected n), handling) RSStandard{rsQueryTotal=queryTotal} = when ((queryTotal > n) && (handling == Just Strict)) $ do
|
||||
lift SQL.condemn
|
||||
throwError $ Error.ApiRequestErr . Error.MaxAffectedViolationError $ toInteger queryTotal
|
||||
|
||||
-- | Set a transaction to roll back if requested
|
||||
optionalRollback :: AppConfig -> ApiRequest -> DbHandler ()
|
||||
optionalRollback AppConfig{..} ApiRequest{iPreferences=Preferences{..}} = do
|
||||
lift $ when (shouldRollback || (configDbTxRollbackAll && not shouldCommit)) $ do
|
||||
SQL.sql "SET CONSTRAINTS ALL IMMEDIATE"
|
||||
SQL.condemn
|
||||
where
|
||||
shouldCommit =
|
||||
preferTransaction == Just Commit
|
||||
shouldRollback =
|
||||
preferTransaction == Just Rollback
|
||||
|
||||
-- | We use rowList because when doing EXPLAIN (FORMAT TEXT), the result comes as many rows. FORMAT JSON comes as one.
|
||||
planRow :: HD.Result BS.ByteString
|
||||
planRow = BS.unlines <$> HD.rowList (column HD.bytea)
|
||||
|
||||
column :: HD.Value a -> HD.Row a
|
||||
column = HD.column . HD.nonNullable
|
||||
|
||||
nullableColumn :: HD.Value a -> HD.Row (Maybe a)
|
||||
nullableColumn = HD.column . HD.nullable
|
||||
|
||||
arrayColumn :: HD.Value a -> HD.Row [a]
|
||||
arrayColumn = column . HD.listArray . HD.nonNullable
|
||||
|
||||
standardRow :: Bool -> HD.Row ResultSet
|
||||
standardRow noLocation =
|
||||
RSStandard <$> nullableColumn HD.int8 <*> column HD.int8
|
||||
<*> (if noLocation then pure mempty else fmap splitKeyValue <$> arrayColumn HD.bytea)
|
||||
<*> (fromMaybe mempty <$> nullableColumn HD.bytea)
|
||||
<*> nullableColumn HD.bytea
|
||||
<*> nullableColumn HD.text
|
||||
<*> nullableColumn HD.int8
|
||||
where
|
||||
splitKeyValue :: ByteString -> (ByteString, ByteString)
|
||||
splitKeyValue kv =
|
||||
let (k, v) = BS.break (== '=') kv in
|
||||
(k, BS.tail v)
|
||||
@@ -0,0 +1,213 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# OPTIONS_GHC -Wno-unused-do-bind #-}
|
||||
module PostgREST.MediaType
|
||||
( MediaType(..)
|
||||
, MTVndPlanOption (..)
|
||||
, MTVndPlanFormat (..)
|
||||
, toContentType
|
||||
, toMime
|
||||
, decodeMediaType
|
||||
, tokenizeMediaType
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Text as T
|
||||
import qualified Text.ParserCombinators.Parsec as P
|
||||
|
||||
import Data.Map (fromList, (!?))
|
||||
import Data.Text.Encoding (decodeLatin1)
|
||||
import Network.HTTP.Types.Header (Header, hContentType)
|
||||
|
||||
import Protolude
|
||||
|
||||
-- $setup
|
||||
-- >>> import qualified Text.ParserCombinators.Parsec as P
|
||||
|
||||
-- | Enumeration of currently supported media types
|
||||
data MediaType
|
||||
= MTApplicationJSON
|
||||
| MTGeoJSON
|
||||
| MTTextCSV
|
||||
| MTTextPlain
|
||||
| MTTextXML
|
||||
| MTOpenAPI
|
||||
| MTUrlEncoded
|
||||
| MTOctetStream
|
||||
| MTAny
|
||||
| MTOther Text
|
||||
-- vendored media types
|
||||
| MTVndArrayJSONStrip
|
||||
| MTVndSingularJSON Bool
|
||||
-- TODO MTVndPlan should only have its options as [Text]. Its ResultAggregate should have the typed attributes.
|
||||
| MTVndPlan MediaType MTVndPlanFormat [MTVndPlanOption]
|
||||
deriving (Eq, Show, Generic, JSON.ToJSON)
|
||||
instance Hashable MediaType
|
||||
|
||||
data MTVndPlanOption
|
||||
= PlanAnalyze | PlanVerbose | PlanSettings | PlanBuffers | PlanWAL
|
||||
deriving (Eq, Show, Generic, JSON.ToJSON)
|
||||
instance Hashable MTVndPlanOption
|
||||
|
||||
data MTVndPlanFormat
|
||||
= PlanJSON | PlanText
|
||||
deriving (Eq, Show, Generic, JSON.ToJSON)
|
||||
instance Hashable MTVndPlanFormat
|
||||
|
||||
-- | Convert MediaType to a Content-Type HTTP Header
|
||||
toContentType :: MediaType -> Header
|
||||
toContentType ct = (hContentType, toMime ct <> charset)
|
||||
where
|
||||
charset = case ct of
|
||||
MTOctetStream -> mempty
|
||||
MTOther _ -> mempty
|
||||
_ -> "; charset=utf-8"
|
||||
|
||||
-- | Convert from MediaType to a ByteString representing the mime type
|
||||
toMime :: MediaType -> ByteString
|
||||
toMime MTApplicationJSON = "application/json"
|
||||
toMime MTVndArrayJSONStrip = "application/vnd.pgrst.array+json;nulls=stripped"
|
||||
toMime MTGeoJSON = "application/geo+json"
|
||||
toMime MTTextCSV = "text/csv"
|
||||
toMime MTTextPlain = "text/plain"
|
||||
toMime MTTextXML = "text/xml"
|
||||
toMime MTOpenAPI = "application/openapi+json"
|
||||
toMime (MTVndSingularJSON True) = "application/vnd.pgrst.object+json;nulls=stripped"
|
||||
toMime (MTVndSingularJSON False) = "application/vnd.pgrst.object+json"
|
||||
toMime MTUrlEncoded = "application/x-www-form-urlencoded"
|
||||
toMime MTOctetStream = "application/octet-stream"
|
||||
toMime MTAny = "*/*"
|
||||
toMime (MTOther ct) = encodeUtf8 ct
|
||||
toMime (MTVndPlan mt fmt opts) =
|
||||
"application/vnd.pgrst.plan+" <> toMimePlanFormat fmt <>
|
||||
("; for=\"" <> toMime mt <> "\"") <>
|
||||
(if null opts then mempty else "; options=" <> BS.intercalate "|" (toMimePlanOption <$> opts))
|
||||
|
||||
toMimePlanOption :: MTVndPlanOption -> ByteString
|
||||
toMimePlanOption PlanAnalyze = "analyze"
|
||||
toMimePlanOption PlanVerbose = "verbose"
|
||||
toMimePlanOption PlanSettings = "settings"
|
||||
toMimePlanOption PlanBuffers = "buffers"
|
||||
toMimePlanOption PlanWAL = "wal"
|
||||
|
||||
toMimePlanFormat :: MTVndPlanFormat -> ByteString
|
||||
toMimePlanFormat PlanJSON = "json"
|
||||
toMimePlanFormat PlanText = "text"
|
||||
|
||||
-- | Convert from ByteString to MediaType.
|
||||
--
|
||||
-- >>> decodeMediaType "application/json"
|
||||
-- MTApplicationJSON
|
||||
--
|
||||
-- >>> decodeMediaType "application/vnd.pgrst.plan;"
|
||||
-- MTVndPlan MTApplicationJSON PlanText []
|
||||
--
|
||||
-- >>> decodeMediaType "application/vnd.pgrst.plan;for=\"application/json\""
|
||||
-- MTVndPlan MTApplicationJSON PlanText []
|
||||
--
|
||||
-- >>> decodeMediaType "application/vnd.pgrst.plan ; for=\"text/xml\" ; options=analyze"
|
||||
-- MTVndPlan MTTextXML PlanText [PlanAnalyze]
|
||||
--
|
||||
-- >>> decodeMediaType "application/vnd.pgrst.plan+json;for=\"text/csv\""
|
||||
-- MTVndPlan MTTextCSV PlanJSON []
|
||||
--
|
||||
-- >>> decodeMediaType "application/vnd.pgrst.array+json;nulls=stripped"
|
||||
-- MTVndArrayJSONStrip
|
||||
--
|
||||
-- >>> decodeMediaType "application/vnd.pgrst.array+json"
|
||||
-- MTApplicationJSON
|
||||
--
|
||||
-- >>> decodeMediaType "application/vnd.pgrst.object+json;nulls=stripped"
|
||||
-- MTVndSingularJSON True
|
||||
--
|
||||
-- >>> decodeMediaType "application/vnd.pgrst.object+json"
|
||||
-- MTVndSingularJSON False
|
||||
--
|
||||
-- Test uppercase is parsed correctly (per issue #3478)
|
||||
-- >>> decodeMediaType "ApplicatIon/vnd.PgRsT.object+json"
|
||||
-- MTVndSingularJSON False
|
||||
--
|
||||
-- >>> decodeMediaType "application/vnd.twkb"
|
||||
-- MTOther "application/vnd.twkb"
|
||||
|
||||
decodeMediaType :: ByteString -> MediaType
|
||||
decodeMediaType mt = decodeMediaType' $ decodeLatin1 mt
|
||||
where
|
||||
decodeMediaType' :: Text -> MediaType
|
||||
decodeMediaType' mt' =
|
||||
case (T.toLower mainType, T.toLower subType, params) of
|
||||
("application", "json", _) -> MTApplicationJSON
|
||||
("application", "geo+json", _) -> MTGeoJSON
|
||||
("text", "csv", _) -> MTTextCSV
|
||||
("text", "plain", _) -> MTTextPlain
|
||||
("text", "xml", _) -> MTTextXML
|
||||
("application", "openapi+json", _) -> MTOpenAPI
|
||||
("application", "x-www-form-urlencoded", _) -> MTUrlEncoded
|
||||
("application", "octet-stream", _) -> MTOctetStream
|
||||
("application", "vnd.pgrst.plan", _) -> getPlan PlanText
|
||||
("application", "vnd.pgrst.plan+text", _) -> getPlan PlanText
|
||||
("application", "vnd.pgrst.plan+json", _) -> getPlan PlanJSON
|
||||
("application", "vnd.pgrst.object+json", _) -> MTVndSingularJSON strippedNulls
|
||||
("application", "vnd.pgrst.object", _) -> MTVndSingularJSON strippedNulls
|
||||
("application", "vnd.pgrst.array+json", _) -> checkArrayNullStrip
|
||||
("application", "vnd.pgrst.array", _) -> checkArrayNullStrip
|
||||
("*","*",_) -> MTAny
|
||||
_ -> MTOther mt'
|
||||
where
|
||||
mediaTypeOrError = P.parse tokenizeMediaType "parsec: tokenizeMediaType failed" $ T.unpack mt'
|
||||
(mainType, subType, params') = case mediaTypeOrError of
|
||||
Right mt'' -> mt''
|
||||
Left _ -> (mt',"",[])
|
||||
params = fromList $ map (first T.toLower) params' -- normalize parameter names to lowercase, per RFC 7321
|
||||
getPlan fmt = MTVndPlan mtFor fmt $
|
||||
[PlanAnalyze | inOpts "analyze" ] ++
|
||||
[PlanVerbose | inOpts "verbose" ] ++
|
||||
[PlanSettings | inOpts "settings"] ++
|
||||
[PlanBuffers | inOpts "buffers" ] ++
|
||||
[PlanWAL | inOpts "wal" ]
|
||||
where
|
||||
mtFor = decodeMediaType' $ fromMaybe "application/json" (params !? "for")
|
||||
inOpts str = str `elem` opts
|
||||
opts = T.splitOn "|" $ fromMaybe mempty (params !? "options")
|
||||
strippedNulls = fromMaybe "false" (params !? "nulls") == "stripped"
|
||||
checkArrayNullStrip = if strippedNulls then MTVndArrayJSONStrip else MTApplicationJSON
|
||||
|
||||
-- | Split a Media Type string into components
|
||||
-- >>> P.parse tokenizeMediaType "" "application/vnd.pgrst.plan+json;for=\"text/csv\""
|
||||
-- Right ("application","vnd.pgrst.plan+json",[("for","text/csv")])
|
||||
--
|
||||
-- >>> P.parse tokenizeMediaType "" "*/*"
|
||||
-- Right ("*","*",[])
|
||||
--
|
||||
-- >>> P.parse tokenizeMediaType "" "application/vnd.pgrst.plan;wat=\"application/json;text/csv\""
|
||||
-- Right ("application","vnd.pgrst.plan",[("wat","application/json;text/csv")])
|
||||
--
|
||||
-- >>> P.parse tokenizeMediaType "" "application/vnd.pgrst.plan+text; for=\"text/xml\"; options=analyze|verbose|settings|buffers|wal"
|
||||
-- Right ("application","vnd.pgrst.plan+text",[("for","text/xml"),("options","analyze|verbose|settings|buffers|wal")])
|
||||
|
||||
-- TODO: Improve mediatype parser as per RFC 2045 https://datatracker.ietf.org/doc/html/rfc2045#section-5.1
|
||||
tokenizeMediaType :: P.Parser (Text, Text, [(Text, Text)])
|
||||
tokenizeMediaType = do
|
||||
mainType <- P.many1 (P.alphaNum <|> P.oneOf ".*")
|
||||
P.char '/'
|
||||
subType <- P.many1 (P.alphaNum <|> P.oneOf ".*+-")
|
||||
params <- P.many pSemicolonSeparatedKeyVals
|
||||
P.optional $ P.try $ P.spaces *> P.char ';' -- ending semicolon, discard input after that because it has already failed or we have hit EOF
|
||||
return (T.pack mainType, T.pack subType, params)
|
||||
where
|
||||
pSemicolonSeparatedKeyVals :: P.Parser (Text, Text)
|
||||
pSemicolonSeparatedKeyVals = P.try $ P.spaces *> P.char ';' *> P.spaces *> pKeyVal
|
||||
where
|
||||
pKeyVal :: P.Parser (Text, Text)
|
||||
pKeyVal = do
|
||||
key <- P.many1 (P.alphaNum <|> P.oneOf "-")
|
||||
P.spaces
|
||||
P.char '='
|
||||
P.spaces
|
||||
val <- P.try pQuoted <|> P.try pUnQuoted
|
||||
return (T.pack key, T.pack val)
|
||||
where
|
||||
pUnQuoted = P.many1 (P.alphaNum <|> P.oneOf "|-")
|
||||
pQuoted = P.char '\"' *> P.manyTill P.anyChar (P.char '\"')
|
||||
@@ -0,0 +1,124 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-|
|
||||
Module : PostgREST.Logger
|
||||
Description : Metrics based on the Observation module. See Observation.hs.
|
||||
-}
|
||||
module PostgREST.Metrics
|
||||
( init
|
||||
, ConnTrack
|
||||
, ConnStats (..)
|
||||
, MetricsState (..)
|
||||
, connectionCounts
|
||||
, observationMetrics
|
||||
, metricsToText
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Hasql.Pool.Observation as SQL
|
||||
|
||||
import GHC.Stats (getRTSStatsEnabled)
|
||||
import Prometheus
|
||||
import qualified Prometheus.Metric.GHC as PMG
|
||||
|
||||
import PostgREST.Observation
|
||||
|
||||
import Control.Arrow ((&&&))
|
||||
import Data.Bitraversable (bisequenceA)
|
||||
import Data.Tuple.Extra (both)
|
||||
import Data.UUID (UUID)
|
||||
import qualified Focus
|
||||
import Protolude
|
||||
import qualified StmHamt.SizedHamt as SH
|
||||
|
||||
data MetricsState =
|
||||
MetricsState {
|
||||
poolTimeouts :: Counter,
|
||||
connTrack :: ConnTrack,
|
||||
poolWaiting :: Gauge,
|
||||
poolMaxSize :: Gauge,
|
||||
schemaCacheLoads :: Vector Label1 Counter,
|
||||
schemaCacheQueryTime :: Gauge,
|
||||
jwtCacheRequests :: Counter,
|
||||
jwtCacheHits :: Counter,
|
||||
jwtCacheEvictions :: Counter
|
||||
}
|
||||
|
||||
init :: Int -> IO MetricsState
|
||||
init configDbPoolSize = do
|
||||
whenM getRTSStatsEnabled $ void $ register PMG.ghcMetrics
|
||||
metricState <- MetricsState <$>
|
||||
register (counter (Info "pgrst_db_pool_timeouts_total" "The total number of pool connection timeouts")) <*>
|
||||
register (Metric ((identity &&& dbPoolAvailable) <$> connectionTracker)) <*>
|
||||
register (gauge (Info "pgrst_db_pool_waiting" "Requests waiting to acquire a pool connection")) <*>
|
||||
register (gauge (Info "pgrst_db_pool_max" "Max pool connections")) <*>
|
||||
register (vector "status" $ counter (Info "pgrst_schema_cache_loads_total" "The total number of times the schema cache was loaded")) <*>
|
||||
register (gauge (Info "pgrst_schema_cache_query_time_seconds" "The query time in seconds of the last schema cache load")) <*>
|
||||
register (counter (Info "pgrst_jwt_cache_requests_total" "The total number of JWT cache lookups")) <*>
|
||||
register (counter (Info "pgrst_jwt_cache_hits_total" "The total number of JWT cache hits")) <*>
|
||||
register (counter (Info "pgrst_jwt_cache_evictions_total" "The total number of JWT cache evictions"))
|
||||
setGauge (poolMaxSize metricState) (fromIntegral configDbPoolSize)
|
||||
pure metricState
|
||||
where
|
||||
dbPoolAvailable = (pure . noLabelsGroup (Info "pgrst_db_pool_available" "Available connections in the pool") GaugeType . calcAvailable <$>) . connectionCounts
|
||||
where
|
||||
calcAvailable = liftA2 (-) connected inUse
|
||||
toSample name labels = Sample name labels . encodeUtf8 . show
|
||||
noLabelsGroup info sampleType = SampleGroup info sampleType . pure . toSample (metricName info) mempty
|
||||
|
||||
-- Only some observations are used as metrics
|
||||
observationMetrics :: MetricsState -> ObservationHandler
|
||||
observationMetrics MetricsState{..} obs = case obs of
|
||||
PoolAcqTimeoutObs -> do
|
||||
incCounter poolTimeouts
|
||||
-- Handle pool observations with connection tracking
|
||||
-- this is necessary because it is not possible
|
||||
-- to accurately maintain open/in use conneciton counts
|
||||
-- statelessly based only on pool observation events.
|
||||
-- The reason is that hasql-pool emits TerminatedConnectionStatus
|
||||
-- both for connections successfully established and failed when connecting.
|
||||
-- When receiving TerminatedConnectionStatus we have to find out
|
||||
-- if we can decrement established connection count. To do that we have to track
|
||||
-- established connections.
|
||||
(HasqlPoolObs sqlObs) -> trackConnections connTrack sqlObs
|
||||
PoolRequest ->
|
||||
incGauge poolWaiting
|
||||
PoolRequestFullfilled ->
|
||||
decGauge poolWaiting
|
||||
SchemaCacheLoadedObs resTime _ -> do
|
||||
withLabel schemaCacheLoads "SUCCESS" incCounter
|
||||
setGauge schemaCacheQueryTime resTime
|
||||
SchemaCacheErrorObs{} -> do
|
||||
withLabel schemaCacheLoads "FAIL" incCounter
|
||||
JwtCacheLookup True -> incCounter jwtCacheRequests *> incCounter jwtCacheHits
|
||||
JwtCacheLookup False -> incCounter jwtCacheRequests
|
||||
JwtCacheEviction -> incCounter jwtCacheEvictions
|
||||
_ ->
|
||||
pure ()
|
||||
|
||||
metricsToText :: IO LBS.ByteString
|
||||
metricsToText = exportMetricsAsText
|
||||
|
||||
data ConnStats = ConnStats {
|
||||
connected :: Int,
|
||||
inUse :: Int
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data ConnTrack = ConnTrack { connTrackConnected :: SH.SizedHamt UUID, connTrackInUse :: SH.SizedHamt UUID }
|
||||
|
||||
connectionTracker :: IO ConnTrack
|
||||
connectionTracker = ConnTrack <$> SH.newIO <*> SH.newIO
|
||||
|
||||
trackConnections :: ConnTrack -> SQL.Observation -> IO ()
|
||||
trackConnections ConnTrack{..} (SQL.ConnectionObservation uuid status) = case status of
|
||||
SQL.ReadyForUseConnectionStatus _ -> atomically $
|
||||
SH.insert identity uuid connTrackConnected *>
|
||||
SH.focus Focus.delete identity uuid connTrackInUse
|
||||
SQL.TerminatedConnectionStatus _ -> atomically $
|
||||
SH.focus Focus.delete identity uuid connTrackConnected *>
|
||||
SH.focus Focus.delete identity uuid connTrackInUse
|
||||
SQL.InUseConnectionStatus -> atomically $
|
||||
SH.insert identity uuid connTrackInUse
|
||||
_ -> mempty
|
||||
|
||||
connectionCounts :: ConnTrack -> IO ConnStats
|
||||
connectionCounts = atomically . fmap (uncurry ConnStats) . bisequenceA . both SH.size . (connTrackConnected &&& connTrackInUse)
|
||||
@@ -0,0 +1,45 @@
|
||||
module PostgREST.Network
|
||||
( resolveSocketToAddress
|
||||
, escapeHostName
|
||||
, isSpecialHostName
|
||||
) where
|
||||
|
||||
import Data.String (IsString (..))
|
||||
import qualified Network.Socket as NS
|
||||
|
||||
import Protolude
|
||||
|
||||
-- | Resolves the socket to an address depending on the socket type. The Show
|
||||
-- instance of the socket types automatically resolves it to the correct
|
||||
-- address. Example resolution:
|
||||
-- -----------------------------------------------------
|
||||
-- | IPv4 | IPv6 | Unix |
|
||||
-- -----------------------------------------------------
|
||||
-- | 127.0.0.1:80 | [2001:db8::1]:80 | /tmp/pgrst.sock |
|
||||
-- -----------------------------------------------------
|
||||
resolveSocketToAddress :: NS.Socket -> IO Text
|
||||
resolveSocketToAddress sock = do
|
||||
sn <- NS.getSocketName sock
|
||||
return $ fromString $ show sn
|
||||
|
||||
-- | When printing special addresses like !4 or *6, we use the following mapping.
|
||||
-- These special addresses come from:
|
||||
-- https://hackage.haskell.org/package/streaming-commons-0.2.3.0/docs/\
|
||||
-- Data-Streaming-Network.html#t:HostPreference
|
||||
-- TODO: "!6" should not be printed as "0.0.0.0" address.
|
||||
escapeHostName :: Text -> Text
|
||||
escapeHostName "*" = "0.0.0.0"
|
||||
escapeHostName "*4" = "0.0.0.0"
|
||||
escapeHostName "!4" = "0.0.0.0"
|
||||
escapeHostName "*6" = "0.0.0.0"
|
||||
escapeHostName "!6" = "0.0.0.0"
|
||||
escapeHostName h = h
|
||||
|
||||
-- | Check if a hostname is special
|
||||
isSpecialHostName :: Text -> Bool
|
||||
isSpecialHostName "*" = True
|
||||
isSpecialHostName "*4" = True
|
||||
isSpecialHostName "!4" = True
|
||||
isSpecialHostName "*6" = True
|
||||
isSpecialHostName "!6" = True
|
||||
isSpecialHostName _ = False
|
||||
@@ -0,0 +1,70 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-|
|
||||
Module : PostgREST.Observation
|
||||
Description : This module holds an Observation type which is the core of Observability for PostgREST.
|
||||
The Observation and ObservationHandler (the observer) are abstractions that allow centralizing logging and metrics concerns,
|
||||
only observer calls with an Observation constructor are applied at different parts in the codebase.
|
||||
The Logger and Metrics modules then decide which observations to expose. Not all observations need to be logged nor all correspond to a metric.
|
||||
-}
|
||||
module PostgREST.Observation
|
||||
( Observation(..)
|
||||
, ObsFatalError(..)
|
||||
, ObservationHandler
|
||||
) where
|
||||
|
||||
import qualified Hasql.Connection as SQL
|
||||
import qualified Hasql.Pool as SQL
|
||||
import qualified Hasql.Pool.Observation as SQL
|
||||
import Network.HTTP.Types.Status (Status)
|
||||
import qualified Network.Wai as Wai
|
||||
import PostgREST.Config.PgVersion
|
||||
import PostgREST.Query (MainQuery)
|
||||
import PostgREST.SchemaCache (QueryTimings)
|
||||
|
||||
import Protolude hiding (toList)
|
||||
|
||||
data Observation
|
||||
= AdminStartObs Text
|
||||
| AdminServerCrashedObs SomeException
|
||||
| AppStartObs ByteString
|
||||
| AppServerAddressObs Text
|
||||
| ExitUnsupportedPgVersion PgVersion PgVersion
|
||||
| ExitDBNoRecoveryObs
|
||||
| ExitDBFatalError ObsFatalError SQL.UsageError
|
||||
| DBConnectedObs Text
|
||||
| SchemaCacheEmptyObs
|
||||
| SchemaCacheErrorObs (NonEmpty Text) [Text] SQL.UsageError
|
||||
| SchemaCacheQueriedObs Double (Maybe QueryTimings)
|
||||
| SchemaCacheLoadedObs Double Text
|
||||
| ConnectionRetryObs Int
|
||||
| DBListenStart (Maybe ByteString) (Maybe ByteString) Text Text -- host, port, version string, channel
|
||||
| DBListenFail Text (Either SQL.ConnectionError SomeException)
|
||||
| DBListenRetry Int
|
||||
| DBListenBugCallQueryFix
|
||||
| DBListenerGotSCacheMsg ByteString
|
||||
| DBListenerGotConfigMsg ByteString
|
||||
| DBListenerConnectionCleanupFail SomeException
|
||||
| QueryObs MainQuery Status
|
||||
| LegacyTargetNameWarningObs (Text, Text) ByteString ByteString
|
||||
| ConfigReadErrorObs SQL.UsageError
|
||||
| ConfigInvalidObs Text
|
||||
| ConfigSucceededObs
|
||||
| QueryRoleSettingsErrorObs SQL.UsageError
|
||||
| QueryErrorCodeHighObs SQL.UsageError
|
||||
| QueryPgVersionError SQL.UsageError
|
||||
| PoolInit Int
|
||||
| PoolAcqTimeoutObs
|
||||
| HasqlPoolObs SQL.Observation
|
||||
| ResponseObs (Maybe ByteString) Wai.Request Status (Maybe Integer)
|
||||
| PoolRequest
|
||||
| PoolRequestFullfilled
|
||||
| PoolFlushed
|
||||
| JwtCacheLookup Bool
|
||||
| JwtCacheEviction
|
||||
| TerminationUnixSignalObs Text
|
||||
| WarpServerObs Text
|
||||
deriving (Generic)
|
||||
|
||||
data ObsFatalError = ServerAuthError | ServerPgrstBug | ServerError42P05 | ServerError08P01
|
||||
|
||||
type ObservationHandler = Observation -> IO ()
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,64 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
module PostgREST.Plan.CallPlan
|
||||
( CallPlan(..)
|
||||
, CallParams(..)
|
||||
, CallArgs(..)
|
||||
, RpcParamValue(..)
|
||||
, toRpcParams
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import PostgREST.SchemaCache.Identifiers (FieldName,
|
||||
QualifiedIdentifier)
|
||||
import PostgREST.SchemaCache.Routine (Routine (..),
|
||||
RoutineParam (..))
|
||||
|
||||
import Protolude
|
||||
|
||||
data CallPlan = FunctionCall
|
||||
{ funCQi :: QualifiedIdentifier
|
||||
, funCParams :: CallParams
|
||||
, funCArgs :: CallArgs
|
||||
, funCScalar :: Bool
|
||||
, funCSetOfScalar :: Bool
|
||||
, funCFilterFields :: Set FieldName
|
||||
, funCReturning :: Set FieldName
|
||||
}
|
||||
|
||||
data CallParams
|
||||
= KeyParams [RoutineParam] -- ^ Call with key params: func(a := val1, b:= val2)
|
||||
| OnePosParam RoutineParam -- ^ Call with positional params(only one supported): func(val)
|
||||
|
||||
data CallArgs
|
||||
= DirectArgs (HM.HashMap Text RpcParamValue)
|
||||
| JsonArgs (Maybe LBS.ByteString)
|
||||
|
||||
-- | RPC query param value `/rpc/func?v=<value>`, used for VARIADIC functions on form-urlencoded POST and GETs
|
||||
-- | It can be fixed `?v=1` or repeated `?v=1&v=2&v=3.
|
||||
data RpcParamValue = Fixed Text | Variadic [Text]
|
||||
instance JSON.ToJSON RpcParamValue where
|
||||
toJSON (Fixed v) = JSON.toJSON v
|
||||
-- Not possible to get here anymore. Variadic arguments are only supported for
|
||||
-- true variadic arguments, but the toJSON instance is only used for the "single unnamed json argument" case.
|
||||
toJSON (Variadic v) = JSON.toJSON v
|
||||
|
||||
-- | Convert rpc params `/rpc/func?a=val1&b=val2` to json `{"a": "val1", "b": "val2"}
|
||||
toRpcParams :: Routine -> [(Text, Text)] -> HM.HashMap Text RpcParamValue
|
||||
toRpcParams proc prms =
|
||||
if not $ pdHasVariadic proc then -- if proc has no variadic param, save steps and directly convert to map
|
||||
HM.fromList $ second Fixed <$> prms
|
||||
else
|
||||
HM.fromListWith mergeParams $ toRpcParamValue proc <$> prms
|
||||
where
|
||||
mergeParams :: RpcParamValue -> RpcParamValue -> RpcParamValue
|
||||
mergeParams (Variadic a) (Variadic b) = Variadic $ b ++ a
|
||||
mergeParams v _ = v -- repeated params for non-variadic parameters are not merged
|
||||
|
||||
toRpcParamValue :: Routine -> (Text, Text) -> (Text, RpcParamValue)
|
||||
toRpcParamValue proc (k, v) | prmIsVariadic k = (k, Variadic [v])
|
||||
| otherwise = (k, Fixed v)
|
||||
where
|
||||
prmIsVariadic prm = isJust $ find (\RoutineParam{ppName, ppVar} -> ppName == prm && ppVar) $ pdParams proc
|
||||
@@ -0,0 +1,40 @@
|
||||
module PostgREST.Plan.MutatePlan
|
||||
( MutatePlan(..)
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
import PostgREST.ApiRequest.Preferences (PreferResolution)
|
||||
import PostgREST.Plan.Types (CoercibleField,
|
||||
CoercibleLogicTree)
|
||||
import PostgREST.SchemaCache.Identifiers (FieldName,
|
||||
QualifiedIdentifier)
|
||||
|
||||
|
||||
import Protolude
|
||||
|
||||
data MutatePlan
|
||||
= Insert
|
||||
{ in_ :: QualifiedIdentifier
|
||||
, insCols :: [CoercibleField]
|
||||
, insBody :: Maybe LBS.ByteString
|
||||
, onConflict :: Maybe (PreferResolution, [FieldName])
|
||||
, where_ :: [CoercibleLogicTree]
|
||||
, returning :: [FieldName]
|
||||
, insPkCols :: [FieldName]
|
||||
, applyDefs :: Bool
|
||||
}
|
||||
| Update
|
||||
{ in_ :: QualifiedIdentifier
|
||||
, updCols :: [CoercibleField]
|
||||
, updBody :: Maybe LBS.ByteString
|
||||
, where_ :: [CoercibleLogicTree]
|
||||
, returning :: [FieldName]
|
||||
, applyDefs :: Bool
|
||||
}
|
||||
| Delete
|
||||
{ in_ :: QualifiedIdentifier
|
||||
, where_ :: [CoercibleLogicTree]
|
||||
, returning :: [FieldName]
|
||||
}
|
||||
@@ -0,0 +1,82 @@
|
||||
{-|
|
||||
Module : PostgREST.Plan.Negotiate
|
||||
Description : PostgREST Content Negotiation
|
||||
|
||||
This module contains logic for content negotiation.
|
||||
RFC: https://datatracker.ietf.org/doc/html/rfc7231#section-3.4
|
||||
-}
|
||||
|
||||
module PostgREST.Plan.Negotiate
|
||||
( negotiateContent
|
||||
) where
|
||||
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
|
||||
import PostgREST.ApiRequest (ApiRequest (..))
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.Error (ApiRequestError (..))
|
||||
import PostgREST.MediaType (MediaType (..))
|
||||
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..),
|
||||
RelIdentifier (..))
|
||||
import PostgREST.SchemaCache.Routine (MediaHandler (..),
|
||||
MediaHandlerMap,
|
||||
ResolvedHandler)
|
||||
|
||||
import PostgREST.ApiRequest.Preferences
|
||||
import PostgREST.ApiRequest.Types
|
||||
import qualified PostgREST.MediaType as MediaType
|
||||
|
||||
import Protolude hiding (from)
|
||||
|
||||
-- We have two general cases of return values from database objects
|
||||
-- (tables/views/functions):
|
||||
--
|
||||
-- 1. "un-mime-typed" values, in most of the cases this is a composite/row
|
||||
-- value, for example for tables or views, but also often for functions.
|
||||
-- It can be simple integer values or text or bytea as well.
|
||||
--
|
||||
-- For this, we need handlers to transform the "non-mime-typed" values
|
||||
-- into "mimetypes". We have a default builtin handler that does
|
||||
-- "application/json". We can add more handlers via aggregates.
|
||||
--
|
||||
-- 2. "mime-typed" values, which specifically return a domain type that is
|
||||
-- associated to a certain mimetype. e.g, a function returning only
|
||||
-- "image/png".
|
||||
--
|
||||
-- FIXME:
|
||||
-- If the function returns a domain type - let's say image/png, we should
|
||||
-- accept */*, image/*, and image/png.
|
||||
-- Related issue: https://github.com/PostgREST/postgrest/issues/3391
|
||||
|
||||
-- | Do content negotiation. i.e. choose a media type based on the
|
||||
-- intersection of accepted/produced media types.
|
||||
negotiateContent :: AppConfig -> ApiRequest -> QualifiedIdentifier -> [MediaType] -> MediaHandlerMap -> Bool -> Either ApiRequestError ResolvedHandler
|
||||
negotiateContent conf ApiRequest{iAction=act, iPreferences=Preferences{preferRepresentation=rep}} identifier accepts produces defaultSelect =
|
||||
case (act, firstAcceptedPick) of
|
||||
(_, Nothing) -> Left . MediaTypeError $ map MediaType.toMime accepts
|
||||
(ActDb (ActRelationMut _ _), Just (x, mt)) -> Right (if rep == Just Full then x else NoAgg, mt)
|
||||
-- no need for an aggregate on HEAD https://github.com/PostgREST/postgrest/issues/2849
|
||||
-- TODO: despite no aggregate, these are responding with a Content-Type, which is not correct.
|
||||
(ActDb (ActRelationRead _ True), Just (_, mt)) -> Right (NoAgg, mt)
|
||||
(ActDb (ActRoutine _ (InvRead True)), Just (_, mt)) -> Right (NoAgg, mt)
|
||||
(_, Just (x, mt)) -> Right (x, mt)
|
||||
where
|
||||
firstAcceptedPick = listToMaybe $ mapMaybe matchMT accepts -- If there are multiple accepted media types, pick the first. This is usual in content negotiation.
|
||||
matchMT mt = case mt of
|
||||
-- all the vendored media types have special handling as they have media type parameters, they cannot be overridden
|
||||
m@(MTVndSingularJSON strip) -> Just (BuiltinAggSingleJson strip, m)
|
||||
m@MTVndArrayJSONStrip -> Just (BuiltinAggArrayJsonStrip, m)
|
||||
m@(MTVndPlan (MTVndSingularJSON strip) _ _) -> mtPlanToNothing $ Just (BuiltinAggSingleJson strip, m)
|
||||
m@(MTVndPlan MTVndArrayJSONStrip _ _) -> mtPlanToNothing $ Just (BuiltinAggArrayJsonStrip, m)
|
||||
-- TODO the plan should have its own MediaHandler instead of relying on MediaType
|
||||
m@(MTVndPlan mType _ _) -> mtPlanToNothing $ ((,) . fst <$> lookupHandler mType) <*> pure m
|
||||
-- all the other media types can be overridden
|
||||
x -> lookupHandler x
|
||||
mtPlanToNothing x = if configDbPlanEnabled conf then x else Nothing -- don't find anything if the plan media type is not allowed
|
||||
lookupHandler mt =
|
||||
when' defaultSelect (HM.lookup (RelId identifier, MTAny) produces) <|> -- lookup for identifier and `*/*`
|
||||
when' defaultSelect (HM.lookup (RelId identifier, mt) produces) <|> -- lookup for identifier and a particular media type
|
||||
HM.lookup (RelAnyElement, mt) produces -- lookup for anyelement and a particular media type
|
||||
when' :: Bool -> Maybe a -> Maybe a
|
||||
when' True (Just a) = Just a
|
||||
when' _ _ = Nothing
|
||||
@@ -0,0 +1,53 @@
|
||||
module PostgREST.Plan.ReadPlan
|
||||
( ReadPlanTree
|
||||
, ReadPlan(..)
|
||||
, JoinCondition(..)
|
||||
, SpreadType(..)
|
||||
) where
|
||||
|
||||
import Data.Tree (Tree (..))
|
||||
|
||||
import PostgREST.ApiRequest.Types (Alias, Depth, Hint,
|
||||
JoinType, NodeName)
|
||||
import PostgREST.Plan.Types (CoercibleLogicTree,
|
||||
CoercibleOrderTerm,
|
||||
CoercibleSelectField (..),
|
||||
RelSelectField (..),
|
||||
SpreadType (..))
|
||||
import PostgREST.RangeQuery (NonnegRange)
|
||||
import PostgREST.SchemaCache.Identifiers (FieldName,
|
||||
QualifiedIdentifier)
|
||||
import PostgREST.SchemaCache.Relationship (Relationship)
|
||||
|
||||
|
||||
import Protolude
|
||||
|
||||
type ReadPlanTree = Tree ReadPlan
|
||||
|
||||
data JoinCondition =
|
||||
JoinCondition
|
||||
(QualifiedIdentifier, FieldName)
|
||||
(QualifiedIdentifier, FieldName)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- TODO: Enforce uniqueness of columns by changing to a Set instead of a List where applicable
|
||||
data ReadPlan = ReadPlan
|
||||
{ select :: [CoercibleSelectField]
|
||||
, from :: QualifiedIdentifier
|
||||
, fromAlias :: Maybe Alias
|
||||
, where_ :: [CoercibleLogicTree]
|
||||
, order :: [CoercibleOrderTerm]
|
||||
, range_ :: NonnegRange
|
||||
, relName :: NodeName
|
||||
, relToParent :: Maybe Relationship
|
||||
, relJoinConds :: [JoinCondition]
|
||||
, relAlias :: Maybe Alias
|
||||
, relAggAlias :: Alias
|
||||
, relHint :: Maybe Hint
|
||||
, relJoinType :: Maybe JoinType
|
||||
, relSpread :: Maybe SpreadType
|
||||
, relSelect :: [RelSelectField]
|
||||
, depth :: Depth -- ^ used for aliasing
|
||||
, relIsLegacyTargetNameMatch :: Bool -- ^ used to ease migration into a new version with breaking change
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@@ -0,0 +1,123 @@
|
||||
module PostgREST.Plan.Types
|
||||
( CoercibleField(..)
|
||||
, CoercibleSelectField(..)
|
||||
, unknownField
|
||||
, CoercibleLogicTree(..)
|
||||
, CoercibleFilter(..)
|
||||
, TransformerProc
|
||||
, ToTsVector(..)
|
||||
, CoercibleOrderTerm(..)
|
||||
, RelSelectField(..)
|
||||
, RelJsonEmbedMode(..)
|
||||
, SpreadSelectField(..)
|
||||
, SpreadType(..)
|
||||
) where
|
||||
|
||||
import PostgREST.ApiRequest.Types (AggregateFunction, Alias, Cast,
|
||||
Field, JsonPath, Language,
|
||||
LogicOperator, OpExpr,
|
||||
OrderDirection, OrderNulls)
|
||||
|
||||
import PostgREST.SchemaCache.Identifiers (FieldName)
|
||||
|
||||
import Protolude
|
||||
|
||||
type TransformerProc = Text
|
||||
|
||||
newtype ToTsVector = ToTsVector (Maybe Language)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | A CoercibleField pairs the name of a query element with any type coercion information we need for some specific use case.
|
||||
-- |
|
||||
-- | As suggested by the name, it's often a reference to a field in a table but really it can be any nameable element (function parameter, calculation with an alias, etc) with a knowable type.
|
||||
-- |
|
||||
-- | In the simplest case, it allows us to parse JSON payloads with `json_to_recordset`, for which we need to know both the name and the type of each thing we'd like to extract. At a higher level, CoercibleField generalises to reflect that any value we work with in a query may need type specific handling.
|
||||
-- |
|
||||
-- | CoercibleField is the foundation for the Data Representations feature. This feature allow user-definable mappings between database types so that the same data can be presented or interpreted in various ways as needed. Sometimes the way Postgres coerces data implicitly isn't right for the job. Different mappings might be appropriate for different situations: parsing a filter from a query string requires one function (text -> field type) while parsing a payload from JSON takes another (json -> field type). And the reverse, outputting a field as JSON, requires yet a third (field type -> json). CoercibleField is that "job specific" reference to an element paired with the type we desire for that particular purpose and the function we'll use to get there, if any.
|
||||
-- |
|
||||
-- | In the planning phase, we "resolve" generic named elements into these specialised CoercibleFields. Again this is context specific: two different CoercibleFields both representing the exact same table column in the database, even in the same query, might have two different target types and mapping functions. For example, one might represent a column in a filter, and another the very same column in an output role to be sent in the response body.
|
||||
-- |
|
||||
-- | The type value is allowed to be the empty string. The analog here is soft type checking in programming languages: sometimes we don't need a variable to have a specified type and things will work anyhow. So the empty type variant is valid when we don't know and *don't need to know* about the specific type in some context. Note that this variation should not be used if it guarantees failure: in that case you should instead raise an error at the planning stage and bail out. For example, we can't parse JSON with `json_to_recordset` without knowing the types of each recipient field, and so error out. Using the empty string for the type would be incorrect and futile. On the other hand we use the empty type for RPC calls since type resolution isn't implemented for RPC, but it's fine because the query still works with Postgres' implicit coercion. In the future, hopefully we will support data representations across the board and then the empty type may be permanently retired.
|
||||
data CoercibleField = CoercibleField
|
||||
{ cfName :: FieldName
|
||||
, cfJsonPath :: JsonPath
|
||||
, cfToJson :: Bool
|
||||
, cfToTsVector :: Maybe ToTsVector -- ^ If the field should be converted using to_tsvector(<language>, <field>)
|
||||
, cfIRType :: Text -- ^ The native Postgres type of the field, the intermediate (IR) type before mapping.
|
||||
, cfBaseType :: Text -- ^ The base type of the field in case of domains, or just the type otherwise (without modifiers in case of pg_catalog types)
|
||||
, cfTransform :: Maybe TransformerProc -- ^ The optional mapping from irType -> targetType.
|
||||
, cfDefault :: Maybe Text
|
||||
, cfFullRow :: Bool -- ^ True if the field represents the whole selected row. Used in spread rels: instead of COUNT(*), it does a COUNT(<row>) in order to not mix with other spread resources.
|
||||
} deriving (Eq, Show)
|
||||
|
||||
unknownField :: FieldName -> JsonPath -> CoercibleField
|
||||
unknownField name path = CoercibleField name path False Nothing "" "" Nothing Nothing False
|
||||
|
||||
-- | Like an API request LogicTree, but with coercible field information.
|
||||
data CoercibleLogicTree
|
||||
= CoercibleExpr Bool LogicOperator [CoercibleLogicTree]
|
||||
| CoercibleStmnt CoercibleFilter
|
||||
deriving (Eq, Show)
|
||||
|
||||
data CoercibleFilter = CoercibleFilter
|
||||
{ field :: CoercibleField
|
||||
, opExpr :: OpExpr
|
||||
}
|
||||
| CoercibleFilterNullEmbed Bool FieldName
|
||||
deriving (Eq, Show)
|
||||
|
||||
data CoercibleOrderTerm
|
||||
= CoercibleOrderTerm
|
||||
{ coField :: CoercibleField
|
||||
, coDirection :: Maybe OrderDirection
|
||||
, coNullOrder :: Maybe OrderNulls
|
||||
}
|
||||
| CoercibleOrderRelationTerm
|
||||
{ coRelation :: FieldName
|
||||
, coRelTerm :: Field
|
||||
, coDirection :: Maybe OrderDirection
|
||||
, coNullOrder :: Maybe OrderNulls
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data CoercibleSelectField = CoercibleSelectField
|
||||
{ csField :: CoercibleField
|
||||
, csAggFunction :: Maybe AggregateFunction
|
||||
, csAggCast :: Maybe Cast
|
||||
, csCast :: Maybe Cast
|
||||
, csAlias :: Maybe Alias
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data RelJsonEmbedMode = JsonObject | JsonArray
|
||||
deriving (Show, Eq)
|
||||
|
||||
data RelSelectField
|
||||
= JsonEmbed
|
||||
{ rsSelName :: FieldName
|
||||
, rsAggAlias :: Alias
|
||||
, rsEmbedMode :: RelJsonEmbedMode
|
||||
, rsEmptyEmbed :: Bool
|
||||
}
|
||||
| Spread
|
||||
{ rsSpreadSel :: [SpreadSelectField]
|
||||
, rsAggAlias :: Alias
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data SpreadSelectField =
|
||||
SpreadSelectField
|
||||
{ ssSelName :: FieldName
|
||||
, ssSelAggFunction :: Maybe AggregateFunction
|
||||
, ssSelAggCast :: Maybe Cast
|
||||
, ssSelAlias :: Maybe Alias
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data SpreadType
|
||||
= ToOneSpread
|
||||
| ToManySpread
|
||||
{ stExtraSelect :: [(Maybe FieldName, CoercibleSelectField)]
|
||||
, stOrder :: [CoercibleOrderTerm]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@@ -0,0 +1,58 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-|
|
||||
Module : PostgREST.Query
|
||||
Description : PostgREST query building
|
||||
|
||||
TODO: This module shouldn't depend on SchemaCache: once OpenAPI is removed, this can be done
|
||||
-}
|
||||
module PostgREST.Query
|
||||
( mainQuery
|
||||
, MainQuery (..)
|
||||
) where
|
||||
|
||||
import qualified Hasql.DynamicStatements.Snippet as SQL hiding (sql)
|
||||
|
||||
import qualified PostgREST.Query.PreQuery as PreQuery
|
||||
import qualified PostgREST.Query.QueryBuilder as QueryBuilder
|
||||
import qualified PostgREST.Query.SqlFragment as SqlFragment
|
||||
import qualified PostgREST.Query.Statements as Statements
|
||||
|
||||
|
||||
import PostgREST.ApiRequest (ApiRequest (..))
|
||||
import PostgREST.ApiRequest.Preferences (Preferences (..),
|
||||
shouldExplainCount)
|
||||
import PostgREST.Auth.Types (AuthResult (..))
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.Plan (ActionPlan (..),
|
||||
CrudPlan (..),
|
||||
DbActionPlan (..),
|
||||
InspectPlan (..))
|
||||
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..))
|
||||
|
||||
import Protolude hiding (Handler)
|
||||
|
||||
-- The Queries that run on every request
|
||||
data MainQuery = MainQuery
|
||||
{ mqTxVars :: SQL.Snippet -- ^ the transaction variables that always run on each query
|
||||
, mqPreReq :: Maybe SQL.Snippet -- ^ the pre-request function that runs if enabled
|
||||
-- TODO only one of the following queries actually runs on each request, once OpenAPI is removed from core it will be easier to refactor this
|
||||
, mqMain :: SQL.Snippet
|
||||
, mqOpenAPI :: (SQL.Snippet, SQL.Snippet, SQL.Snippet)
|
||||
, mqExplain :: Maybe SQL.Snippet -- ^ the explain query that gets generated for the "Prefer: count=estimated" case
|
||||
}
|
||||
|
||||
mainQuery :: ActionPlan -> AppConfig -> ApiRequest -> AuthResult -> Maybe QualifiedIdentifier -> MainQuery
|
||||
mainQuery (NoDb _) _ _ _ _ = MainQuery mempty Nothing mempty (mempty, mempty, mempty) mempty
|
||||
mainQuery (Db plan) conf@AppConfig{..} apiReq@ApiRequest{iTopLevelRange=range, iPreferences=Preferences{..}} authRes preReq =
|
||||
let genQ = MainQuery (PreQuery.txVarQuery plan conf authRes apiReq) (PreQuery.preReqQuery <$> preReq) in
|
||||
case plan of
|
||||
DbCrud _ WrappedReadPlan{..} ->
|
||||
let countQuery = QueryBuilder.readPlanToCountQuery wrReadPlan in
|
||||
genQ (Statements.mainRead wrReadPlan countQuery preferCount configDbMaxRows range pMedia wrHandler) (mempty, mempty, mempty)
|
||||
(if shouldExplainCount preferCount then Just (Statements.postExplain countQuery) else Nothing)
|
||||
DbCrud _ MutateReadPlan{..} ->
|
||||
genQ (Statements.mainWrite mrReadPlan mrMutatePlan pMedia mrHandler preferRepresentation preferResolution) (mempty, mempty, mempty) mempty
|
||||
DbCrud _ CallReadPlan{..} ->
|
||||
genQ (Statements.mainCall crProc crCallPlan crReadPlan preferCount configDbMaxRows range pMedia crHandler) (mempty, mempty, mempty) mempty
|
||||
MayUseDb InspectPlan{ipSchema=tSchema} ->
|
||||
genQ mempty (SqlFragment.accessibleTables tSchema, SqlFragment.accessibleFuncs tSchema, SqlFragment.schemaDescription tSchema) mempty
|
||||
@@ -0,0 +1,68 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-|
|
||||
Module : PostgREST.Query.PreQuery
|
||||
Description : Builds queries that run prior to the main query
|
||||
-}
|
||||
module PostgREST.Query.PreQuery
|
||||
( txVarQuery
|
||||
, preReqQuery
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import qualified Data.ByteString.Lazy.Char8 as LBS
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Hasql.DynamicStatements.Snippet as SQL hiding (sql)
|
||||
|
||||
|
||||
|
||||
import PostgREST.ApiRequest (ApiRequest (..))
|
||||
import PostgREST.ApiRequest.Preferences (PreferTimezone (..),
|
||||
Preferences (..))
|
||||
import PostgREST.Auth.Types (AuthResult (..))
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.Plan (CrudPlan (..),
|
||||
DbActionPlan (..))
|
||||
import PostgREST.Query.SqlFragment (escapeIdentList, fromQi,
|
||||
intercalateSnippet,
|
||||
setConfigWithConstantName,
|
||||
setConfigWithConstantNameJSON,
|
||||
setConfigWithDynamicName)
|
||||
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..))
|
||||
import PostgREST.SchemaCache.Routine (Routine (..))
|
||||
|
||||
import Protolude hiding (Handler)
|
||||
|
||||
-- sets transaction variables
|
||||
txVarQuery :: DbActionPlan -> AppConfig -> AuthResult -> ApiRequest -> SQL.Snippet
|
||||
txVarQuery dbActPlan AppConfig{..} AuthResult{..} ApiRequest{..} =
|
||||
-- To ensure `GRANT SET ON PARAMETER <superuser_setting> TO authenticator` works, the role settings must be set before the impersonated role.
|
||||
-- Otherwise the GRANT SET would have to be applied to the impersonated role. See https://github.com/PostgREST/postgrest/issues/3045
|
||||
"select " <> intercalateSnippet ", " (
|
||||
searchPathSql : roleSettingsSql ++ roleSql ++ claimsSql ++ [methodSql, pathSql] ++ headersSql ++ cookiesSql ++ timezoneSql ++ funcSettingsSql ++ appSettingsSql
|
||||
)
|
||||
where
|
||||
methodSql = setConfigWithConstantName ("request.method", iMethod)
|
||||
pathSql = setConfigWithConstantName ("request.path", iPath)
|
||||
headersSql = setConfigWithConstantNameJSON "request.headers" iHeaders
|
||||
cookiesSql = setConfigWithConstantNameJSON "request.cookies" iCookies
|
||||
claimsSql = [setConfigWithConstantName ("request.jwt.claims", LBS.toStrict $ JSON.encode claims)]
|
||||
where
|
||||
claims = authClaims & KM.insert "role" (JSON.String $ decodeUtf8 authRole) -- insert "role" to claims as well
|
||||
|
||||
roleSql = [setConfigWithConstantName ("role", authRole)]
|
||||
roleSettingsSql = setConfigWithDynamicName <$> HM.toList (fromMaybe mempty $ HM.lookup authRole configRoleSettings)
|
||||
appSettingsSql = setConfigWithDynamicName . join bimap toUtf8 <$> configAppSettings
|
||||
timezoneSql = maybe mempty (\(PreferTimezone tz) -> [setConfigWithConstantName ("timezone", tz)]) $ preferTimezone iPreferences
|
||||
funcSettingsSql = setConfigWithDynamicName . join bimap toUtf8 <$> funcSettings
|
||||
searchPathSql =
|
||||
let schemas = escapeIdentList (iSchema : configDbExtraSearchPath) in
|
||||
setConfigWithConstantName ("search_path", schemas)
|
||||
funcSettings = case dbActPlan of
|
||||
DbCrud _ CallReadPlan{crProc} -> pdFuncSettings crProc
|
||||
_ -> mempty
|
||||
|
||||
-- runs the pre-request function
|
||||
preReqQuery :: QualifiedIdentifier -> SQL.Snippet
|
||||
preReqQuery preRequest = "select " <> fromQi preRequest <> "()"
|
||||
@@ -0,0 +1,284 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-|
|
||||
Module : PostgREST.Query.QueryBuilder
|
||||
Description : PostgREST SQL queries generating functions.
|
||||
|
||||
This module provides functions to consume data types that
|
||||
represent database queries (e.g. ReadPlanTree, MutatePlan) and SqlFragment
|
||||
to produce SqlQuery type outputs.
|
||||
-}
|
||||
module PostgREST.Query.QueryBuilder
|
||||
( readPlanToQuery
|
||||
, mutatePlanToQuery
|
||||
, readPlanToCountQuery
|
||||
, callPlanToQuery
|
||||
, limitedQuery
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Set as S
|
||||
import qualified Hasql.DynamicStatements.Snippet as SQL
|
||||
import qualified Hasql.Encoders as HE
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Tree (Tree (..))
|
||||
|
||||
import PostgREST.ApiRequest.Preferences (PreferResolution (..))
|
||||
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..))
|
||||
import PostgREST.SchemaCache.Relationship (Cardinality (..),
|
||||
Junction (..),
|
||||
Relationship (..))
|
||||
import PostgREST.SchemaCache.Routine (RoutineParam (..))
|
||||
|
||||
import PostgREST.ApiRequest.Types
|
||||
import PostgREST.Plan.CallPlan
|
||||
import PostgREST.Plan.MutatePlan
|
||||
import PostgREST.Plan.ReadPlan
|
||||
import PostgREST.Plan.Types
|
||||
import PostgREST.Query.SqlFragment
|
||||
|
||||
import Protolude
|
||||
|
||||
readPlanToQuery :: ReadPlanTree -> SQL.Snippet
|
||||
readPlanToQuery node@(Node ReadPlan{select,from=mainQi,fromAlias,where_=logicForest,order, range_=readRange, relToParent, relJoinConds, relSelect, relSpread} forest) =
|
||||
"SELECT " <>
|
||||
intercalateSnippet ", " (selects ++ sprExtraSelects ++ joinsSelects) <>
|
||||
fromFrag <>
|
||||
intercalateSnippet " " joins <>
|
||||
(if null logicForest && null relJoinConds
|
||||
then mempty
|
||||
else " WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCondition relJoinConds)) <> " " <>
|
||||
groupF qi select relSelect <> " " <>
|
||||
orderF qi order <> " " <>
|
||||
limitOffsetF readRange
|
||||
where
|
||||
fromFrag = fromF relToParent mainQi fromAlias
|
||||
qi = getQualifiedIdentifier relToParent mainQi fromAlias
|
||||
-- gets all the columns in case of an empty select, ignoring/obtaining these columns is done at the aggregation stage
|
||||
defSelect = [CoercibleSelectField (unknownField "*" []) Nothing Nothing Nothing Nothing]
|
||||
joins = getJoins node
|
||||
selects = pgFmtSelectItem qi <$> (if null select && null forest then defSelect else select)
|
||||
joinsSelects = getJoinSelects node
|
||||
sprExtraSelects = case relSpread of
|
||||
Just (ToManySpread sels _) -> (\s -> pgFmtSelectItem (maybe qi (QualifiedIdentifier "") $ fst s) $ snd s) <$> sels
|
||||
_ -> mempty
|
||||
|
||||
getJoinSelects :: ReadPlanTree -> [SQL.Snippet]
|
||||
getJoinSelects (Node ReadPlan{relSelect} _) =
|
||||
join $ map relSelectToSnippet relSelect
|
||||
where
|
||||
relSelectToSnippet :: RelSelectField -> [SQL.Snippet]
|
||||
relSelectToSnippet fld =
|
||||
let aggAlias = pgFmtIdent $ rsAggAlias fld
|
||||
in
|
||||
case fld of
|
||||
JsonEmbed{rsEmptyEmbed = True} ->
|
||||
[]
|
||||
JsonEmbed{rsSelName, rsEmbedMode = JsonObject} ->
|
||||
["row_to_json(" <> aggAlias <> ".*)::jsonb AS " <> pgFmtIdent rsSelName]
|
||||
JsonEmbed{rsSelName, rsEmbedMode = JsonArray} ->
|
||||
["COALESCE( " <> aggAlias <> "." <> aggAlias <> ", '[]') AS " <> pgFmtIdent rsSelName]
|
||||
Spread{rsSpreadSel, rsAggAlias} ->
|
||||
pgFmtSpreadSelectItem rsAggAlias <$> rsSpreadSel
|
||||
|
||||
getJoins :: ReadPlanTree -> [SQL.Snippet]
|
||||
getJoins (Node _ []) = []
|
||||
getJoins (Node ReadPlan{relSelect} forest) =
|
||||
map (\fld ->
|
||||
let alias = rsAggAlias fld
|
||||
matchingNode = fromJust $ find (\(Node ReadPlan{relAggAlias} _) -> alias == relAggAlias) forest
|
||||
in getJoin fld matchingNode
|
||||
) relSelect
|
||||
|
||||
getJoin :: RelSelectField -> ReadPlanTree -> SQL.Snippet
|
||||
getJoin fld node@(Node ReadPlan{relJoinType, relSpread} _) =
|
||||
let
|
||||
correlatedSubquery sub al cond =
|
||||
" " <> (if relJoinType == Just JTInner then "INNER" else "LEFT") <> " JOIN LATERAL ( " <> sub <> " ) AS " <> al <> " ON " <> cond
|
||||
subquery = readPlanToQuery node
|
||||
aggAlias = pgFmtIdent $ rsAggAlias fld
|
||||
selectSubqAgg = "SELECT json_agg(" <> aggAlias <> ")::jsonb AS " <> aggAlias
|
||||
fromSubqAgg = " FROM (" <> subquery <> " ) AS " <> aggAlias
|
||||
joinCondition = if relJoinType == Just JTInner then aggAlias <> " IS NOT NULL" else "TRUE"
|
||||
in
|
||||
case fld of
|
||||
JsonEmbed{rsEmbedMode = JsonObject} ->
|
||||
correlatedSubquery subquery aggAlias "TRUE"
|
||||
Spread{rsSpreadSel, rsAggAlias} ->
|
||||
case relSpread of
|
||||
Just (ToManySpread _ sprOrder) ->
|
||||
let selSpread = selectSubqAgg <> (if null rsSpreadSel then mempty else ", ") <> intercalateSnippet ", " (pgFmtSpreadJoinSelectItem rsAggAlias sprOrder <$> rsSpreadSel)
|
||||
in correlatedSubquery (selSpread <> fromSubqAgg) aggAlias joinCondition
|
||||
_ ->
|
||||
correlatedSubquery subquery aggAlias "TRUE"
|
||||
JsonEmbed{rsEmbedMode = JsonArray} ->
|
||||
correlatedSubquery (selectSubqAgg <> fromSubqAgg) aggAlias joinCondition
|
||||
|
||||
mutatePlanToQuery :: MutatePlan -> SQL.Snippet
|
||||
mutatePlanToQuery (Insert mainQi iCols body onConflict putConditions returnings _ applyDefaults) =
|
||||
"INSERT INTO " <> fromQi mainQi <> (if null iCols then " " else "(" <> cols <> ") ") <>
|
||||
fromJsonBodyF body iCols True False applyDefaults <>
|
||||
-- Only used for PUT
|
||||
(if null putConditions then mempty else "WHERE " <> addConfigPgrstInserted True <> " AND " <> intercalateSnippet " AND " (pgFmtLogicTree (QualifiedIdentifier mempty "pgrst_body") <$> putConditions)) <>
|
||||
(if null putConditions && mergeDups then "WHERE " <> addConfigPgrstInserted True else mempty) <>
|
||||
maybe mempty (\(oncDo, oncCols) ->
|
||||
if null oncCols then
|
||||
mempty
|
||||
else
|
||||
" ON CONFLICT(" <> intercalateSnippet ", " (pgFmtIdent <$> oncCols) <> ") " <> case oncDo of
|
||||
IgnoreDuplicates ->
|
||||
"DO NOTHING"
|
||||
MergeDuplicates ->
|
||||
if null iCols
|
||||
then "DO NOTHING"
|
||||
else "DO UPDATE SET " <> intercalateSnippet ", " ((pgFmtIdent . cfName) <> const " = EXCLUDED." <> (pgFmtIdent . cfName) <$> iCols) <> (if null putConditions && not mergeDups then mempty else "WHERE " <> addConfigPgrstInserted False)
|
||||
) onConflict <> " " <>
|
||||
returningF mainQi returnings
|
||||
where
|
||||
cols = intercalateSnippet ", " $ pgFmtIdent . cfName <$> iCols
|
||||
mergeDups = case onConflict of {Just (MergeDuplicates,_) -> True; _ -> False;}
|
||||
|
||||
mutatePlanToQuery (Update mainQi uCols body logicForest returnings applyDefaults)
|
||||
| null uCols =
|
||||
-- if there are no columns we cannot do UPDATE table SET {empty}, it'd be invalid syntax
|
||||
-- selecting an empty resultset from mainQi gives us the column names to prevent errors when using &select=
|
||||
-- the select has to be based on "returnings" to make computed overloaded functions not throw
|
||||
"SELECT " <> emptyBodyReturnedColumns <> " FROM " <> fromQi mainQi <> " WHERE false"
|
||||
|
||||
| otherwise =
|
||||
"UPDATE " <> mainTbl <> " SET " <> cols <> " " <>
|
||||
fromJsonBodyF body uCols False False applyDefaults <>
|
||||
whereLogic <> " " <>
|
||||
returningF mainQi returnings
|
||||
|
||||
where
|
||||
whereLogic = if null logicForest then mempty else " WHERE " <> intercalateSnippet " AND " (pgFmtLogicTree mainQi <$> logicForest)
|
||||
mainTbl = fromQi mainQi
|
||||
emptyBodyReturnedColumns = if null returnings then "NULL" else intercalateSnippet ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName mainQi) <$> returnings)
|
||||
cols = intercalateSnippet ", " (pgFmtIdent . cfName <> const " = " <> pgFmtColumn (QualifiedIdentifier mempty "pgrst_body") . cfName <$> uCols)
|
||||
|
||||
mutatePlanToQuery (Delete mainQi logicForest returnings) =
|
||||
"DELETE FROM " <> fromQi mainQi <> " " <>
|
||||
whereLogic <> " " <>
|
||||
returningF mainQi returnings
|
||||
where
|
||||
whereLogic = if null logicForest then mempty else " WHERE " <> intercalateSnippet " AND " (pgFmtLogicTree mainQi <$> logicForest)
|
||||
|
||||
callPlanToQuery :: CallPlan -> SQL.Snippet
|
||||
callPlanToQuery (FunctionCall qi params arguments returnsScalar returnsSetOfScalar filterFields returnings) =
|
||||
"SELECT " <> (if returnsScalar || returnsSetOfScalar then "pgrst_call.pgrst_scalar" else returnedColumns) <> " " <>
|
||||
fromCall
|
||||
where
|
||||
jsonArgs = case arguments of
|
||||
DirectArgs args -> Just $ JSON.encode args
|
||||
JsonArgs json -> json
|
||||
fromCall = case params of
|
||||
OnePosParam prm -> "FROM " <> callIt (singleParameter jsonArgs $ encodeUtf8 $ ppType prm)
|
||||
KeyParams [] -> "FROM " <> callIt mempty
|
||||
KeyParams prms -> case arguments of
|
||||
DirectArgs args -> "FROM " <> callIt (fmtArgs prms args)
|
||||
JsonArgs json -> fromJsonBodyF json ((\p -> CoercibleField (ppName p) mempty False Nothing (ppTypeMaxLength p) mempty Nothing Nothing False) <$> prms) False True False <> ", " <>
|
||||
"LATERAL " <> callIt (fmtParams prms)
|
||||
|
||||
callIt :: SQL.Snippet -> SQL.Snippet
|
||||
callIt argument | returnsScalar || returnsSetOfScalar = "(SELECT " <> fromQi qi <> "(" <> argument <> ") pgrst_scalar) pgrst_call"
|
||||
| otherwise = fromQi qi <> "(" <> argument <> ") pgrst_call"
|
||||
|
||||
fmtParams :: [RoutineParam] -> SQL.Snippet
|
||||
fmtParams prms = intercalateSnippet ", "
|
||||
((\a -> (if ppVar a then "VARIADIC " else mempty) <> pgFmtIdent (ppName a) <> " := pgrst_body." <> pgFmtIdent (ppName a)) <$> prms)
|
||||
|
||||
fmtArgs :: [RoutineParam] -> HM.HashMap Text RpcParamValue -> SQL.Snippet
|
||||
fmtArgs prms args = intercalateSnippet ", " $ fmtArg <$> prms
|
||||
where
|
||||
fmtArg RoutineParam{..} =
|
||||
(if ppVar then "VARIADIC " else mempty) <>
|
||||
pgFmtIdent ppName <>
|
||||
" := " <>
|
||||
encodeArg (HM.lookup ppName args) <>
|
||||
"::" <>
|
||||
SQL.sql (encodeUtf8 ppTypeMaxLength)
|
||||
encodeArg :: Maybe RpcParamValue -> SQL.Snippet
|
||||
encodeArg (Just (Variadic v)) = SQL.encoderAndParam (HE.nonNullable $ HE.foldableArray $ HE.nonNullable HE.text) v
|
||||
encodeArg (Just (Fixed v)) = SQL.encoderAndParam (HE.nonNullable HE.unknown) $ encodeUtf8 v
|
||||
-- Currently not supported: Calling functions without some of their arguments without DEFAULT.
|
||||
-- We could fallback to providing this NULL value in those cases.
|
||||
encodeArg Nothing = "NULL"
|
||||
|
||||
-- the columns here would be the returnings + the columns that would later
|
||||
-- be used by a where clause filter, if they intersect, we remove the duplicates
|
||||
-- and if * is returned then no need to explicitly add filter columns
|
||||
returnedColumns :: SQL.Snippet
|
||||
returnedColumns = case S.toList returnings of
|
||||
[] -> "*"
|
||||
["*"] -> pgFmtColumn (QualifiedIdentifier mempty "pgrst_call") "*"
|
||||
_ -> intercalateSnippet ", " (pgFmtColumn (QualifiedIdentifier mempty "pgrst_call") <$> returnedColumns')
|
||||
where
|
||||
returnedColumns' = S.toList $ returnings <> filterFields
|
||||
|
||||
-- | SQL query meant for COUNTing the root node of the Tree.
|
||||
-- It only takes WHERE into account and doesn't include LIMIT/OFFSET because it would reduce the COUNT.
|
||||
-- SELECT 1 is done instead of SELECT * to prevent doing expensive operations(like functions based on the columns)
|
||||
-- inside the FROM target.
|
||||
-- If the request contains INNER JOINs, then the COUNT of the root node will change.
|
||||
-- For this case, we use a WHERE EXISTS instead of an INNER JOIN on the count query.
|
||||
-- See https://github.com/PostgREST/postgrest/issues/2009#issuecomment-977473031
|
||||
-- Only for the nodes that have an INNER JOIN linked to the root level.
|
||||
readPlanToCountQuery :: ReadPlanTree -> SQL.Snippet
|
||||
readPlanToCountQuery (Node ReadPlan{from=mainQi, fromAlias=tblAlias, where_=logicForest, relToParent=rel, relJoinConds} forest) =
|
||||
"SELECT 1 " <> fromFrag <>
|
||||
(if null logicForest && null relJoinConds && null subQueries
|
||||
then mempty
|
||||
else " WHERE " ) <>
|
||||
intercalateSnippet " AND " (
|
||||
map (pgFmtLogicTreeCount qi) logicForest ++
|
||||
map pgFmtJoinCondition relJoinConds ++
|
||||
subQueries
|
||||
)
|
||||
where
|
||||
qi = getQualifiedIdentifier rel mainQi tblAlias
|
||||
fromFrag = fromF rel mainQi tblAlias
|
||||
subQueries = foldr existsSubquery [] forest
|
||||
existsSubquery :: ReadPlanTree -> [SQL.Snippet] -> [SQL.Snippet]
|
||||
existsSubquery readReq@(Node ReadPlan{relJoinType=joinType} _) rest =
|
||||
if joinType == Just JTInner
|
||||
then ("EXISTS (" <> readPlanToCountQuery readReq <> " )"):rest
|
||||
else rest
|
||||
findNullEmbedRel fld = find (\(Node ReadPlan{relAggAlias} _) -> fld == relAggAlias) forest
|
||||
|
||||
-- https://github.com/PostgREST/postgrest/pull/2930#discussion_r1325293698
|
||||
pgFmtLogicTreeCount :: QualifiedIdentifier -> CoercibleLogicTree -> SQL.Snippet
|
||||
pgFmtLogicTreeCount qiCount (CoercibleExpr hasNot op frst) = SQL.sql notOp <> " (" <> intercalateSnippet (opSql op) (pgFmtLogicTreeCount qiCount <$> frst) <> ")"
|
||||
where
|
||||
notOp = if hasNot then "NOT" else mempty
|
||||
opSql And = " AND "
|
||||
opSql Or = " OR "
|
||||
pgFmtLogicTreeCount _ (CoercibleStmnt (CoercibleFilterNullEmbed hasNot fld)) =
|
||||
maybe mempty (\x -> (if not hasNot then "NOT " else mempty) <> "EXISTS (" <> readPlanToCountQuery x <> ")") (findNullEmbedRel fld)
|
||||
pgFmtLogicTreeCount qiCount (CoercibleStmnt flt) = pgFmtFilter qiCount flt
|
||||
|
||||
limitedQuery :: SQL.Snippet -> Maybe Integer -> SQL.Snippet
|
||||
limitedQuery query maxRows = query <> SQL.sql (maybe mempty (\x -> " LIMIT " <> BS.pack (show x)) maxRows)
|
||||
|
||||
-- TODO refactor so this function is unneeded and ComputedRelationship QualifiedIdentifier comes from the ReadPlan type
|
||||
getQualifiedIdentifier :: Maybe Relationship -> QualifiedIdentifier -> Maybe Alias -> QualifiedIdentifier
|
||||
getQualifiedIdentifier rel mainQi tblAlias = case rel of
|
||||
Just ComputedRelationship{relFunction} -> QualifiedIdentifier mempty $ fromMaybe (qiName relFunction) tblAlias
|
||||
_ -> maybe mainQi (QualifiedIdentifier mempty) tblAlias
|
||||
|
||||
-- FROM clause plus implicit joins
|
||||
fromF :: Maybe Relationship -> QualifiedIdentifier -> Maybe Alias -> SQL.Snippet
|
||||
fromF rel mainQi tblAlias = " FROM " <>
|
||||
(case rel of
|
||||
-- Due to the use of CTEs on RPC, we need to cast the parameter to the table name in case of function overloading.
|
||||
-- See https://github.com/PostgREST/postgrest/issues/2963#issuecomment-1736557386
|
||||
Just ComputedRelationship{relFunction,relTableAlias,relTable} -> fromQi relFunction <> "(" <> pgFmtIdent (qiName relTableAlias) <> "::" <> fromQi relTable <> ")"
|
||||
_ -> fromQi mainQi) <>
|
||||
maybe mempty (\a -> " AS " <> pgFmtIdent a) tblAlias <>
|
||||
(case rel of
|
||||
Just Relationship{relCardinality=M2M Junction{junTable=jt}} -> ", " <> fromQi jt
|
||||
_ -> mempty)
|
||||
@@ -0,0 +1,712 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-|
|
||||
Module : PostgREST.Query.SqlFragment
|
||||
Description : Helper functions for PostgREST.QueryBuilder.
|
||||
-}
|
||||
module PostgREST.Query.SqlFragment
|
||||
( accessibleFuncs
|
||||
, accessibleTables
|
||||
, addConfigPgrstInserted
|
||||
, countF
|
||||
, currentSettingF
|
||||
, escapeIdent
|
||||
, escapeIdentList
|
||||
, explainF
|
||||
, fromJsonBodyF
|
||||
, fromQi
|
||||
, groupF
|
||||
, handlerF
|
||||
, intercalateSnippet
|
||||
, limitOffsetF
|
||||
, locationF
|
||||
, noLocationF
|
||||
, orderF
|
||||
, pageCountSelectF
|
||||
, pgFmtColumn
|
||||
, pgFmtFilter
|
||||
, pgFmtIdent
|
||||
, pgFmtJoinCondition
|
||||
, pgFmtLogicTree
|
||||
, pgFmtOrderTerm
|
||||
, pgFmtSelectItem
|
||||
, pgFmtSpreadJoinSelectItem
|
||||
, pgFmtSpreadSelectItem
|
||||
, responseHeadersF
|
||||
, responseStatusF
|
||||
, returningF
|
||||
, schemaDescription
|
||||
, setConfigWithConstantName
|
||||
, setConfigWithConstantNameJSON
|
||||
, setConfigWithDynamicName
|
||||
, singleParameter
|
||||
, sourceCTE
|
||||
, sourceCTEName
|
||||
, unknownEncoder
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Hasql.DynamicStatements.Snippet as SQL
|
||||
import qualified Hasql.Encoders as HE
|
||||
|
||||
import Control.Arrow ((***))
|
||||
|
||||
import Data.Foldable (foldr1)
|
||||
import NeatInterpolation (trimming)
|
||||
|
||||
import PostgREST.ApiRequest.Types (AggregateFunction (..),
|
||||
Alias, Cast,
|
||||
FtsOperator (..),
|
||||
IsVal (..),
|
||||
JsonOperand (..),
|
||||
JsonOperation (..),
|
||||
JsonPath,
|
||||
LogicOperator (..),
|
||||
OpExpr (..),
|
||||
OpQuantifier (..),
|
||||
Operation (..),
|
||||
OrderDirection (..),
|
||||
OrderNulls (..),
|
||||
QuantOperator (..),
|
||||
SimpleOperator (..))
|
||||
import PostgREST.MediaType (MTVndPlanFormat (..),
|
||||
MTVndPlanOption (..))
|
||||
import PostgREST.Plan.ReadPlan (JoinCondition (..))
|
||||
import PostgREST.Plan.Types (CoercibleField (..),
|
||||
CoercibleFilter (..),
|
||||
CoercibleLogicTree (..),
|
||||
CoercibleOrderTerm (..),
|
||||
CoercibleSelectField (..),
|
||||
RelSelectField (..),
|
||||
SpreadSelectField (..),
|
||||
ToTsVector (..),
|
||||
unknownField)
|
||||
import PostgREST.RangeQuery (NonnegRange, allRange,
|
||||
rangeLimit, rangeOffset)
|
||||
import PostgREST.SchemaCache.Identifiers (FieldName,
|
||||
QualifiedIdentifier (..),
|
||||
RelIdentifier (..),
|
||||
escapeIdent, trimNullChars)
|
||||
import PostgREST.SchemaCache.Routine (MediaHandler (..),
|
||||
Routine (..),
|
||||
funcReturnsScalar,
|
||||
funcReturnsSetOfScalar,
|
||||
funcReturnsSingle,
|
||||
funcReturnsSingleComposite)
|
||||
|
||||
import Protolude hiding (Sum, cast)
|
||||
|
||||
sourceCTEName :: Text
|
||||
sourceCTEName = "pgrst_source"
|
||||
|
||||
sourceCTE :: SQL.Snippet
|
||||
sourceCTE = "pgrst_source"
|
||||
|
||||
noLocationF :: SQL.Snippet
|
||||
noLocationF = "array[]::text[]"
|
||||
|
||||
simpleOperator :: SimpleOperator -> SQL.Snippet
|
||||
simpleOperator = \case
|
||||
OpNotEqual -> "<>"
|
||||
OpContains -> "@>"
|
||||
OpContained -> "<@"
|
||||
OpOverlap -> "&&"
|
||||
OpStrictlyLeft -> "<<"
|
||||
OpStrictlyRight -> ">>"
|
||||
OpNotExtendsRight -> "&<"
|
||||
OpNotExtendsLeft -> "&>"
|
||||
OpAdjacent -> "-|-"
|
||||
|
||||
quantOperator :: QuantOperator -> SQL.Snippet
|
||||
quantOperator = \case
|
||||
OpEqual -> "="
|
||||
OpGreaterThanEqual -> ">="
|
||||
OpGreaterThan -> ">"
|
||||
OpLessThanEqual -> "<="
|
||||
OpLessThan -> "<"
|
||||
OpLike -> "like"
|
||||
OpILike -> "ilike"
|
||||
OpMatch -> "~"
|
||||
OpIMatch -> "~*"
|
||||
|
||||
ftsOperator :: FtsOperator -> SQL.Snippet
|
||||
ftsOperator = \case
|
||||
FilterFts -> "@@ to_tsquery"
|
||||
FilterFtsPlain -> "@@ plainto_tsquery"
|
||||
FilterFtsPhrase -> "@@ phraseto_tsquery"
|
||||
FilterFtsWebsearch -> "@@ websearch_to_tsquery"
|
||||
|
||||
singleParameter :: Maybe LBS.ByteString -> ByteString -> SQL.Snippet
|
||||
singleParameter body typ =
|
||||
if typ == "bytea"
|
||||
-- TODO: Hasql fails when using HE.unknown with bytea(pg tries to utf8 encode).
|
||||
then SQL.encoderAndParam (HE.nullable HE.bytea) (LBS.toStrict <$> body)
|
||||
else SQL.encoderAndParam (HE.nullable HE.unknown) (LBS.toStrict <$> body) <> "::" <> SQL.sql typ
|
||||
|
||||
-- Here we build the pg array literal, e.g '{"Hebdon, John","Other","Another"}', manually.
|
||||
-- This is necessary to pass an "unknown" array and let pg infer the type.
|
||||
-- There are backslashes here, but since this value is parametrized and is not a string constant
|
||||
-- https://www.postgresql.org/docs/current/sql-syntax-lexical.html#SQL-SYNTAX-STRINGS
|
||||
-- we don't need to use the E'string' form for C-style escapes
|
||||
-- https://www.postgresql.org/docs/current/sql-syntax-lexical.html#SQL-SYNTAX-STRINGS-ESCAPE
|
||||
pgBuildArrayLiteral :: [Text] -> Text
|
||||
pgBuildArrayLiteral vals =
|
||||
let trimmed = trimNullChars
|
||||
slashed = T.replace "\\" "\\\\" . trimmed
|
||||
escaped x = "\"" <> T.replace "\"" "\\\"" (slashed x) <> "\"" in
|
||||
"{" <> T.intercalate "," (escaped <$> vals) <> "}"
|
||||
|
||||
-- TODO: refactor by following https://github.com/PostgREST/postgrest/pull/1631#issuecomment-711070833
|
||||
pgFmtIdent :: Text -> SQL.Snippet
|
||||
pgFmtIdent x = SQL.sql . encodeUtf8 $ escapeIdent x
|
||||
|
||||
-- Only use it if the input comes from the database itself, like on `jsonb_build_object('column_from_a_table', val)..`
|
||||
pgFmtLit :: Text -> Text
|
||||
pgFmtLit x =
|
||||
let trimmed = trimNullChars x
|
||||
escaped = "'" <> T.replace "'" "''" trimmed <> "'"
|
||||
slashed = T.replace "\\" "\\\\" escaped in
|
||||
if "\\" `T.isInfixOf` escaped
|
||||
then "E" <> slashed
|
||||
else slashed
|
||||
|
||||
-- |
|
||||
-- Format a list of identifiers and separate them by commas.
|
||||
--
|
||||
-- >>> escapeIdentList ["schema_1", "schema_2", "SPECIAL \"@/\\#~_-"]
|
||||
-- "\"schema_1\", \"schema_2\", \"SPECIAL \"\"@/\\#~_-\""
|
||||
escapeIdentList :: [Text] -> ByteString
|
||||
escapeIdentList schemas = BS.intercalate ", " $ encodeUtf8 . escapeIdent <$> schemas
|
||||
|
||||
asCsvF :: SQL.Snippet
|
||||
asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
|
||||
where
|
||||
asCsvHeaderF =
|
||||
"(SELECT coalesce(string_agg(a.k, ','), '')" <>
|
||||
" FROM (" <>
|
||||
" SELECT json_object_keys(r)::text as k" <>
|
||||
" FROM ( " <>
|
||||
" SELECT row_to_json(hh) as r from " <> sourceCTE <> " as hh limit 1" <>
|
||||
" ) s" <>
|
||||
" ) a" <>
|
||||
")"
|
||||
asCsvBodyF = "coalesce(string_agg(substring(_postgrest_t::text, 2, length(_postgrest_t::text) - 2), '\n'), '')"
|
||||
|
||||
addNullsToSnip :: Bool -> SQL.Snippet -> SQL.Snippet
|
||||
addNullsToSnip strip snip =
|
||||
if strip then "json_strip_nulls(" <> snip <> ")" else snip
|
||||
|
||||
asJsonSingleF :: Maybe Routine -> Bool -> SQL.Snippet
|
||||
asJsonSingleF rout strip
|
||||
| returnsScalar = "coalesce(" <> addNullsToSnip strip "json_agg(_postgrest_t.pgrst_scalar)->0" <> ", 'null')"
|
||||
| otherwise = "coalesce(" <> addNullsToSnip strip "json_agg(_postgrest_t)->0" <> ", 'null')"
|
||||
where
|
||||
returnsScalar = maybe False funcReturnsScalar rout
|
||||
|
||||
asJsonF :: Maybe Routine -> Bool -> SQL.Snippet
|
||||
asJsonF rout strip
|
||||
| returnsSingleComposite = "coalesce(" <> addNullsToSnip strip "json_agg(_postgrest_t)->0" <> ", 'null')"
|
||||
| returnsScalar = "coalesce(" <> addNullsToSnip strip "json_agg(_postgrest_t.pgrst_scalar)->0" <> ", 'null')"
|
||||
| returnsSetOfScalar = "coalesce(" <> addNullsToSnip strip "json_agg(_postgrest_t.pgrst_scalar)" <> ", '[]')"
|
||||
| otherwise = "coalesce(" <> addNullsToSnip strip "json_agg(_postgrest_t)" <> ", '[]')"
|
||||
where
|
||||
(returnsSingleComposite, returnsScalar, returnsSetOfScalar) = case rout of
|
||||
Just r -> (funcReturnsSingleComposite r, funcReturnsScalar r, funcReturnsSetOfScalar r)
|
||||
Nothing -> (False, False, False)
|
||||
|
||||
asGeoJsonF :: SQL.Snippet
|
||||
asGeoJsonF = "json_build_object('type', 'FeatureCollection', 'features', coalesce(json_agg(ST_AsGeoJSON(_postgrest_t)::json), '[]'))"
|
||||
|
||||
customFuncF :: Maybe Routine -> QualifiedIdentifier -> RelIdentifier -> SQL.Snippet
|
||||
customFuncF rout funcQi _
|
||||
| (funcReturnsScalar <$> rout) == Just True = fromQi funcQi <> "(_postgrest_t.pgrst_scalar)"
|
||||
customFuncF _ funcQi RelAnyElement = fromQi funcQi <> "(_postgrest_t)"
|
||||
customFuncF _ funcQi (RelId target) = fromQi funcQi <> "(_postgrest_t::" <> fromQi target <> ")"
|
||||
|
||||
locationF :: [Text] -> SQL.Snippet
|
||||
locationF pKeys = SQL.sql $ encodeUtf8 [trimming|(
|
||||
WITH data AS (SELECT row_to_json(_) AS row FROM ${sourceCTEName} AS _ LIMIT 1)
|
||||
SELECT array_agg(json_data.key || '=' || coalesce('eq.' || json_data.value, 'is.null'))
|
||||
FROM data CROSS JOIN json_each_text(data.row) AS json_data
|
||||
WHERE json_data.key IN ('${fmtPKeys}')
|
||||
)|]
|
||||
where
|
||||
fmtPKeys = T.intercalate "','" pKeys
|
||||
|
||||
fromQi :: QualifiedIdentifier -> SQL.Snippet
|
||||
fromQi t = (if T.null s then mempty else pgFmtIdent s <> ".") <> pgFmtIdent n
|
||||
where
|
||||
n = qiName t
|
||||
s = qiSchema t
|
||||
|
||||
pgFmtColumn :: QualifiedIdentifier -> Text -> SQL.Snippet
|
||||
pgFmtColumn table "*" = fromQi table <> ".*"
|
||||
pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c
|
||||
|
||||
pgFmtCallUnary :: Text -> SQL.Snippet -> SQL.Snippet
|
||||
pgFmtCallUnary f x = SQL.sql (encodeUtf8 f) <> "(" <> x <> ")"
|
||||
|
||||
pgFmtField :: QualifiedIdentifier -> CoercibleField -> SQL.Snippet
|
||||
pgFmtField table cf = case cfToTsVector cf of
|
||||
Just (ToTsVector lang) -> "to_tsvector(" <> pgFmtFtsLang lang <> fmtFld <> ")"
|
||||
_ -> fmtFld
|
||||
where
|
||||
fmtFld = case cf of
|
||||
CoercibleField{cfFullRow=True} -> pgFmtIdent (qiName table)
|
||||
CoercibleField{cfName=fn, cfJsonPath=[]} -> pgFmtColumn table fn
|
||||
CoercibleField{cfName=fn, cfToJson=doToJson, cfJsonPath=jp} | doToJson -> "to_jsonb(" <> pgFmtColumn table fn <> ")" <> pgFmtJsonPath jp
|
||||
| otherwise -> pgFmtColumn table fn <> pgFmtJsonPath jp
|
||||
|
||||
-- Select the value of a named element from a table, applying its optional coercion mapping if any.
|
||||
pgFmtTableCoerce :: QualifiedIdentifier -> CoercibleField -> SQL.Snippet
|
||||
pgFmtTableCoerce table fld@(CoercibleField{cfTransform=(Just formatterProc)}) = pgFmtCallUnary formatterProc (pgFmtField table fld)
|
||||
pgFmtTableCoerce table f = pgFmtField table f
|
||||
|
||||
-- | Like the previous but now we just have a name so no namespace or JSON paths.
|
||||
pgFmtCoerceNamed :: CoercibleField -> SQL.Snippet
|
||||
pgFmtCoerceNamed CoercibleField{cfName=fn, cfTransform=(Just formatterProc)} = pgFmtCallUnary formatterProc (pgFmtIdent fn) <> " AS " <> pgFmtIdent fn
|
||||
pgFmtCoerceNamed CoercibleField{cfName=fn} = pgFmtIdent fn
|
||||
|
||||
pgFmtSelectItem :: QualifiedIdentifier -> CoercibleSelectField -> SQL.Snippet
|
||||
pgFmtSelectItem table CoercibleSelectField{csField=fld, csAggFunction=agg, csAggCast=aggCast, csCast=cast, csAlias=alias} =
|
||||
pgFmtApplyAggregate agg aggCast (pgFmtApplyCast cast (pgFmtTableCoerce table fld)) <> pgFmtAs alias
|
||||
|
||||
pgFmtSpreadSelectItem :: Alias -> SpreadSelectField -> SQL.Snippet
|
||||
pgFmtSpreadSelectItem aggAlias SpreadSelectField{ssSelName, ssSelAggFunction, ssSelAggCast, ssSelAlias} =
|
||||
pgFmtApplyAggregate ssSelAggFunction ssSelAggCast (pgFmtFullSelName aggAlias ssSelName) <> pgFmtAs ssSelAlias
|
||||
|
||||
pgFmtApplyAggregate :: Maybe AggregateFunction -> Maybe Cast -> SQL.Snippet -> SQL.Snippet
|
||||
pgFmtApplyAggregate Nothing _ snippet = snippet
|
||||
pgFmtApplyAggregate (Just agg) aggCast snippet =
|
||||
pgFmtApplyCast aggCast aggregatedSnippet
|
||||
where
|
||||
convertAggFunction :: AggregateFunction -> SQL.Snippet
|
||||
-- Convert from e.g. Sum (the data type) to SUM
|
||||
convertAggFunction = SQL.sql . BS.map toUpper . BS.pack . show
|
||||
aggregatedSnippet = convertAggFunction agg <> "(" <> snippet <> ")"
|
||||
|
||||
pgFmtSpreadJoinSelectItem :: Alias -> [CoercibleOrderTerm] -> SpreadSelectField -> SQL.Snippet
|
||||
pgFmtSpreadJoinSelectItem aggAlias order SpreadSelectField{ssSelName, ssSelAlias} =
|
||||
"COALESCE(json_agg(" <> fmtField <> " " <> fmtOrder <> "),'[]')::jsonb" <> " AS " <> fmtAlias
|
||||
where
|
||||
fmtField = pgFmtFullSelName aggAlias ssSelName
|
||||
fmtOrder = orderF (QualifiedIdentifier "" aggAlias) order
|
||||
fmtAlias = pgFmtIdent (fromMaybe ssSelName ssSelAlias)
|
||||
|
||||
pgFmtApplyCast :: Maybe Cast -> SQL.Snippet -> SQL.Snippet
|
||||
pgFmtApplyCast Nothing snippet = snippet
|
||||
-- Ideally we'd quote the cast with "pgFmtIdent cast". However, that would invalidate common casts such as "int", "bigint", etc.
|
||||
-- Try doing: `select 1::"bigint"` - it'll err, using "int8" will work though. There's some parser magic that pg does that's invalidated when quoting.
|
||||
-- Not quoting should be fine, we validate the input on Parsers.
|
||||
pgFmtApplyCast (Just cast) snippet = "CAST( " <> snippet <> " AS " <> SQL.sql (encodeUtf8 cast) <> " )"
|
||||
|
||||
pgFmtFullSelName :: Alias -> FieldName -> SQL.Snippet
|
||||
pgFmtFullSelName aggAlias fieldName = case fieldName of
|
||||
"*" -> pgFmtIdent aggAlias <> ".*"
|
||||
_ -> pgFmtIdent aggAlias <> "." <> pgFmtIdent fieldName
|
||||
|
||||
-- TODO: At this stage there shouldn't be a Maybe since ApiRequest should ensure that an INSERT/UPDATE has a body
|
||||
fromJsonBodyF :: Maybe LBS.ByteString -> [CoercibleField] -> Bool -> Bool -> Bool -> SQL.Snippet
|
||||
fromJsonBodyF body fields includeSelect includeLimitOne includeDefaults =
|
||||
selectClause <> fromClause <> defaultsClause <> lateralClause <> " pgrst_body "
|
||||
where
|
||||
selectClause = if includeSelect then "SELECT " <> namedCols <> " " else mempty
|
||||
fromClause = "FROM (SELECT " <> jsonPlaceHolder <> " AS json_data) pgrst_payload, "
|
||||
defaultsClause
|
||||
| includeDefaults && isJsonObject = "LATERAL (SELECT " <> defsJsonb <> " || pgrst_payload.json_data AS val) pgrst_json_defs, "
|
||||
| includeDefaults && not isJsonObject = "LATERAL (SELECT jsonb_agg(" <> defsJsonb <> " || elem) AS val from jsonb_array_elements(pgrst_payload.json_data) elem) pgrst_json_defs, "
|
||||
| otherwise = mempty
|
||||
lateralClause = "LATERAL (SELECT " <> parsedCols <> " FROM " <> lateralFieldsSource <> ")"
|
||||
|
||||
namedCols = intercalateSnippet ", " $ fromQi . QualifiedIdentifier "pgrst_body" . cfName <$> fields
|
||||
parsedCols = intercalateSnippet ", " $ pgFmtCoerceNamed <$> fields
|
||||
typedCols = intercalateSnippet ", " $ pgFmtIdent . cfName <> const " " <> SQL.sql . encodeUtf8 . cfIRType <$> fields
|
||||
|
||||
lateralFieldsSource = if null fields then emptyFieldsSource else nonEmptyFieldsSource
|
||||
where
|
||||
limitClause = if includeLimitOne then "LIMIT 1" else mempty
|
||||
nonEmptyFieldsSource = jsonToRecordsetF <> "(" <> finalBodyF <> ") AS _(" <> typedCols <> ") " <> limitClause
|
||||
-- when json keys are empty, e.g. when payload is `{}` or `[{}, {}]`
|
||||
emptyFieldsSource = if isJsonObject
|
||||
then "(values(1)) _ " -- only 1 row for an empty json object '{}'
|
||||
else jsonArrayElementsF <> "(" <> finalBodyF <> ") _ " -- extract rows of a json array of empty objects `[{}, {}]`
|
||||
|
||||
defsJsonb = SQL.sql $ "jsonb_build_object(" <> BS.intercalate "," fieldsWDefaults <> ")"
|
||||
fieldsWDefaults = mapMaybe extractFieldDefault fields
|
||||
where
|
||||
extractFieldDefault CoercibleField{cfName=nam, cfDefault=Just def} = Just $ encodeUtf8 (pgFmtLit nam <> ", " <> def)
|
||||
extractFieldDefault CoercibleField{cfDefault=Nothing} = Nothing
|
||||
|
||||
(finalBodyF, jsonArrayElementsF, jsonToRecordsetF) =
|
||||
if includeDefaults
|
||||
then ("pgrst_json_defs.val", "jsonb_array_elements", if isJsonObject then "jsonb_to_record" else "jsonb_to_recordset")
|
||||
else ("pgrst_payload.json_data", "json_array_elements", if isJsonObject then "json_to_record" else "json_to_recordset")
|
||||
|
||||
jsonPlaceHolder = SQL.encoderAndParam (HE.nullable $ if includeDefaults then HE.jsonbLazyBytes else HE.jsonLazyBytes) body
|
||||
isJsonObject = -- light validation as pg's json_to_record(set) already validates that the body is valid JSON. We just need to know whether the body looks like an object or not.
|
||||
LBS.take 1 (LBS.dropWhile (`elem` insignificantWhitespace) (fromMaybe mempty body)) == "{"
|
||||
where
|
||||
insignificantWhitespace = [32,9,10,13] --" \t\n\r" [32,9,10,13] https://datatracker.ietf.org/doc/html/rfc8259#section-2
|
||||
|
||||
pgFmtOrderTerm :: QualifiedIdentifier -> CoercibleOrderTerm -> SQL.Snippet
|
||||
pgFmtOrderTerm qi ot =
|
||||
fmtOTerm ot <> " " <>
|
||||
SQL.sql (BS.unwords [
|
||||
maybe mempty direction $ coDirection ot,
|
||||
maybe mempty nullOrder $ coNullOrder ot])
|
||||
where
|
||||
fmtOTerm = \case
|
||||
CoercibleOrderTerm{coField=cof} -> pgFmtField qi cof
|
||||
CoercibleOrderRelationTerm{coRelation, coRelTerm=(fn, jp)} -> pgFmtField (QualifiedIdentifier mempty coRelation) (unknownField fn jp)
|
||||
|
||||
direction OrderAsc = "ASC"
|
||||
direction OrderDesc = "DESC"
|
||||
|
||||
nullOrder OrderNullsFirst = "NULLS FIRST"
|
||||
nullOrder OrderNullsLast = "NULLS LAST"
|
||||
|
||||
-- | Interpret a literal in the way the planner indicated through the CoercibleField.
|
||||
pgFmtUnknownLiteralForField :: SQL.Snippet -> CoercibleField -> SQL.Snippet
|
||||
pgFmtUnknownLiteralForField value CoercibleField{cfTransform=(Just parserProc)} = pgFmtCallUnary parserProc value
|
||||
-- But when no transform is requested, we just use the literal as-is.
|
||||
pgFmtUnknownLiteralForField value _ = value
|
||||
|
||||
-- | Array version of the above, used by ANY().
|
||||
pgFmtArrayLiteralForField :: [Text] -> CoercibleField -> SQL.Snippet
|
||||
-- When a transformation is requested, we need to apply the transformation to each element of the array. This could be done by just making a query with `parser(value)` for each value, but may lead to huge query lengths. Imagine `data_representations.color_from_text('...'::text)` for repeated for a hundred values. Instead we use `unnest()` to unpack a standard array literal and then apply the transformation to each element, like a map.
|
||||
-- Note the literals will be treated as text since in every case when we use ANY() the parameters are textual (coming from a query string). We want to rely on the `text->domain` parser to do the right thing.
|
||||
pgFmtArrayLiteralForField values CoercibleField{cfTransform=(Just parserProc)} = SQL.sql "(SELECT " <> pgFmtCallUnary parserProc (SQL.sql "unnest(" <> unknownLiteral (pgBuildArrayLiteral values) <> "::text[])") <> ")"
|
||||
-- When no transformation is requested, we don't need a subquery.
|
||||
pgFmtArrayLiteralForField values _ = unknownLiteral (pgBuildArrayLiteral values)
|
||||
|
||||
|
||||
pgFmtFilter :: QualifiedIdentifier -> CoercibleFilter -> SQL.Snippet
|
||||
pgFmtFilter _ (CoercibleFilterNullEmbed hasNot fld) = pgFmtIdent fld <> " IS " <> (if not hasNot then "NOT " else mempty) <> "DISTINCT FROM NULL"
|
||||
pgFmtFilter _ (CoercibleFilter _ (NoOpExpr _)) = mempty -- TODO unreachable because NoOpExpr is filtered on QueryParams
|
||||
pgFmtFilter table (CoercibleFilter fld (OpExpr hasNot oper)) = notOp <> " " <> pgFmtField table fld <> case oper of
|
||||
Op op val -> " " <> simpleOperator op <> " " <> pgFmtUnknownLiteralForField (unknownLiteral val) fld
|
||||
|
||||
OpQuant op quant val -> " " <> quantOperator op <> " " <> case op of
|
||||
OpLike -> fmtQuant quant $ unknownLiteral (T.map star val)
|
||||
OpILike -> fmtQuant quant $ unknownLiteral (T.map star val)
|
||||
_ -> fmtQuant quant $ pgFmtUnknownLiteralForField (unknownLiteral val) fld
|
||||
|
||||
-- IS cannot be prepared. `PREPARE boolplan AS SELECT * FROM projects where id IS $1` will give a syntax error.
|
||||
-- The above can be fixed by using `PREPARE boolplan AS SELECT * FROM projects where id IS NOT DISTINCT FROM $1;`
|
||||
-- However that would not accept the TRUE/FALSE/NULL/"NOT NULL"/UNKNOWN keywords. See: https://stackoverflow.com/questions/6133525/proper-way-to-set-preparedstatement-parameter-to-null-under-postgres.
|
||||
-- This is why `IS` operands are whitelisted at the Parsers.hs level
|
||||
Is isVal -> " IS " <>
|
||||
case isVal of
|
||||
IsNull -> "NULL"
|
||||
IsNotNull -> "NOT NULL"
|
||||
IsTriTrue -> "TRUE"
|
||||
IsTriFalse -> "FALSE"
|
||||
IsTriUnknown -> "UNKNOWN"
|
||||
|
||||
IsDistinctFrom val -> " IS DISTINCT FROM " <> unknownLiteral val
|
||||
|
||||
-- We don't use "IN", we use "= ANY". IN has the following disadvantages:
|
||||
-- + No way to use an empty value on IN: "col IN ()" is invalid syntax. With ANY we can do "= ANY('{}')"
|
||||
-- + Can invalidate prepared statements: multiple parameters on an IN($1, $2, $3) will lead to using different prepared statements and not take advantage of caching.
|
||||
In vals -> " " <> case vals of
|
||||
[""] -> "= ANY('{}') "
|
||||
_ -> "= ANY (" <> pgFmtArrayLiteralForField vals fld <> ") "
|
||||
|
||||
Fts op lang val -> " " <> ftsOperator op <> "(" <> pgFmtFtsLang lang <> unknownLiteral val <> ") "
|
||||
where
|
||||
notOp = if hasNot then "NOT" else mempty
|
||||
star c = if c == '*' then '%' else c
|
||||
fmtQuant q val = case q of
|
||||
Just QuantAny -> "ANY(" <> val <> ")"
|
||||
Just QuantAll -> "ALL(" <> val <> ")"
|
||||
Nothing -> val
|
||||
|
||||
pgFmtFtsLang :: Maybe Text -> SQL.Snippet
|
||||
pgFmtFtsLang = maybe mempty (\l -> unknownLiteral l <> ", ")
|
||||
|
||||
pgFmtJoinCondition :: JoinCondition -> SQL.Snippet
|
||||
pgFmtJoinCondition (JoinCondition (qi1, col1) (qi2, col2)) =
|
||||
pgFmtColumn qi1 col1 <> " = " <> pgFmtColumn qi2 col2
|
||||
|
||||
pgFmtLogicTree :: QualifiedIdentifier -> CoercibleLogicTree -> SQL.Snippet
|
||||
pgFmtLogicTree qi (CoercibleExpr hasNot op forest) = SQL.sql notOp <> " (" <> intercalateSnippet (opSql op) (pgFmtLogicTree qi <$> forest) <> ")"
|
||||
where
|
||||
notOp = if hasNot then "NOT" else mempty
|
||||
|
||||
opSql And = " AND "
|
||||
opSql Or = " OR "
|
||||
pgFmtLogicTree qi (CoercibleStmnt flt) = pgFmtFilter qi flt
|
||||
|
||||
pgFmtJsonPath :: JsonPath -> SQL.Snippet
|
||||
pgFmtJsonPath = \case
|
||||
[] -> mempty
|
||||
(JArrow x:xs) -> "->" <> pgFmtJsonOperand x <> pgFmtJsonPath xs
|
||||
(J2Arrow x:xs) -> "->>" <> pgFmtJsonOperand x <> pgFmtJsonPath xs
|
||||
where
|
||||
pgFmtJsonOperand (JKey k) = unknownLiteral k
|
||||
pgFmtJsonOperand (JIdx i) = unknownLiteral i <> "::int"
|
||||
|
||||
pgFmtAs :: Maybe Alias -> SQL.Snippet
|
||||
pgFmtAs Nothing = mempty
|
||||
pgFmtAs (Just alias) = " AS " <> pgFmtIdent alias
|
||||
|
||||
groupF :: QualifiedIdentifier -> [CoercibleSelectField] -> [RelSelectField] -> SQL.Snippet
|
||||
groupF qi select relSelect
|
||||
| (noSelectsAreAggregated && noRelSelectsAreAggregated) || null groupTerms = mempty
|
||||
| otherwise = " GROUP BY " <> intercalateSnippet ", " groupTerms
|
||||
where
|
||||
noSelectsAreAggregated = null $ [s | s@(CoercibleSelectField { csAggFunction = Just _ }) <- select]
|
||||
noRelSelectsAreAggregated = all (\case Spread sels _ -> all (isNothing . ssSelAggFunction) sels; _ -> True) relSelect
|
||||
groupTermsFromSelect = mapMaybe (pgFmtGroup qi) select
|
||||
groupTermsFromRelSelect = mapMaybe groupTermFromRelSelectField relSelect
|
||||
groupTerms = groupTermsFromSelect ++ groupTermsFromRelSelect
|
||||
|
||||
groupTermFromRelSelectField :: RelSelectField -> Maybe SQL.Snippet
|
||||
groupTermFromRelSelectField (JsonEmbed { rsSelName }) =
|
||||
Just $ pgFmtIdent rsSelName
|
||||
groupTermFromRelSelectField (Spread { rsSpreadSel, rsAggAlias }) =
|
||||
if null groupTerms
|
||||
then Nothing
|
||||
else
|
||||
Just $ intercalateSnippet ", " groupTerms
|
||||
where
|
||||
processField :: SpreadSelectField -> Maybe SQL.Snippet
|
||||
processField SpreadSelectField{ssSelAggFunction = Just _} = Nothing
|
||||
processField SpreadSelectField{ssSelName, ssSelAlias} =
|
||||
Just $ pgFmtIdent rsAggAlias <> "." <> pgFmtIdent (fromMaybe ssSelName ssSelAlias)
|
||||
groupTerms = mapMaybe processField rsSpreadSel
|
||||
|
||||
pgFmtGroup :: QualifiedIdentifier -> CoercibleSelectField -> Maybe SQL.Snippet
|
||||
pgFmtGroup _ CoercibleSelectField{csAggFunction=Just _} = Nothing
|
||||
pgFmtGroup _ CoercibleSelectField{csAlias=Just alias, csAggFunction=Nothing} = Just $ pgFmtIdent alias
|
||||
pgFmtGroup qi CoercibleSelectField{csField=fld, csAlias=Nothing, csAggFunction=Nothing} = Just $ pgFmtField qi fld
|
||||
|
||||
countF :: SQL.Snippet -> SQL.Snippet -> Bool -> Maybe Integer -> NonnegRange -> (SQL.Snippet, SQL.Snippet)
|
||||
countF countQuery pageCountSelect shouldCount maxRows range
|
||||
| shouldCount = if isJust maxRows || range /= allRange
|
||||
then ( ", pgrst_source_count AS (" <> countQuery <> ")"
|
||||
, "(SELECT pg_catalog.count(*) FROM pgrst_source_count)" )
|
||||
-- When there are no db-max-rows and limits/offsets, the total count will be the same as the page count,
|
||||
-- so we use the same page count here to avoid doing a separate aggregated count.
|
||||
else ( mempty, pageCountSelect )
|
||||
| otherwise = ( mempty, "null::bigint" )
|
||||
|
||||
pageCountSelectF :: Maybe Routine -> SQL.Snippet
|
||||
pageCountSelectF rout =
|
||||
if maybe False funcReturnsSingle rout
|
||||
then "1"
|
||||
else "pg_catalog.count(_postgrest_t)"
|
||||
|
||||
returningF :: QualifiedIdentifier -> [FieldName] -> SQL.Snippet
|
||||
returningF qi returnings =
|
||||
if null returnings
|
||||
then "RETURNING 1" -- For mutation cases where there's no ?select, we return 1 to know how many rows were modified
|
||||
else "RETURNING " <> intercalateSnippet ", " (pgFmtColumn qi <$> returnings)
|
||||
|
||||
limitOffsetF :: NonnegRange -> SQL.Snippet
|
||||
limitOffsetF range =
|
||||
if range == allRange then mempty else "LIMIT " <> limit <> " OFFSET " <> offset
|
||||
where
|
||||
limit = maybe "ALL" (\l -> unknownEncoder (BS.pack $ show l)) $ rangeLimit range
|
||||
offset = unknownEncoder (BS.pack . show $ rangeOffset range)
|
||||
|
||||
responseHeadersF :: SQL.Snippet
|
||||
responseHeadersF = currentSettingF "response.headers"
|
||||
|
||||
responseStatusF :: SQL.Snippet
|
||||
responseStatusF = currentSettingF "response.status"
|
||||
|
||||
addConfigPgrstInserted :: Bool -> SQL.Snippet
|
||||
addConfigPgrstInserted add =
|
||||
let (symbol, num) = if add then ("+", "0") else ("-", "-1") in
|
||||
"set_config('pgrst.inserted', (coalesce(" <> currentSettingF "pgrst.inserted" <> "::int, 0) " <> symbol <> " 1)::text, true) <> '" <> num <> "'"
|
||||
|
||||
currentSettingF :: SQL.Snippet -> SQL.Snippet
|
||||
currentSettingF setting =
|
||||
-- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15
|
||||
"nullif(current_setting('" <> setting <> "', true), '')"
|
||||
|
||||
orderF :: QualifiedIdentifier -> [CoercibleOrderTerm] -> SQL.Snippet
|
||||
orderF _ [] = mempty
|
||||
orderF qi ordts = "ORDER BY " <> intercalateSnippet ", " (pgFmtOrderTerm qi <$> ordts)
|
||||
|
||||
-- Hasql Snippet utilities
|
||||
unknownEncoder :: ByteString -> SQL.Snippet
|
||||
unknownEncoder = SQL.encoderAndParam (HE.nonNullable HE.unknown)
|
||||
|
||||
unknownLiteral :: Text -> SQL.Snippet
|
||||
unknownLiteral = unknownEncoder . encodeUtf8
|
||||
|
||||
intercalateSnippet :: ByteString -> [SQL.Snippet] -> SQL.Snippet
|
||||
intercalateSnippet _ [] = mempty
|
||||
intercalateSnippet frag snippets = foldr1 (\a b -> a <> SQL.sql frag <> b) snippets
|
||||
|
||||
explainF :: MTVndPlanFormat -> [MTVndPlanOption] -> SQL.Snippet -> SQL.Snippet
|
||||
explainF fmt opts snip =
|
||||
"EXPLAIN (" <>
|
||||
SQL.sql (BS.intercalate ", " (fmtPlanFmt fmt : (fmtPlanOpt <$> opts))) <>
|
||||
") " <> snip
|
||||
where
|
||||
fmtPlanOpt :: MTVndPlanOption -> BS.ByteString
|
||||
fmtPlanOpt PlanAnalyze = "ANALYZE"
|
||||
fmtPlanOpt PlanVerbose = "VERBOSE"
|
||||
fmtPlanOpt PlanSettings = "SETTINGS"
|
||||
fmtPlanOpt PlanBuffers = "BUFFERS"
|
||||
fmtPlanOpt PlanWAL = "WAL"
|
||||
|
||||
fmtPlanFmt PlanText = "FORMAT TEXT"
|
||||
fmtPlanFmt PlanJSON = "FORMAT JSON"
|
||||
|
||||
-- | Do a pg set_config(setting, value, true) call. This is equivalent to a SET LOCAL.
|
||||
setConfigLocal :: (SQL.Snippet, ByteString) -> SQL.Snippet
|
||||
setConfigLocal (k, v) =
|
||||
"set_config(" <> k <> ", " <> unknownEncoder v <> ", true)"
|
||||
|
||||
-- | For when the settings are hardcoded and not parameterized
|
||||
setConfigWithConstantName :: (SQL.Snippet, ByteString) -> SQL.Snippet
|
||||
setConfigWithConstantName (k, v) = setConfigLocal ("'" <> k <> "'", v)
|
||||
|
||||
-- | For when the settings need to be parameterized
|
||||
setConfigWithDynamicName :: (ByteString, ByteString) -> SQL.Snippet
|
||||
setConfigWithDynamicName (k, v) =
|
||||
setConfigLocal (unknownEncoder k, v)
|
||||
|
||||
-- | Starting from PostgreSQL v14, some characters are not allowed for config names (mostly affecting headers with "-").
|
||||
-- | A JSON format string is used to avoid this problem. See https://github.com/PostgREST/postgrest/issues/1857
|
||||
setConfigWithConstantNameJSON :: SQL.Snippet -> [(ByteString, ByteString)] -> [SQL.Snippet]
|
||||
setConfigWithConstantNameJSON prefix keyVals = [setConfigWithConstantName (prefix, gucJsonVal keyVals)]
|
||||
where
|
||||
gucJsonVal :: [(ByteString, ByteString)] -> ByteString
|
||||
gucJsonVal = LBS.toStrict . JSON.encode . HM.fromList . arrayByteStringToText
|
||||
arrayByteStringToText :: [(ByteString, ByteString)] -> [(Text,Text)]
|
||||
arrayByteStringToText keyVal = (T.decodeUtf8 *** T.decodeUtf8) <$> keyVal
|
||||
|
||||
handlerF :: Maybe Routine -> MediaHandler -> SQL.Snippet
|
||||
handlerF rout = \case
|
||||
BuiltinAggArrayJsonStrip -> asJsonF rout True
|
||||
BuiltinAggSingleJson strip -> asJsonSingleF rout strip
|
||||
BuiltinOvAggJson -> asJsonF rout False
|
||||
BuiltinOvAggGeoJson -> asGeoJsonF
|
||||
BuiltinOvAggCsv -> asCsvF
|
||||
CustomFunc funcQi target -> customFuncF rout funcQi target
|
||||
NoAgg -> "''::text"
|
||||
|
||||
schemaDescription :: Text -> SQL.Snippet
|
||||
schemaDescription schema =
|
||||
"SELECT pg_catalog.obj_description(" <> encoded <> "::regnamespace, 'pg_namespace')"
|
||||
where
|
||||
encoded = SQL.encoderAndParam (HE.nonNullable HE.unknown) $ encodeUtf8 schema
|
||||
|
||||
accessibleTables :: Text -> SQL.Snippet
|
||||
accessibleTables schema = SQL.sql (encodeUtf8 [trimming|
|
||||
SELECT
|
||||
n.nspname AS table_schema,
|
||||
c.relname AS table_name
|
||||
FROM pg_class c
|
||||
JOIN pg_namespace n ON n.oid = c.relnamespace
|
||||
WHERE c.relkind IN ('v','r','m','f','p')
|
||||
AND c.relnamespace = |]) <> encodedSchema <> "::regnamespace " <> SQL.sql (encodeUtf8 [trimming|
|
||||
AND (
|
||||
pg_has_role(c.relowner, 'USAGE')
|
||||
or has_table_privilege(c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER')
|
||||
or has_any_column_privilege(c.oid, 'SELECT, INSERT, UPDATE, REFERENCES')
|
||||
)
|
||||
AND not c.relispartition
|
||||
ORDER BY table_schema, table_name|])
|
||||
where
|
||||
encodedSchema = SQL.encoderAndParam (HE.nonNullable HE.text) schema
|
||||
|
||||
accessibleFuncs :: Text -> SQL.Snippet
|
||||
accessibleFuncs schema = baseFuncSqlQuery <> "AND p.pronamespace = " <> encodedSchema <> "::regnamespace"
|
||||
where
|
||||
encodedSchema = SQL.encoderAndParam (HE.nonNullable HE.text) schema
|
||||
|
||||
baseFuncSqlQuery :: SQL.Snippet
|
||||
baseFuncSqlQuery = SQL.sql $ encodeUtf8 [trimming|
|
||||
WITH
|
||||
base_types AS (
|
||||
WITH RECURSIVE
|
||||
recurse AS (
|
||||
SELECT
|
||||
oid,
|
||||
typbasetype,
|
||||
typnamespace AS base_namespace,
|
||||
COALESCE(NULLIF(typbasetype, 0), oid) AS base_type
|
||||
FROM pg_type
|
||||
UNION
|
||||
SELECT
|
||||
t.oid,
|
||||
b.typbasetype,
|
||||
b.typnamespace AS base_namespace,
|
||||
COALESCE(NULLIF(b.typbasetype, 0), b.oid) AS base_type
|
||||
FROM recurse t
|
||||
JOIN pg_type b ON t.typbasetype = b.oid
|
||||
)
|
||||
SELECT
|
||||
oid,
|
||||
base_namespace,
|
||||
base_type
|
||||
FROM recurse
|
||||
WHERE typbasetype = 0
|
||||
),
|
||||
arguments AS (
|
||||
SELECT
|
||||
oid,
|
||||
array_agg((
|
||||
COALESCE(name, ''), -- name
|
||||
type::regtype::text, -- type
|
||||
CASE type
|
||||
WHEN 'bit'::regtype THEN 'bit varying'
|
||||
WHEN 'bit[]'::regtype THEN 'bit varying[]'
|
||||
WHEN 'character'::regtype THEN 'character varying'
|
||||
WHEN 'character[]'::regtype THEN 'character varying[]'
|
||||
ELSE type::regtype::text
|
||||
END, -- convert types that ignore the length and accept any value till maximum size
|
||||
idx <= (pronargs - pronargdefaults), -- is_required
|
||||
COALESCE(mode = 'v', FALSE) -- is_variadic
|
||||
) ORDER BY idx) AS args,
|
||||
CASE COUNT(*) - COUNT(name) -- number of unnamed arguments
|
||||
WHEN 0 THEN true
|
||||
WHEN 1 THEN (array_agg(type))[1] IN ('bytea'::regtype, 'json'::regtype, 'jsonb'::regtype, 'text'::regtype, 'xml'::regtype)
|
||||
ELSE false
|
||||
END AS callable
|
||||
FROM pg_proc,
|
||||
unnest(proargnames, proargtypes, proargmodes)
|
||||
WITH ORDINALITY AS _ (name, type, mode, idx)
|
||||
WHERE type IS NOT NULL -- only input arguments
|
||||
GROUP BY oid
|
||||
)
|
||||
SELECT
|
||||
pn.nspname AS proc_schema,
|
||||
p.proname AS proc_name,
|
||||
d.description AS proc_description,
|
||||
COALESCE(a.args, '{}') AS args,
|
||||
tn.nspname AS schema,
|
||||
COALESCE(comp.relname, t.typname) AS name,
|
||||
p.proretset AS rettype_is_setof,
|
||||
(t.typtype = 'c'
|
||||
-- if any TABLE, INOUT or OUT arguments present, treat as composite
|
||||
or COALESCE(proargmodes::text[] && '{t,b,o}', false)
|
||||
) AS rettype_is_composite,
|
||||
bt.oid <> bt.base_type as rettype_is_composite_alias,
|
||||
p.provolatile,
|
||||
p.provariadic > 0 as hasvariadic,
|
||||
'ignored' AS transaction_isolation_level,
|
||||
'{}'::text[] as kvs
|
||||
FROM pg_proc p
|
||||
LEFT JOIN arguments a ON a.oid = p.oid
|
||||
JOIN pg_namespace pn ON pn.oid = p.pronamespace
|
||||
JOIN base_types bt ON bt.oid = p.prorettype
|
||||
JOIN pg_type t ON t.oid = bt.base_type
|
||||
JOIN pg_namespace tn ON tn.oid = t.typnamespace
|
||||
LEFT JOIN pg_class comp ON comp.oid = t.typrelid
|
||||
LEFT JOIN pg_description as d ON d.objoid = p.oid AND d.classoid = 'pg_proc'::regclass
|
||||
WHERE t.oid <> 'trigger'::regtype AND COALESCE(a.callable, true)
|
||||
AND has_function_privilege(p.oid, 'execute')
|
||||
AND prokind = 'f' |]
|
||||
@@ -0,0 +1,121 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-|
|
||||
Module : PostgREST.Query.Statements
|
||||
Description : PostgREST main queries
|
||||
-}
|
||||
module PostgREST.Query.Statements
|
||||
( mainWrite
|
||||
, mainRead
|
||||
, mainCall
|
||||
, postExplain
|
||||
) where
|
||||
|
||||
import qualified Hasql.DynamicStatements.Snippet as SQL
|
||||
|
||||
import PostgREST.ApiRequest.Preferences
|
||||
import PostgREST.MediaType (MTVndPlanFormat (..),
|
||||
MediaType (..))
|
||||
import PostgREST.Plan.CallPlan
|
||||
import PostgREST.Plan.MutatePlan as MTPlan
|
||||
import PostgREST.Plan.ReadPlan
|
||||
import PostgREST.Query.QueryBuilder
|
||||
import PostgREST.Query.SqlFragment
|
||||
import PostgREST.RangeQuery (NonnegRange)
|
||||
import PostgREST.SchemaCache.Routine (MediaHandler (..), Routine)
|
||||
|
||||
import Protolude
|
||||
|
||||
mainWrite :: ReadPlanTree -> MutatePlan -> MediaType -> MediaHandler ->
|
||||
Maybe PreferRepresentation -> Maybe PreferResolution -> SQL.Snippet
|
||||
mainWrite rPlan mtplan mt handler rep resolution = mtSnippet mt snippet
|
||||
where
|
||||
checkUpsert snip = if isInsert && (isPut || resolution == Just MergeDuplicates) then snip else "''"
|
||||
pgrstInsertedF = checkUpsert "nullif(current_setting('pgrst.inserted', true),'')::int"
|
||||
snippet =
|
||||
"WITH " <> sourceCTE <> " AS (" <> mutateQuery <> ") " <>
|
||||
"SELECT " <>
|
||||
"'' AS total_result_set, " <>
|
||||
"pg_catalog.count(_postgrest_t) AS page_total, " <>
|
||||
locF <> " AS header, " <>
|
||||
handlerF Nothing handler <> " AS body, " <>
|
||||
responseHeadersF <> " AS response_headers, " <>
|
||||
responseStatusF <> " AS response_status, " <>
|
||||
pgrstInsertedF <> " AS response_inserted " <>
|
||||
"FROM (" <> selectF <> ") _postgrest_t"
|
||||
|
||||
locF =
|
||||
if isInsert && rep == Just HeadersOnly
|
||||
then
|
||||
"CASE WHEN pg_catalog.count(_postgrest_t) = 1 " <>
|
||||
"THEN coalesce(" <> locationF pkCols <> ", " <> noLocationF <> ") " <>
|
||||
"ELSE " <> noLocationF <> " " <>
|
||||
"END"
|
||||
else noLocationF
|
||||
|
||||
selectF
|
||||
-- prevent using any of the column names in ?select= when no response is returned from the CTE
|
||||
| handler == NoAgg = "SELECT * FROM " <> sourceCTE
|
||||
| otherwise = selectQuery
|
||||
|
||||
selectQuery = readPlanToQuery rPlan
|
||||
mutateQuery = mutatePlanToQuery mtplan
|
||||
(isPut, isInsert, pkCols) = case mtplan of
|
||||
MTPlan.Insert{MTPlan.where_,insPkCols} -> ((not . null) where_, True, insPkCols)
|
||||
_ -> (False,False, mempty);
|
||||
|
||||
mainRead :: ReadPlanTree -> SQL.Snippet -> Maybe PreferCount -> Maybe Integer ->
|
||||
NonnegRange -> MediaType -> MediaHandler -> SQL.Snippet
|
||||
mainRead rPlan countQuery pCount maxRows range mt handler = mtSnippet mt snippet
|
||||
where
|
||||
snippet =
|
||||
"WITH " <> sourceCTE <> " AS ( " <> selectQuery <> " ) " <>
|
||||
countCTEF <> " " <>
|
||||
"SELECT " <>
|
||||
countResultF <> " AS total_result_set, " <>
|
||||
pageCountSelect <> " AS page_total, " <>
|
||||
handlerF Nothing handler <> " AS body, " <>
|
||||
responseHeadersF <> " AS response_headers, " <>
|
||||
responseStatusF <> " AS response_status, " <>
|
||||
"''" <> " AS response_inserted " <>
|
||||
"FROM ( SELECT * FROM " <> sourceCTE <> " ) _postgrest_t"
|
||||
|
||||
(countCTEF, countResultF) = countF countQ pageCountSelect (shouldCount pCount) maxRows range
|
||||
selectQuery = readPlanToQuery rPlan
|
||||
pageCountSelect = pageCountSelectF Nothing
|
||||
countQ =
|
||||
if pCount == Just EstimatedCount then
|
||||
-- LIMIT maxRows + 1 so we can determine below that maxRows was surpassed
|
||||
limitedQuery countQuery ((+ 1) <$> maxRows)
|
||||
else
|
||||
countQuery
|
||||
|
||||
mainCall :: Routine -> CallPlan -> ReadPlanTree -> Maybe PreferCount -> Maybe Integer ->
|
||||
NonnegRange-> MediaType -> MediaHandler -> SQL.Snippet
|
||||
mainCall rout cPlan rPlan pCount maxRows range mt handler = mtSnippet mt snippet
|
||||
where
|
||||
snippet =
|
||||
"WITH " <> sourceCTE <> " AS (" <> callProcQuery <> ") " <>
|
||||
countCTEF <>
|
||||
"SELECT " <>
|
||||
countResultF <> " AS total_result_set, " <>
|
||||
pageCountSelect <> " AS page_total, " <>
|
||||
handlerF (Just rout) handler <> " AS body, " <>
|
||||
responseHeadersF <> " AS response_headers, " <>
|
||||
responseStatusF <> " AS response_status, " <>
|
||||
"''" <> " AS response_inserted " <>
|
||||
"FROM (" <> selectQuery <> ") _postgrest_t"
|
||||
|
||||
(countCTEF, countResultF) = countF countQuery pageCountSelect (shouldCount pCount) maxRows range
|
||||
selectQuery = readPlanToQuery rPlan
|
||||
callProcQuery = callPlanToQuery cPlan
|
||||
countQuery = readPlanToCountQuery rPlan
|
||||
pageCountSelect = pageCountSelectF (Just rout)
|
||||
|
||||
-- This occurs after the main query runs, that's why it's prefixed with "post"
|
||||
postExplain :: SQL.Snippet -> SQL.Snippet
|
||||
postExplain = explainF PlanJSON mempty
|
||||
|
||||
mtSnippet :: MediaType -> SQL.Snippet -> SQL.Snippet
|
||||
mtSnippet mediaType snippet = case mediaType of
|
||||
MTVndPlan _ fmt opts -> explainF fmt opts snippet
|
||||
_ -> snippet
|
||||
@@ -0,0 +1,121 @@
|
||||
{-|
|
||||
Module : PostgREST.RangeQuery
|
||||
Description : Logic regarding the `Range`/`Content-Range` headers and `limit`/`offset` querystring arguments.
|
||||
-}
|
||||
module PostgREST.RangeQuery (
|
||||
rangeParse
|
||||
, rangeRequested
|
||||
, rangeLimit
|
||||
, rangeOffset
|
||||
, restrictRange
|
||||
, rangeGeq
|
||||
, allRange
|
||||
, limitZeroRange
|
||||
, hasLimitZero
|
||||
, convertToLimitZeroRange
|
||||
, NonnegRange
|
||||
, rangeStatusHeader
|
||||
, contentRangeH
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
import Data.List (lookup)
|
||||
import Text.Regex.TDFA ((=~))
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Ranged.Boundaries
|
||||
import Data.Ranged.Ranges
|
||||
import Network.HTTP.Types.Header
|
||||
import Network.HTTP.Types.Status
|
||||
|
||||
import Protolude
|
||||
|
||||
type NonnegRange = Range Integer
|
||||
|
||||
rangeParse :: BS.ByteString -> NonnegRange
|
||||
rangeParse range = do
|
||||
let rangeRegex = "^([0-9]+)-([0-9]*)$" :: BS.ByteString
|
||||
|
||||
case range =~ rangeRegex :: [[BS.ByteString]] of
|
||||
[[_, l, u]] ->
|
||||
let lower = maybe emptyRange rangeGeq (readInteger l)
|
||||
upper = maybe allRange rangeLeq (readInteger u) in
|
||||
rangeIntersection lower upper
|
||||
_ -> allRange
|
||||
where
|
||||
readInteger = readMaybe . BS.unpack
|
||||
|
||||
rangeRequested :: RequestHeaders -> NonnegRange
|
||||
rangeRequested headers = maybe allRange rangeParse $ lookup hRange headers
|
||||
|
||||
restrictRange :: Maybe Integer -> NonnegRange -> NonnegRange
|
||||
restrictRange Nothing r = r
|
||||
restrictRange (Just limit) r =
|
||||
rangeIntersection r $
|
||||
Range BoundaryBelowAll (BoundaryAbove $ rangeOffset r + limit - 1)
|
||||
|
||||
rangeLimit :: NonnegRange -> Maybe Integer
|
||||
rangeLimit range =
|
||||
case [rangeLower range, rangeUpper range] of
|
||||
[BoundaryBelow lower, BoundaryAbove upper] -> Just (1 + upper - lower)
|
||||
_ -> Nothing
|
||||
|
||||
rangeOffset :: NonnegRange -> Integer
|
||||
rangeOffset range =
|
||||
case rangeLower range of
|
||||
BoundaryBelow lower -> lower
|
||||
_ -> panic "range without lower bound" -- should never happen
|
||||
|
||||
rangeGeq :: Integer -> NonnegRange
|
||||
rangeGeq n =
|
||||
Range (BoundaryBelow n) BoundaryAboveAll
|
||||
|
||||
allRange :: NonnegRange
|
||||
allRange = rangeGeq 0
|
||||
|
||||
rangeLeq :: Integer -> NonnegRange
|
||||
rangeLeq n =
|
||||
Range BoundaryBelowAll (BoundaryAbove n)
|
||||
|
||||
-- Special case to allow limit 0 queries
|
||||
-- https://github.com/PostgREST/postgrest/issues/1121
|
||||
-- 0 <= x <= -1
|
||||
limitZeroRange :: Range Integer
|
||||
limitZeroRange = Range (BoundaryBelow 0) (BoundaryAbove (-1))
|
||||
|
||||
hasLimitZero :: Range Integer -> Bool
|
||||
hasLimitZero r = rangeUpper r == rangeUpper limitZeroRange
|
||||
|
||||
-- Used to convert a range into a special limitZeroRange if it has a
|
||||
-- limit=0 in order to bypass validations for empty ranges.
|
||||
convertToLimitZeroRange :: Range Integer -> Range Integer -> Range Integer
|
||||
convertToLimitZeroRange range fallbackRange =
|
||||
if hasLimitZero range then limitZeroRange else fallbackRange
|
||||
|
||||
rangeStatusHeader :: NonnegRange -> Int64 -> Maybe Int64 -> (Status, Header)
|
||||
rangeStatusHeader topLevelRange queryTotal tableTotal =
|
||||
let lower = rangeOffset topLevelRange
|
||||
upper = lower + toInteger queryTotal - 1
|
||||
contentRange = contentRangeH lower upper (toInteger <$> tableTotal)
|
||||
status = rangeStatus lower upper (toInteger <$> tableTotal)
|
||||
in (status, contentRange)
|
||||
where
|
||||
rangeStatus :: Integer -> Integer -> Maybe Integer -> Status
|
||||
rangeStatus _ _ Nothing = status200
|
||||
rangeStatus lower upper (Just total)
|
||||
| lower > total = status416 -- 416 Range Not Satisfiable
|
||||
| (1 + upper - lower) < total = status206 -- 206 Partial Content
|
||||
| otherwise = status200 -- 200 OK
|
||||
|
||||
contentRangeH :: (Integral a, Show a) => a -> a -> Maybe a -> Header
|
||||
contentRangeH lower upper total =
|
||||
("Content-Range", toUtf8 headerValue)
|
||||
where
|
||||
headerValue = rangeString <> "/" <> totalString :: Text
|
||||
rangeString
|
||||
| totalNotZero && fromInRange = show lower <> "-" <> show upper
|
||||
| otherwise = "*"
|
||||
totalString = maybe "*" show total
|
||||
totalNotZero = Just 0 /= total
|
||||
fromInRange = lower <= upper
|
||||
@@ -0,0 +1,302 @@
|
||||
{- |
|
||||
Module : PostgREST.Response
|
||||
Description : Generate HTTP Response
|
||||
-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module PostgREST.Response
|
||||
( actionResponse
|
||||
, PgrstResponse(..)
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Text.Read (decimal)
|
||||
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 PostgREST.Error as Error
|
||||
import qualified PostgREST.MediaType as MediaType
|
||||
import qualified PostgREST.RangeQuery as RangeQuery
|
||||
import qualified PostgREST.Response.OpenAPI as OpenAPI
|
||||
|
||||
import PostgREST.ApiRequest (ApiRequest (..))
|
||||
import PostgREST.ApiRequest.Preferences (PreferRepresentation (..),
|
||||
PreferResolution (..),
|
||||
Preferences (..),
|
||||
prefAppliedHeader,
|
||||
shouldCount)
|
||||
import PostgREST.ApiRequest.QueryParams (QueryParams (..))
|
||||
import PostgREST.ApiRequest.Types (InvokeMethod (..),
|
||||
Mutation (..))
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.MainTx (DbResult (..),
|
||||
ResultSet (..))
|
||||
import PostgREST.MediaType (MediaType (..))
|
||||
import PostgREST.Plan (CrudPlan (..),
|
||||
InfoPlan (..),
|
||||
InspectPlan (..))
|
||||
import PostgREST.Plan.MutatePlan (MutatePlan (..))
|
||||
import PostgREST.Response.GucHeader (GucHeader, unwrapGucHeader)
|
||||
import PostgREST.SchemaCache (SchemaCache (..))
|
||||
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..),
|
||||
Schema)
|
||||
import PostgREST.SchemaCache.Routine (FuncVolatility (..),
|
||||
Routine (..))
|
||||
import PostgREST.SchemaCache.Table (Table (..))
|
||||
|
||||
import qualified PostgREST.SchemaCache.Routine as Routine
|
||||
|
||||
import Protolude hiding (Handler, toS)
|
||||
import Protolude.Conv (toS)
|
||||
|
||||
data PgrstResponse = PgrstResponse {
|
||||
pgrstStatus :: HTTP.Status
|
||||
, pgrstHeaders :: [HTTP.Header]
|
||||
, pgrstBody :: LBS.ByteString
|
||||
}
|
||||
|
||||
actionResponse :: DbResult -> ApiRequest -> (Text, Text) -> AppConfig -> SchemaCache -> Either Error.Error PgrstResponse
|
||||
|
||||
actionResponse (DbCrudResult plan@WrappedReadPlan{pMedia, wrHdrsOnly=headersOnly, crudQi=identifier} RSStandard{..}) ctxApiRequest@ApiRequest{..} _ AppConfig{..} _ = do
|
||||
let
|
||||
(status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal rsTableTotal
|
||||
cLHeader = if headersOnly then mempty else [ contentLengthHeader bod ]
|
||||
prefHeader = maybeToList . prefAppliedHeader $ responsePreferences plan ctxApiRequest
|
||||
|
||||
headers =
|
||||
[ contentRange
|
||||
, ( "Content-Location"
|
||||
, "/"
|
||||
<> toUtf8 (qiName identifier)
|
||||
<> if BS.null (qsCanonical iQueryParams) then mempty else "?" <> qsCanonical iQueryParams
|
||||
)
|
||||
]
|
||||
++ cLHeader
|
||||
++ contentTypeHeaders pMedia ctxApiRequest
|
||||
++ prefHeader
|
||||
bod | status == HTTP.status416 = Error.errorPayload configClientErrorVerbosity $ Error.ApiRequestErr $ Error.InvalidRange $
|
||||
Error.OutOfBounds (show $ RangeQuery.rangeOffset iTopLevelRange) (maybe "0" show rsTableTotal)
|
||||
| headersOnly = mempty
|
||||
| otherwise = LBS.fromStrict rsBody
|
||||
|
||||
(ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers
|
||||
|
||||
Right $ PgrstResponse ovStatus ovHeaders bod
|
||||
|
||||
actionResponse (DbCrudResult plan@MutateReadPlan{mrMutation=MutationCreate, pMedia, crudQi=QualifiedIdentifier{..}} RSStandard{..}) ctxApiRequest@ApiRequest{..} _ _ _ = do
|
||||
let
|
||||
prefHeader = prefAppliedHeader $ responsePreferences plan ctxApiRequest
|
||||
|
||||
headers =
|
||||
catMaybes
|
||||
[ if null rsLocation then
|
||||
Nothing
|
||||
else
|
||||
Just
|
||||
( HTTP.hLocation
|
||||
, "/"
|
||||
<> toUtf8 qiName
|
||||
<> HTTP.renderSimpleQuery True rsLocation
|
||||
)
|
||||
, Just . RangeQuery.contentRangeH 1 0 $
|
||||
if shouldCount (preferCount iPreferences) then Just rsQueryTotal else Nothing
|
||||
, prefHeader ]
|
||||
|
||||
isInsertIfGTZero i =
|
||||
if i <= 0 && preferResolution iPreferences == Just MergeDuplicates then
|
||||
HTTP.status200
|
||||
else
|
||||
HTTP.status201
|
||||
status = maybe HTTP.status200 isInsertIfGTZero rsInserted
|
||||
(headers', bod) = case preferRepresentation iPreferences of
|
||||
Just Full -> (headers ++ contentTypeHeaders pMedia ctxApiRequest, LBS.fromStrict rsBody)
|
||||
Just None -> (headers, mempty)
|
||||
Just HeadersOnly -> (headers, mempty)
|
||||
Nothing -> (headers, mempty)
|
||||
|
||||
(ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status $ contentLengthHeader bod:headers'
|
||||
|
||||
Right $ PgrstResponse ovStatus ovHeaders bod
|
||||
|
||||
actionResponse (DbCrudResult plan@MutateReadPlan{mrMutation=MutationUpdate, pMedia} RSStandard{..}) ctxApiRequest@ApiRequest{..} _ _ _ = do
|
||||
let
|
||||
contentRangeHeader =
|
||||
Just . RangeQuery.contentRangeH 0 (rsQueryTotal - 1) $
|
||||
if shouldCount (preferCount iPreferences) then Just rsQueryTotal else Nothing
|
||||
|
||||
prefHeader = prefAppliedHeader $ responsePreferences plan ctxApiRequest
|
||||
|
||||
headers = catMaybes [contentRangeHeader, prefHeader]
|
||||
lbsBody = LBS.fromStrict rsBody
|
||||
|
||||
let (status, headers', body) =
|
||||
case preferRepresentation iPreferences of
|
||||
Just Full -> (HTTP.status200, headers ++ [contentLengthHeader lbsBody] ++ contentTypeHeaders pMedia ctxApiRequest, lbsBody)
|
||||
Just None -> (HTTP.status204, headers, mempty)
|
||||
_ -> (HTTP.status204, headers, mempty)
|
||||
|
||||
(ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers'
|
||||
|
||||
Right $ PgrstResponse ovStatus ovHeaders body
|
||||
|
||||
actionResponse (DbCrudResult plan@MutateReadPlan{mrMutation=MutationSingleUpsert, pMedia} RSStandard{..}) ctxApiRequest@ApiRequest{..} _ _ _ = do
|
||||
let
|
||||
prefHeader = maybeToList . prefAppliedHeader $ responsePreferences plan ctxApiRequest
|
||||
lbsBody = LBS.fromStrict rsBody
|
||||
cLHeader = [contentLengthHeader lbsBody]
|
||||
cTHeader = contentTypeHeaders pMedia ctxApiRequest
|
||||
|
||||
let isInsertIfGTZero i = if i > 0 then HTTP.status201 else HTTP.status200
|
||||
upsertStatus = isInsertIfGTZero $ fromJust rsInserted
|
||||
(status, headers, body) =
|
||||
case preferRepresentation iPreferences of
|
||||
Just Full -> (upsertStatus, cLHeader ++ cTHeader ++ prefHeader, lbsBody)
|
||||
Just None -> (HTTP.status204, prefHeader, mempty)
|
||||
_ -> (HTTP.status204, prefHeader, mempty)
|
||||
(ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers
|
||||
|
||||
Right $ PgrstResponse ovStatus ovHeaders body
|
||||
|
||||
actionResponse (DbCrudResult plan@MutateReadPlan{mrMutation=MutationDelete, pMedia} RSStandard{..}) ctxApiRequest@ApiRequest{..} _ _ _ = do
|
||||
let
|
||||
contentRangeHeader = RangeQuery.contentRangeH 1 0 $ if shouldCount (preferCount iPreferences) then Just rsQueryTotal else Nothing
|
||||
prefHeader = maybeToList . prefAppliedHeader $ responsePreferences plan ctxApiRequest
|
||||
headers = contentRangeHeader : prefHeader
|
||||
lbsBody = LBS.fromStrict rsBody
|
||||
(status, headers', body) =
|
||||
case preferRepresentation iPreferences of
|
||||
Just Full -> (HTTP.status200, headers ++ [contentLengthHeader lbsBody] ++ contentTypeHeaders pMedia ctxApiRequest, lbsBody)
|
||||
Just None -> (HTTP.status204, headers, mempty)
|
||||
_ -> (HTTP.status204, headers, mempty)
|
||||
|
||||
(ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers'
|
||||
|
||||
Right $ PgrstResponse ovStatus ovHeaders body
|
||||
|
||||
actionResponse (DbCrudResult plan@CallReadPlan{pMedia, crInvMthd=invMethod, crProc=proc} RSStandard {..}) ctxApiRequest@ApiRequest{..} _ AppConfig{..} _ = do
|
||||
let
|
||||
(status, contentRange) =
|
||||
RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal rsTableTotal
|
||||
rsOrErrBody = if status == HTTP.status416
|
||||
then Error.errorPayload configClientErrorVerbosity $ Error.ApiRequestErr $ Error.InvalidRange
|
||||
$ Error.OutOfBounds (show $ RangeQuery.rangeOffset iTopLevelRange) (maybe "0" show rsTableTotal)
|
||||
else LBS.fromStrict rsBody
|
||||
isHeadMethod = invMethod == InvRead True
|
||||
prefHeader = maybeToList . prefAppliedHeader $ responsePreferences plan ctxApiRequest
|
||||
cLHeader = if isHeadMethod then mempty else [contentLengthHeader rsOrErrBody]
|
||||
headers = contentRange : prefHeader
|
||||
(status', headers', body) =
|
||||
if Routine.funcReturnsVoid proc then
|
||||
(HTTP.status204, headers, mempty)
|
||||
else
|
||||
(status,
|
||||
headers ++ cLHeader ++ contentTypeHeaders pMedia ctxApiRequest,
|
||||
if isHeadMethod then mempty else rsOrErrBody)
|
||||
|
||||
(ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status' headers'
|
||||
|
||||
Right $ PgrstResponse ovStatus ovHeaders body
|
||||
|
||||
actionResponse (DbPlanResult media plan) ctxApiRequest _ _ _ =
|
||||
let body = LBS.fromStrict plan in
|
||||
Right $ PgrstResponse HTTP.status200 (contentLengthHeader body : contentTypeHeaders media ctxApiRequest) body
|
||||
|
||||
actionResponse (MaybeDbResult InspectPlan{ipHdrsOnly=headersOnly} body) ApiRequest{..} versions conf sCache =
|
||||
let
|
||||
rsBody = maybe mempty (\(x, y, z) -> if headersOnly then mempty else OpenAPI.encode versions conf sCache x y z) body
|
||||
cLHeader = if headersOnly then mempty else [contentLengthHeader rsBody]
|
||||
in
|
||||
Right $ PgrstResponse HTTP.status200 (MediaType.toContentType MTOpenAPI : cLHeader ++ maybeToList (profileHeader iSchema iNegotiatedByProfile)) rsBody
|
||||
|
||||
actionResponse (NoDbResult (RelInfoPlan qi@QualifiedIdentifier{..})) _ _ _ sc@SchemaCache{dbTables} =
|
||||
case HM.lookup qi dbTables of
|
||||
Just tbl -> respondInfo $ allowH tbl
|
||||
Nothing -> Left $ Error.SchemaCacheErr $ Error.TableNotFound qiSchema qiName sc
|
||||
where
|
||||
allowH table =
|
||||
let hasPK = not . null $ tablePKCols table in
|
||||
BS.intercalate "," $
|
||||
["OPTIONS,GET,HEAD"] ++
|
||||
["POST" | tableInsertable table] ++
|
||||
["PUT" | tableInsertable table && tableUpdatable table && hasPK] ++
|
||||
["PATCH" | tableUpdatable table] ++
|
||||
["DELETE" | tableDeletable table]
|
||||
|
||||
actionResponse (NoDbResult (RoutineInfoPlan proc)) _ _ _ _
|
||||
| pdVolatility proc == Volatile = respondInfo "OPTIONS,POST"
|
||||
| otherwise = respondInfo "OPTIONS,GET,HEAD,POST"
|
||||
|
||||
actionResponse (NoDbResult SchemaInfoPlan) _ _ _ _ = respondInfo "OPTIONS,GET,HEAD"
|
||||
|
||||
respondInfo :: ByteString -> Either Error.Error PgrstResponse
|
||||
respondInfo allowHeader =
|
||||
let allOrigins = ("Access-Control-Allow-Origin", "*") in
|
||||
Right $ PgrstResponse HTTP.status200 [contentLengthHeader mempty, allOrigins, (HTTP.hAllow, allowHeader)] mempty
|
||||
|
||||
-- Status and headers can be overridden as per https://postgrest.org/en/stable/references/transactions.html#response-headers
|
||||
overrideStatusHeaders :: Maybe Text -> Maybe BS.ByteString -> HTTP.Status -> [HTTP.Header]-> Either Error.Error (HTTP.Status, [HTTP.Header])
|
||||
overrideStatusHeaders rsGucStatus rsGucHeaders pgrstStatus pgrstHeaders = do
|
||||
gucStatus <- decodeGucStatus rsGucStatus
|
||||
gucHeaders <- decodeGucHeaders rsGucHeaders
|
||||
Right (fromMaybe pgrstStatus gucStatus, addHeadersIfNotIncluded pgrstHeaders $ map unwrapGucHeader gucHeaders)
|
||||
|
||||
decodeGucHeaders :: Maybe BS.ByteString -> Either Error.Error [GucHeader]
|
||||
decodeGucHeaders =
|
||||
maybe (Right []) $ first (const . Error.ApiRequestErr $ Error.GucHeadersError) . JSON.eitherDecode . LBS.fromStrict
|
||||
|
||||
decodeGucStatus :: Maybe Text -> Either Error.Error (Maybe HTTP.Status)
|
||||
decodeGucStatus =
|
||||
maybe (Right Nothing) $ first (const . Error.ApiRequestErr $ Error.GucStatusError) . fmap (Just . toEnum . fst) . decimal
|
||||
|
||||
contentLengthHeader :: LBS.ByteString -> HTTP.Header
|
||||
contentLengthHeader body = ("Content-Length", show (LBS.length body))
|
||||
|
||||
contentTypeHeaders :: MediaType -> ApiRequest -> [HTTP.Header]
|
||||
contentTypeHeaders mediaType ApiRequest{..} =
|
||||
MediaType.toContentType mediaType : maybeToList (profileHeader iSchema iNegotiatedByProfile)
|
||||
|
||||
profileHeader :: Schema -> Bool -> Maybe HTTP.Header
|
||||
profileHeader schema negotiatedByProfile =
|
||||
if negotiatedByProfile
|
||||
then Just $ (,) "Content-Profile" (toS schema)
|
||||
else
|
||||
Nothing
|
||||
|
||||
-- | Add headers not already included to allow the user to override them instead of duplicating them
|
||||
addHeadersIfNotIncluded :: [HTTP.Header] -> [HTTP.Header] -> [HTTP.Header]
|
||||
addHeadersIfNotIncluded newHeaders initialHeaders =
|
||||
filter (\(nk, _) -> isNothing $ find (\(ik, _) -> ik == nk) initialHeaders) newHeaders ++
|
||||
initialHeaders
|
||||
|
||||
-- | Get Preferences for Preference-Applied header per plan
|
||||
responsePreferences :: CrudPlan -> ApiRequest -> Preferences
|
||||
responsePreferences plan ApiRequest{iPreferences=Preferences{..}, iQueryParams=QueryParams{..}} =
|
||||
let
|
||||
-- Only returned on Inserts
|
||||
preferResolution' = case plan of
|
||||
MutateReadPlan{mrMutation=MutationCreate, mrMutatePlan} ->
|
||||
let pkCols = case mrMutatePlan of { Insert{insPkCols} -> insPkCols ; _ -> mempty; }
|
||||
in (if null pkCols && isNothing qsOnConflict then Nothing else preferResolution)
|
||||
_ -> Nothing
|
||||
|
||||
preferRepresentation' = case plan of
|
||||
MutateReadPlan{} -> preferRepresentation
|
||||
_ -> Nothing
|
||||
|
||||
preferMissing' = case plan of
|
||||
MutateReadPlan{mrMutation=MutationCreate} -> preferMissing
|
||||
MutateReadPlan{mrMutation=MutationUpdate} -> preferMissing
|
||||
_ -> Nothing
|
||||
|
||||
preferMaxAffected' = case plan of
|
||||
MutateReadPlan{mrMutation=MutationUpdate} -> preferMaxAffected
|
||||
MutateReadPlan{mrMutation=MutationDelete} -> preferMaxAffected
|
||||
CallReadPlan{} -> preferMaxAffected
|
||||
_ -> Nothing
|
||||
|
||||
in Preferences preferResolution' preferRepresentation' preferCount preferTransaction preferMissing' preferHandling preferTimezone preferMaxAffected' []
|
||||
@@ -0,0 +1,30 @@
|
||||
module PostgREST.Response.GucHeader
|
||||
( GucHeader
|
||||
, unwrapGucHeader
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.Key as K
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Network.HTTP.Types.Header (Header)
|
||||
|
||||
import Protolude
|
||||
|
||||
|
||||
{-|
|
||||
Custom guc header, it's obtained by parsing the json in a:
|
||||
`SET LOCAL "response.headers" = '[{"Set-Cookie": ".."}]'
|
||||
-}
|
||||
newtype GucHeader = GucHeader (CI.CI ByteString, ByteString)
|
||||
|
||||
instance JSON.FromJSON GucHeader where
|
||||
parseJSON (JSON.Object o) =
|
||||
case KM.toList o of
|
||||
[(k, JSON.String s)] -> pure $ GucHeader (CI.mk $ toUtf8 $ K.toText k, toUtf8 s)
|
||||
_ -> mzero
|
||||
parseJSON _ = mzero
|
||||
|
||||
unwrapGucHeader :: GucHeader -> Header
|
||||
unwrapGucHeader (GucHeader (k, v)) = (k, v)
|
||||
@@ -0,0 +1,454 @@
|
||||
{-|
|
||||
Module : PostgREST.OpenAPI
|
||||
Description : Generates the OpenAPI output
|
||||
-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module PostgREST.Response.OpenAPI (encode) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.HashSet.InsOrd as Set
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Control.Arrow ((&&&))
|
||||
import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.String (IsString (..))
|
||||
import Network.URI (URI (..), URIAuth (..))
|
||||
|
||||
import Control.Lens (at, (.~), (?~))
|
||||
|
||||
import Data.Swagger
|
||||
|
||||
import PostgREST.Config (AppConfig (..), Proxy (..),
|
||||
isMalformedProxyUri, toURI)
|
||||
import PostgREST.MediaType
|
||||
import PostgREST.Network (escapeHostName)
|
||||
import PostgREST.SchemaCache (SchemaCache (..))
|
||||
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..))
|
||||
import PostgREST.SchemaCache.Relationship (Cardinality (..),
|
||||
Relationship (..),
|
||||
RelationshipsMap)
|
||||
import PostgREST.SchemaCache.Routine (FuncVolatility (..),
|
||||
Routine (..),
|
||||
RoutineParam (..))
|
||||
import PostgREST.SchemaCache.Table (Column (..), Table (..),
|
||||
TablesMap,
|
||||
tableColumnsList)
|
||||
|
||||
import Protolude hiding (Proxy, get)
|
||||
|
||||
encode :: (Text, Text) -> AppConfig -> SchemaCache -> TablesMap -> HM.HashMap k [Routine] -> Maybe Text -> LBS.ByteString
|
||||
encode versions conf sCache tables procs schemaDescription =
|
||||
JSON.encode $
|
||||
postgrestSpec
|
||||
versions
|
||||
(dbRelationships sCache)
|
||||
(concat $ HM.elems procs)
|
||||
(snd <$> HM.toList tables)
|
||||
(proxyUri conf)
|
||||
schemaDescription
|
||||
(configOpenApiSecurityActive conf)
|
||||
|
||||
makeMimeList :: [MediaType] -> MimeList
|
||||
makeMimeList cs = MimeList $ fmap (fromString . BS.unpack . toMime) cs
|
||||
|
||||
toSwaggerType :: Text -> Maybe (SwaggerType t)
|
||||
toSwaggerType "character varying" = Just SwaggerString
|
||||
toSwaggerType "character" = Just SwaggerString
|
||||
toSwaggerType "text" = Just SwaggerString
|
||||
toSwaggerType "boolean" = Just SwaggerBoolean
|
||||
toSwaggerType "smallint" = Just SwaggerInteger
|
||||
toSwaggerType "integer" = Just SwaggerInteger
|
||||
toSwaggerType "bigint" = Just SwaggerInteger
|
||||
toSwaggerType "numeric" = Just SwaggerNumber
|
||||
toSwaggerType "real" = Just SwaggerNumber
|
||||
toSwaggerType "double precision" = Just SwaggerNumber
|
||||
toSwaggerType "json" = Nothing
|
||||
toSwaggerType "jsonb" = Nothing
|
||||
toSwaggerType colType = case T.takeEnd 2 colType of
|
||||
"[]" -> Just SwaggerArray
|
||||
_ -> Just SwaggerString
|
||||
|
||||
toSwaggerFormat :: Text -> Maybe Text
|
||||
toSwaggerFormat "smallint" = Just "int32"
|
||||
toSwaggerFormat "integer" = Just "int32"
|
||||
toSwaggerFormat "bigint" = Just "int64"
|
||||
toSwaggerFormat colType = Just colType
|
||||
|
||||
typeFromArray :: Text -> Text
|
||||
typeFromArray = T.dropEnd 2
|
||||
|
||||
toSwaggerTypeFromArray :: Text -> Maybe (SwaggerType t)
|
||||
toSwaggerTypeFromArray arrType = toSwaggerType $ typeFromArray arrType
|
||||
|
||||
makePropertyItems :: Text -> Maybe (Referenced Schema)
|
||||
makePropertyItems arrType = case toSwaggerType arrType of
|
||||
Just SwaggerArray -> Just $ Inline (mempty & type_ .~ toSwaggerTypeFromArray arrType)
|
||||
_ -> Nothing
|
||||
|
||||
parseDefault :: Text -> Text -> Text
|
||||
parseDefault colType colDefault =
|
||||
case toSwaggerType colType of
|
||||
Just SwaggerString -> wrapInQuotations $ case T.stripSuffix ("::" <> colType) colDefault of
|
||||
Just def -> T.dropAround (=='\'') def
|
||||
Nothing -> colDefault
|
||||
_ -> colDefault
|
||||
where
|
||||
wrapInQuotations text = "\"" <> text <> "\""
|
||||
|
||||
makeTableDef :: RelationshipsMap -> Table -> (Text, Schema)
|
||||
makeTableDef rels t =
|
||||
let tn = tableName t in
|
||||
(tn, (mempty :: Schema)
|
||||
& description .~ tableDescription t
|
||||
& type_ ?~ SwaggerObject
|
||||
& properties .~ fromList (makeProperty t rels <$> tableColumnsList t)
|
||||
& required .~ fmap colName (filter (not . colNullable) $ tableColumnsList t))
|
||||
|
||||
makeProperty :: Table -> RelationshipsMap -> Column -> (Text, Referenced Schema)
|
||||
makeProperty tbl rels col = (colName col, Inline s)
|
||||
where
|
||||
e = if null $ colEnum col then Nothing else JSON.decode $ JSON.encode $ colEnum col
|
||||
fk :: Maybe Text
|
||||
fk =
|
||||
let
|
||||
searchedRels = fromMaybe mempty $ HM.lookup (QualifiedIdentifier (tableSchema tbl) (tableName tbl), tableSchema tbl) rels
|
||||
-- Sorts the relationship list to get tables first
|
||||
relsSortedByIsView = sortOn relFTableIsView [ r | r@Relationship{} <- searchedRels]
|
||||
-- Finds the relationship that has a single column foreign key
|
||||
rel = find (\case
|
||||
Relationship{relCardinality=(M2O _ relColumns)} -> [colName col] == (fst <$> relColumns)
|
||||
Relationship{relCardinality=(O2O _ relColumns False)} -> [colName col] == (fst <$> relColumns)
|
||||
_ -> False
|
||||
) relsSortedByIsView
|
||||
fCol = (headMay . (\r -> snd <$> relColumns (relCardinality r)) =<< rel)
|
||||
fTbl = qiName . relForeignTable <$> rel
|
||||
fTblCol = (,) <$> fTbl <*> fCol
|
||||
in
|
||||
(\(a, b) -> T.intercalate "" ["This is a Foreign Key to `", a, ".", b, "`.<fk table='", a, "' column='", b, "'/>"]) <$> fTblCol
|
||||
pk :: Bool
|
||||
pk = colName col `elem` tablePKCols tbl
|
||||
n = catMaybes
|
||||
[ Just "Note:"
|
||||
, if pk then Just "This is a Primary Key.<pk/>" else Nothing
|
||||
, fk
|
||||
]
|
||||
d =
|
||||
if length n > 1 then
|
||||
Just $ T.append (maybe "" (`T.append` "\n\n") $ colDescription col) (T.intercalate "\n" n)
|
||||
else
|
||||
colDescription col
|
||||
s =
|
||||
(mempty :: Schema)
|
||||
& default_ .~ (JSON.decode . toUtf8Lazy . parseDefault (colType col) =<< colDefault col)
|
||||
& description .~ d
|
||||
& enum_ .~ e
|
||||
& format .~ toSwaggerFormat (colType col)
|
||||
& maxLength .~ (fromIntegral <$> colMaxLen col)
|
||||
& type_ .~ toSwaggerType (colType col)
|
||||
& items .~ (SwaggerItemsObject <$> makePropertyItems (colType col))
|
||||
|
||||
makeProcSchema :: Routine -> Schema
|
||||
makeProcSchema pd =
|
||||
(mempty :: Schema)
|
||||
& description .~ pdDescription pd
|
||||
& type_ ?~ SwaggerObject
|
||||
& properties .~ fromList (fmap makeProcProperty (pdParams pd))
|
||||
& required .~ fmap ppName (filter ppReq (pdParams pd))
|
||||
|
||||
makeProcProperty :: RoutineParam -> (Text, Referenced Schema)
|
||||
makeProcProperty (RoutineParam n t _ _ _) = (n, Inline s)
|
||||
where
|
||||
s = (mempty :: Schema)
|
||||
& type_ .~ toSwaggerType t
|
||||
& items .~ (SwaggerItemsObject <$> makePropertyItems t)
|
||||
& format .~ toSwaggerFormat t
|
||||
|
||||
makePreferParam :: [Text] -> Param
|
||||
makePreferParam ts =
|
||||
(mempty :: Param)
|
||||
& name .~ "Prefer"
|
||||
& description ?~ "Preference"
|
||||
& required ?~ False
|
||||
& schema .~ ParamOther ((mempty :: ParamOtherSchema)
|
||||
& in_ .~ ParamHeader
|
||||
& type_ ?~ SwaggerString
|
||||
& enum_ .~ if null enu then Nothing else JSON.decode (JSON.encode enu))
|
||||
where
|
||||
enu = foldl (<>) [] (val <$> ts)
|
||||
val :: Text -> [Text]
|
||||
val = \case
|
||||
"count" -> ["count=none"]
|
||||
"return" -> ["return=representation", "return=minimal", "return=none"]
|
||||
"resolution" -> ["resolution=ignore-duplicates", "resolution=merge-duplicates"]
|
||||
_ -> []
|
||||
|
||||
makeProcGetParam :: RoutineParam -> Referenced Param
|
||||
makeProcGetParam (RoutineParam n t _ r v) =
|
||||
Inline $ (mempty :: Param)
|
||||
& name .~ n
|
||||
& required ?~ r
|
||||
& schema .~ ParamOther fullSchema
|
||||
where
|
||||
fullSchema = if v then schemaMulti else schemaNotMulti
|
||||
baseSchema = (mempty :: ParamOtherSchema)
|
||||
& in_ .~ ParamQuery
|
||||
schemaNotMulti = baseSchema
|
||||
& format .~ toSwaggerFormat t
|
||||
& type_ ?~ toParamType (toSwaggerType t)
|
||||
schemaMulti = baseSchema
|
||||
& type_ ?~ fromMaybe SwaggerString (toSwaggerType t)
|
||||
& items ?~ SwaggerItemsPrimitive (Just CollectionMulti)
|
||||
((mempty :: ParamSchema x)
|
||||
& type_ .~ toSwaggerTypeFromArray t
|
||||
& format .~ toSwaggerFormat (typeFromArray t))
|
||||
toParamType paramType = case paramType of
|
||||
-- Array uses {} in query params
|
||||
Just SwaggerArray -> SwaggerString
|
||||
-- Type must be specified in query params
|
||||
Nothing -> SwaggerString
|
||||
_ -> fromJust paramType
|
||||
|
||||
makeProcGetParams :: [RoutineParam] -> [Referenced Param]
|
||||
makeProcGetParams = fmap makeProcGetParam
|
||||
|
||||
makeProcPostParams :: Routine -> [Referenced Param]
|
||||
makeProcPostParams pd =
|
||||
[ Inline $ (mempty :: Param)
|
||||
& name .~ "args"
|
||||
& required ?~ True
|
||||
& schema .~ ParamBody (Inline $ makeProcSchema pd)
|
||||
, Ref $ Reference "preferParams"
|
||||
]
|
||||
|
||||
makeParamDefs :: [Table] -> [(Text, Param)]
|
||||
makeParamDefs ti =
|
||||
-- TODO: create Prefer for each method (GET, PATCH, etc.)
|
||||
[ ("preferParams", makePreferParam ["params"])
|
||||
, ("preferReturn", makePreferParam ["return"])
|
||||
, ("preferCount", makePreferParam ["count"])
|
||||
, ("preferPost", makePreferParam ["return", "resolution"])
|
||||
, ("select", (mempty :: Param)
|
||||
& name .~ "select"
|
||||
& description ?~ "Filtering Columns"
|
||||
& required ?~ False
|
||||
& schema .~ ParamOther ((mempty :: ParamOtherSchema)
|
||||
& in_ .~ ParamQuery
|
||||
& type_ ?~ SwaggerString))
|
||||
, ("on_conflict", (mempty :: Param)
|
||||
& name .~ "on_conflict"
|
||||
& description ?~ "On Conflict"
|
||||
& required ?~ False
|
||||
& schema .~ ParamOther ((mempty :: ParamOtherSchema)
|
||||
& in_ .~ ParamQuery
|
||||
& type_ ?~ SwaggerString))
|
||||
, ("order", (mempty :: Param)
|
||||
& name .~ "order"
|
||||
& description ?~ "Ordering"
|
||||
& required ?~ False
|
||||
& schema .~ ParamOther ((mempty :: ParamOtherSchema)
|
||||
& in_ .~ ParamQuery
|
||||
& type_ ?~ SwaggerString))
|
||||
, ("range", (mempty :: Param)
|
||||
& name .~ "Range"
|
||||
& description ?~ "Limiting and Pagination"
|
||||
& required ?~ False
|
||||
& schema .~ ParamOther ((mempty :: ParamOtherSchema)
|
||||
& in_ .~ ParamHeader
|
||||
& type_ ?~ SwaggerString))
|
||||
, ("rangeUnit", (mempty :: Param)
|
||||
& name .~ "Range-Unit"
|
||||
& description ?~ "Limiting and Pagination"
|
||||
& required ?~ False
|
||||
& schema .~ ParamOther ((mempty :: ParamOtherSchema)
|
||||
& in_ .~ ParamHeader
|
||||
& type_ ?~ SwaggerString
|
||||
& default_ .~ JSON.decode "\"items\""))
|
||||
, ("offset", (mempty :: Param)
|
||||
& name .~ "offset"
|
||||
& description ?~ "Limiting and Pagination"
|
||||
& required ?~ False
|
||||
& schema .~ ParamOther ((mempty :: ParamOtherSchema)
|
||||
& in_ .~ ParamQuery
|
||||
& type_ ?~ SwaggerString))
|
||||
, ("limit", (mempty :: Param)
|
||||
& name .~ "limit"
|
||||
& description ?~ "Limiting and Pagination"
|
||||
& required ?~ False
|
||||
& schema .~ ParamOther ((mempty :: ParamOtherSchema)
|
||||
& in_ .~ ParamQuery
|
||||
& type_ ?~ SwaggerString))
|
||||
]
|
||||
<> concat [ makeObjectBody (tableName t) : makeRowFilters (tableName t) (tableColumnsList t)
|
||||
| t <- ti
|
||||
]
|
||||
|
||||
makeObjectBody :: Text -> (Text, Param)
|
||||
makeObjectBody tn =
|
||||
("body." <> tn, (mempty :: Param)
|
||||
& name .~ tn
|
||||
& description ?~ tn
|
||||
& required ?~ False
|
||||
& schema .~ ParamBody (Ref (Reference tn)))
|
||||
|
||||
makeRowFilter :: Text -> Column -> (Text, Param)
|
||||
makeRowFilter tn c =
|
||||
(T.intercalate "." ["rowFilter", tn, colName c], (mempty :: Param)
|
||||
& name .~ colName c
|
||||
& description .~ colDescription c
|
||||
& required ?~ False
|
||||
& schema .~ ParamOther ((mempty :: ParamOtherSchema)
|
||||
& in_ .~ ParamQuery
|
||||
& type_ ?~ SwaggerString))
|
||||
|
||||
makeRowFilters :: Text -> [Column] -> [(Text, Param)]
|
||||
makeRowFilters tn = fmap (makeRowFilter tn)
|
||||
|
||||
makePathItem :: Table -> (FilePath, PathItem)
|
||||
makePathItem t = ("/" ++ T.unpack tn, p $ tableInsertable t || tableUpdatable t || tableDeletable t)
|
||||
where
|
||||
-- Use first line of table description as summary; rest as description (if present)
|
||||
-- We strip leading newlines from description so that users can include a blank line between summary and description
|
||||
(tSum, tDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $
|
||||
T.breakOn "\n" <$> tableDescription t
|
||||
tOp = (mempty :: Operation)
|
||||
& tags .~ Set.fromList [tn]
|
||||
& summary .~ tSum
|
||||
& description .~ mfilter (/="") tDesc
|
||||
getOp = tOp
|
||||
& parameters .~ fmap ref (rs <> ["select", "order", "range", "rangeUnit", "offset", "limit", "preferCount"])
|
||||
& at 206 ?~ "Partial Content"
|
||||
& at 200 ?~ Inline ((mempty :: Response)
|
||||
& description .~ "OK"
|
||||
& schema ?~ Inline (mempty
|
||||
& type_ ?~ SwaggerArray
|
||||
& items ?~ SwaggerItemsObject (Ref $ Reference $ tableName t)
|
||||
)
|
||||
)
|
||||
postOp = tOp
|
||||
& parameters .~ fmap ref ["body." <> tn, "select", "preferPost"]
|
||||
& at 201 ?~ "Created"
|
||||
patchOp = tOp
|
||||
& parameters .~ fmap ref (rs <> ["body." <> tn, "preferReturn"])
|
||||
& at 204 ?~ "No Content"
|
||||
deletOp = tOp
|
||||
& parameters .~ fmap ref (rs <> ["preferReturn"])
|
||||
& at 204 ?~ "No Content"
|
||||
pr = (mempty :: PathItem) & get ?~ getOp
|
||||
pw = pr & post ?~ postOp & patch ?~ patchOp & delete ?~ deletOp
|
||||
p False = pr
|
||||
p True = pw
|
||||
tn = tableName t
|
||||
rs = [ T.intercalate "." ["rowFilter", tn, colName c ] | c <- tableColumnsList t ]
|
||||
ref = Ref . Reference
|
||||
|
||||
makeProcPathItem :: Routine -> (FilePath, PathItem)
|
||||
makeProcPathItem pd = ("/rpc/" ++ toS (pdName pd), pe)
|
||||
where
|
||||
-- Use first line of proc description as summary; rest as description (if present)
|
||||
-- We strip leading newlines from description so that users can include a blank line between summary and description
|
||||
(pSum, pDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $
|
||||
T.breakOn "\n" <$> pdDescription pd
|
||||
procOp = (mempty :: Operation)
|
||||
& summary .~ pSum
|
||||
& description .~ mfilter (/="") pDesc
|
||||
& tags .~ Set.fromList ["(rpc) " <> pdName pd]
|
||||
& produces ?~ makeMimeList [MTApplicationJSON, MTVndSingularJSON True, MTVndSingularJSON False]
|
||||
& at 200 ?~ "OK"
|
||||
getOp = procOp
|
||||
& parameters .~ makeProcGetParams (pdParams pd)
|
||||
postOp = procOp
|
||||
& parameters .~ makeProcPostParams pd
|
||||
pe = case pdVolatility pd of
|
||||
Volatile -> (mempty :: PathItem) & post ?~ postOp
|
||||
_ -> (mempty :: PathItem) & get ?~ getOp & post ?~ postOp
|
||||
|
||||
makeRootPathItem :: (FilePath, PathItem)
|
||||
makeRootPathItem = ("/", p)
|
||||
where
|
||||
getOp = (mempty :: Operation)
|
||||
& tags .~ Set.fromList ["Introspection"]
|
||||
& summary ?~ "OpenAPI description (this document)"
|
||||
& produces ?~ makeMimeList [MTOpenAPI, MTApplicationJSON]
|
||||
& at 200 ?~ "OK"
|
||||
pr = (mempty :: PathItem) & get ?~ getOp
|
||||
p = pr
|
||||
|
||||
makePathItems :: [Routine] -> [Table] -> InsOrdHashMap FilePath PathItem
|
||||
makePathItems pds ti = fromList $ makeRootPathItem :
|
||||
fmap makePathItem ti ++ fmap makeProcPathItem pds
|
||||
|
||||
makeSecurityDefinitions :: Text -> Bool -> SecurityDefinitions
|
||||
makeSecurityDefinitions secName allow
|
||||
| allow = SecurityDefinitions (fromList [(secName, SecurityScheme secSchType secSchDescription)])
|
||||
| otherwise = mempty
|
||||
where
|
||||
secSchType = SecuritySchemeApiKey (ApiKeyParams "Authorization" ApiKeyHeader)
|
||||
secSchDescription = Just "Add the token prepending \"Bearer \" (without quotes) to it"
|
||||
|
||||
postgrestSpec :: (Text, Text) -> RelationshipsMap -> [Routine] -> [Table] -> (Text, Text, Integer, Text) -> Maybe Text -> Bool -> Swagger
|
||||
postgrestSpec (prettyVersion, docsVersion) rels pds ti (s, h, p, b) sd allowSecurityDef = (mempty :: Swagger)
|
||||
& basePath ?~ T.unpack b
|
||||
& schemes ?~ [s']
|
||||
& info .~ ((mempty :: Info)
|
||||
& version .~ prettyVersion
|
||||
& title .~ fromMaybe "PostgREST API" dTitle
|
||||
& description ?~ fromMaybe "This is a dynamic API generated by PostgREST" dDesc)
|
||||
& externalDocs ?~ ((mempty :: ExternalDocs)
|
||||
& description ?~ "PostgREST Documentation"
|
||||
& url .~ URL ("https://postgrest.org/en/" <> docsVersion <> "/references/api.html"))
|
||||
& host .~ h'
|
||||
& definitions .~ fromList (makeTableDef rels <$> ti)
|
||||
& parameters .~ fromList (makeParamDefs ti)
|
||||
& paths .~ makePathItems pds ti
|
||||
& produces .~ makeMimeList [MTApplicationJSON, MTVndSingularJSON True, MTVndSingularJSON False, MTTextCSV]
|
||||
& consumes .~ makeMimeList [MTApplicationJSON, MTVndSingularJSON True, MTVndSingularJSON False, MTTextCSV]
|
||||
& securityDefinitions .~ makeSecurityDefinitions securityDefName allowSecurityDef
|
||||
& security .~ [SecurityRequirement (fromList [(securityDefName, [])]) | allowSecurityDef]
|
||||
where
|
||||
s' = if s == "http" then Http else Https
|
||||
h' = Just $ Host (T.unpack $ escapeHostName h) (Just (fromInteger p))
|
||||
securityDefName = "JWT"
|
||||
(dTitle, dDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $
|
||||
T.breakOn "\n" <$> sd
|
||||
|
||||
pickProxy :: Maybe Text -> Maybe Proxy
|
||||
pickProxy proxy
|
||||
| isNothing proxy = Nothing
|
||||
-- should never happen
|
||||
-- since the request would have been rejected by the middleware if proxy uri
|
||||
-- is malformed
|
||||
| isMalformedProxyUri $ fromMaybe mempty proxy = Nothing
|
||||
| otherwise = Just Proxy {
|
||||
proxyScheme = scheme
|
||||
, proxyHost = host'
|
||||
, proxyPort = port''
|
||||
, proxyPath = path'
|
||||
}
|
||||
where
|
||||
uri = toURI $ fromJust proxy
|
||||
scheme = T.init $ T.toLower $ T.pack $ uriScheme uri
|
||||
path URI {uriPath = ""} = "/"
|
||||
path URI {uriPath = p} = p
|
||||
path' = T.pack $ path uri
|
||||
authority = fromJust $ uriAuthority uri
|
||||
host' = T.pack $ uriRegName authority
|
||||
port' = uriPort authority
|
||||
readPort = fromMaybe 80 . readMaybe
|
||||
port'' :: Integer
|
||||
port'' = case (port', scheme) of
|
||||
("", "http") -> 80
|
||||
("", "https") -> 443
|
||||
_ -> readPort $ T.unpack $ T.tail $ T.pack port'
|
||||
|
||||
proxyUri :: AppConfig -> (Text, Text, Integer, Text)
|
||||
proxyUri AppConfig{..} =
|
||||
case pickProxy $ toS <$> configOpenApiServerProxyUri of
|
||||
Just Proxy{..} ->
|
||||
(proxyScheme, proxyHost, proxyPort, proxyPath)
|
||||
Nothing ->
|
||||
("http", configServerHost, toInteger configServerPort, "/")
|
||||
@@ -0,0 +1,41 @@
|
||||
module PostgREST.Response.Performance
|
||||
( ServerTiming (..)
|
||||
, serverTimingHeader
|
||||
)
|
||||
where
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Numeric (showFFloat)
|
||||
import Protolude
|
||||
|
||||
-- $setup
|
||||
-- >>> import Protolude
|
||||
|
||||
-- | ServerTiming represents the timing data for a request, in seconds.
|
||||
data ServerTiming =
|
||||
ServerTiming
|
||||
{ jwt :: Maybe Double
|
||||
, parse :: Maybe Double
|
||||
, plan :: Maybe Double
|
||||
, transaction :: Maybe Double
|
||||
, response :: Maybe Double
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- | Render the Server-Timing header from a ServerTimingData
|
||||
-- The duration precision is milliseconds, per the docs
|
||||
--
|
||||
-- >>> serverTimingHeader ServerTiming { plan=Just 0.1, transaction=Just 0.2, response=Just 0.3, jwt=Just 0.4, parse=Just 0.5}
|
||||
-- ("Server-Timing","jwt;dur=0.4, parse;dur=0.5, plan;dur=0.1, transaction;dur=0.2, response;dur=0.3")
|
||||
serverTimingHeader :: ServerTiming -> HTTP.Header
|
||||
serverTimingHeader timing =
|
||||
("Server-Timing", renderTiming)
|
||||
where
|
||||
renderMetric metric = maybe "" (\dur -> BS.concat [metric, BS.pack $ ";dur=" <> showFFloat (Just 1) dur ""])
|
||||
renderTiming = BS.intercalate ", " $ (\(k, v) -> renderMetric k (v timing)) <$>
|
||||
[ ("jwt", jwt)
|
||||
, ("parse", parse)
|
||||
, ("plan", plan)
|
||||
, ("transaction", transaction)
|
||||
, ("response", response)
|
||||
]
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,65 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module PostgREST.SchemaCache.Identifiers
|
||||
( FieldName
|
||||
, QualifiedIdentifier(..)
|
||||
, RelIdentifier(..)
|
||||
, Schema
|
||||
, TableName
|
||||
, escapeIdent
|
||||
, isAnyElement
|
||||
, quoteQi
|
||||
, toQi
|
||||
, trimNullChars
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Protolude
|
||||
|
||||
data RelIdentifier = RelId QualifiedIdentifier | RelAnyElement
|
||||
deriving (Eq, Ord, Generic, JSON.ToJSON, JSON.ToJSONKey, Show)
|
||||
instance Hashable RelIdentifier
|
||||
|
||||
-- | Represents a pg identifier with a prepended schema name "schema.table".
|
||||
-- When qiSchema is "", the schema is defined by the pg search_path.
|
||||
-- TODO: Refactor this, we also use QI for procedure names
|
||||
data QualifiedIdentifier = QualifiedIdentifier
|
||||
{ qiSchema :: Schema
|
||||
, qiName :: TableName
|
||||
}
|
||||
deriving (Eq, Show, Ord, Generic, JSON.ToJSON, JSON.ToJSONKey)
|
||||
|
||||
instance Hashable QualifiedIdentifier
|
||||
|
||||
isAnyElement :: QualifiedIdentifier -> Bool
|
||||
isAnyElement y = QualifiedIdentifier "pg_catalog" "anyelement" == y
|
||||
|
||||
-- |
|
||||
-- Quote the qualified identifier when preparing the SQL. This avoids parse
|
||||
-- errors by postgres, for example on pg reserved words like "true" or "select".
|
||||
--
|
||||
-- >>> quoteQi (QualifiedIdentifier "" "true")
|
||||
-- "\"true\""
|
||||
quoteQi :: QualifiedIdentifier -> Text
|
||||
quoteQi (QualifiedIdentifier s i) =
|
||||
(if T.null s then mempty else escapeIdent s <> ".") <> escapeIdent i
|
||||
|
||||
-- TODO: Handle a case where the QI comes like this: "my.fav.schema"."my.identifier"
|
||||
-- Right now it only handles the schema.identifier case
|
||||
toQi :: Text -> QualifiedIdentifier
|
||||
toQi txt = case T.drop 1 <$> T.breakOn "." txt of
|
||||
(i, "") -> QualifiedIdentifier mempty i
|
||||
(s, i) -> QualifiedIdentifier s i
|
||||
|
||||
escapeIdent :: Text -> Text
|
||||
escapeIdent x = "\"" <> T.replace "\"" "\"\"" (trimNullChars x) <> "\""
|
||||
|
||||
trimNullChars :: Text -> Text
|
||||
trimNullChars = T.takeWhile (/= '\x0')
|
||||
|
||||
type Schema = Text
|
||||
type TableName = Text
|
||||
type FieldName = Text
|
||||
@@ -0,0 +1,73 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module PostgREST.SchemaCache.Relationship
|
||||
( Cardinality(..)
|
||||
, Relationship(..)
|
||||
, Junction(..)
|
||||
, RelationshipsMap
|
||||
, relIsToOne
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
|
||||
import PostgREST.SchemaCache.Identifiers (FieldName,
|
||||
QualifiedIdentifier, Schema)
|
||||
|
||||
import Protolude
|
||||
|
||||
|
||||
-- | Relationship between two tables.
|
||||
data Relationship = Relationship
|
||||
{ relTable :: QualifiedIdentifier
|
||||
, relForeignTable :: QualifiedIdentifier
|
||||
, relIsSelf :: Bool -- ^ Whether is a self relationship
|
||||
, relCardinality :: Cardinality
|
||||
, relTableIsView :: Bool
|
||||
, relFTableIsView :: Bool
|
||||
}
|
||||
| ComputedRelationship
|
||||
{ relFunction :: QualifiedIdentifier
|
||||
, relTable :: QualifiedIdentifier
|
||||
, relForeignTable :: QualifiedIdentifier
|
||||
, relTableAlias :: QualifiedIdentifier
|
||||
, relToOne :: Bool
|
||||
, relIsSelf :: Bool
|
||||
}
|
||||
deriving (Eq, Show, Ord, Generic, JSON.ToJSON)
|
||||
|
||||
-- | The relationship cardinality
|
||||
-- | https://en.wikipedia.org/wiki/Cardinality_(data_modeling)
|
||||
data Cardinality
|
||||
= O2M {relCons :: FKConstraint, relColumns :: [(FieldName, FieldName)]}
|
||||
-- ^ one-to-many
|
||||
| M2O {relCons :: FKConstraint, relColumns :: [(FieldName, FieldName)]}
|
||||
-- ^ many-to-one
|
||||
| O2O {relCons :: FKConstraint, relColumns :: [(FieldName, FieldName)], isParent :: Bool}
|
||||
-- ^ one-to-one, this is a refinement over M2O, operating on it is pretty much the same as M2O when isParent == False
|
||||
| M2M Junction
|
||||
-- ^ many-to-many
|
||||
deriving (Eq, Show, Ord, Generic, JSON.ToJSON)
|
||||
|
||||
type FKConstraint = Text
|
||||
|
||||
-- | Junction table on an M2M relationship
|
||||
data Junction = Junction
|
||||
{ junTable :: QualifiedIdentifier
|
||||
, junConstraint1 :: FKConstraint
|
||||
, junConstraint2 :: FKConstraint
|
||||
, junColsSource :: [(FieldName, FieldName)]
|
||||
, junColsTarget :: [(FieldName, FieldName)]
|
||||
}
|
||||
deriving (Eq, Show, Ord, Generic, JSON.ToJSON)
|
||||
|
||||
-- | Key based on the source table and the foreign table schema
|
||||
type RelationshipsMap = HM.HashMap (QualifiedIdentifier, Schema) [Relationship]
|
||||
|
||||
relIsToOne :: Relationship -> Bool
|
||||
relIsToOne rel = case rel of
|
||||
Relationship{relCardinality=M2O {}} -> True
|
||||
Relationship{relCardinality=O2O {}} -> True
|
||||
ComputedRelationship{relToOne=True} -> True
|
||||
_ -> False
|
||||
@@ -0,0 +1,29 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module PostgREST.SchemaCache.Representations
|
||||
( DataRepresentation(..)
|
||||
, RepresentationsMap
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
|
||||
|
||||
import Protolude
|
||||
|
||||
-- | Data representations allow user customisation of how to present and receive data through APIs, per field.
|
||||
-- This structure is used for the library of available transforms. It answers questions like:
|
||||
-- - What function, if any, should be used to present a certain field that's been selected for API output?
|
||||
-- - How do we parse incoming data for a certain field type when inserting or updating?
|
||||
-- - And similarly, how do we parse textual data in a query string to be used as a filter?
|
||||
--
|
||||
-- Support for outputting special formats like CSV and binary data would fit into the same system.
|
||||
data DataRepresentation = DataRepresentation
|
||||
{ drSourceType :: Text
|
||||
, drTargetType :: Text
|
||||
, drFunction :: Text
|
||||
} deriving (Eq, Show, Generic, JSON.ToJSON, JSON.FromJSON)
|
||||
|
||||
-- The representation map maps from (source type, target type) to a DR.
|
||||
type RepresentationsMap = HM.HashMap (Text, Text) DataRepresentation
|
||||
@@ -0,0 +1,147 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module PostgREST.SchemaCache.Routine
|
||||
( PgType(..)
|
||||
, Routine(..)
|
||||
, RoutineParam(..)
|
||||
, FuncVolatility(..)
|
||||
, FuncSettings
|
||||
, RoutineMap
|
||||
, RetType(..)
|
||||
, funcReturnsScalar
|
||||
, funcReturnsSetOfScalar
|
||||
, funcReturnsSingleComposite
|
||||
, funcReturnsVoid
|
||||
, funcTableName
|
||||
, funcReturnsSingle
|
||||
, MediaHandlerMap
|
||||
, ResolvedHandler
|
||||
, MediaHandler(..)
|
||||
) where
|
||||
|
||||
import Data.Aeson ((.=))
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Hasql.Transaction.Sessions as SQL
|
||||
import qualified PostgREST.MediaType as MediaType
|
||||
|
||||
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..),
|
||||
RelIdentifier (..), Schema,
|
||||
TableName)
|
||||
|
||||
|
||||
import Protolude
|
||||
|
||||
data PgType
|
||||
= Scalar QualifiedIdentifier
|
||||
| Composite QualifiedIdentifier Bool -- True if the composite is a domain alias(used to work around a bug in pg 11 and 12, see QueryBuilder.hs)
|
||||
deriving (Eq, Show, Ord, Generic, JSON.ToJSON)
|
||||
|
||||
data RetType
|
||||
= Single PgType
|
||||
| SetOf PgType
|
||||
deriving (Eq, Show, Ord, Generic, JSON.ToJSON)
|
||||
|
||||
data FuncVolatility
|
||||
= Volatile
|
||||
| Stable
|
||||
| Immutable
|
||||
deriving (Eq, Show, Ord, Generic, JSON.ToJSON)
|
||||
|
||||
type FuncSettings = [(Text,Text)]
|
||||
|
||||
data Routine = Function
|
||||
{ pdSchema :: Schema
|
||||
, pdName :: Text
|
||||
, pdDescription :: Maybe Text
|
||||
, pdParams :: [RoutineParam]
|
||||
, pdReturnType :: RetType
|
||||
, pdVolatility :: FuncVolatility
|
||||
, pdHasVariadic :: Bool
|
||||
, pdIsoLvl :: Maybe SQL.IsolationLevel
|
||||
, pdFuncSettings :: FuncSettings
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
-- need to define JSON manually bc SQL.IsolationLevel doesn't have a JSON instance(and we can't define one for that type without getting a compiler error)
|
||||
instance JSON.ToJSON Routine where
|
||||
toJSON (Function sch nam desc params ret vol hasVar _ sets) = JSON.object
|
||||
[
|
||||
"pdSchema" .= sch
|
||||
, "pdName" .= nam
|
||||
, "pdDescription" .= desc
|
||||
, "pdParams" .= JSON.toJSON params
|
||||
, "pdReturnType" .= JSON.toJSON ret
|
||||
, "pdVolatility" .= JSON.toJSON vol
|
||||
, "pdHasVariadic" .= JSON.toJSON hasVar
|
||||
, "pdFuncSettings" .= JSON.toJSON sets
|
||||
]
|
||||
|
||||
data RoutineParam = RoutineParam
|
||||
{ ppName :: Text
|
||||
, ppType :: Text
|
||||
, ppTypeMaxLength :: Text
|
||||
, ppReq :: Bool
|
||||
, ppVar :: Bool
|
||||
}
|
||||
deriving (Eq, Show, Ord, Generic, JSON.ToJSON)
|
||||
|
||||
-- Order by least number of params in the case of overloaded functions
|
||||
instance Ord Routine where
|
||||
Function schema1 name1 des1 prms1 rt1 vol1 hasVar1 iso1 sets1 `compare` Function schema2 name2 des2 prms2 rt2 vol2 hasVar2 iso2 sets2
|
||||
| schema1 == schema2 && name1 == name2 && length prms1 < length prms2 = LT
|
||||
| schema1 == schema2 && name1 == name2 && length prms1 > length prms2 = GT
|
||||
| otherwise = (schema1, name1, des1, prms1, rt1, vol1, hasVar1, iso1, sets1) `compare` (schema2, name2, des2, prms2, rt2, vol2, hasVar2, iso2, sets2)
|
||||
|
||||
-- | A map of all procs, all of which can be overloaded(one entry will have more than one Routine).
|
||||
-- | It uses a HashMap for a faster lookup.
|
||||
type RoutineMap = HM.HashMap QualifiedIdentifier [Routine]
|
||||
|
||||
-- | A media handler can be an aggregate over a composite type or a function over a scalar
|
||||
data MediaHandler
|
||||
-- non overridable builtins
|
||||
= BuiltinAggSingleJson Bool
|
||||
| BuiltinAggArrayJsonStrip
|
||||
-- these builtins are overridable
|
||||
| BuiltinOvAggJson
|
||||
| BuiltinOvAggGeoJson
|
||||
| BuiltinOvAggCsv
|
||||
-- custom
|
||||
| CustomFunc QualifiedIdentifier RelIdentifier
|
||||
| NoAgg
|
||||
deriving (Eq, Show, Generic, JSON.ToJSON)
|
||||
|
||||
funcReturnsSingle :: Routine -> Bool
|
||||
funcReturnsSingle proc = case proc of
|
||||
Function{pdReturnType = Single _} -> True
|
||||
_ -> False
|
||||
|
||||
funcReturnsScalar :: Routine -> Bool
|
||||
funcReturnsScalar proc = case proc of
|
||||
Function{pdReturnType = Single (Scalar{})} -> True
|
||||
_ -> False
|
||||
|
||||
funcReturnsSetOfScalar :: Routine -> Bool
|
||||
funcReturnsSetOfScalar proc = case proc of
|
||||
Function{pdReturnType = SetOf (Scalar{})} -> True
|
||||
_ -> False
|
||||
|
||||
funcReturnsSingleComposite :: Routine -> Bool
|
||||
funcReturnsSingleComposite proc = case proc of
|
||||
Function{pdReturnType = Single (Composite _ _)} -> True
|
||||
_ -> False
|
||||
|
||||
funcReturnsVoid :: Routine -> Bool
|
||||
funcReturnsVoid proc = case proc of
|
||||
Function{pdReturnType = Single (Scalar (QualifiedIdentifier "pg_catalog" "void"))} -> True
|
||||
_ -> False
|
||||
|
||||
funcTableName :: Routine -> Maybe TableName
|
||||
funcTableName proc = case pdReturnType proc of
|
||||
SetOf (Composite qi _) -> Just $ qiName qi
|
||||
Single (Composite qi _) -> Just $ qiName qi
|
||||
_ -> Nothing
|
||||
|
||||
-- the resolved handler also carries the media type because MTAny (*/*) is resolved to a different media type
|
||||
type ResolvedHandler = (MediaHandler, MediaType.MediaType)
|
||||
type MediaHandlerMap = HM.HashMap (RelIdentifier, MediaType.MediaType) ResolvedHandler
|
||||
@@ -0,0 +1,58 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
module PostgREST.SchemaCache.Table
|
||||
( Column(..)
|
||||
, Table(..)
|
||||
, tableColumnsList
|
||||
, TablesMap
|
||||
, ColumnMap
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.HashMap.Strict.InsOrd as HMI
|
||||
|
||||
import PostgREST.SchemaCache.Identifiers (FieldName,
|
||||
QualifiedIdentifier (..),
|
||||
Schema, TableName)
|
||||
|
||||
import Protolude
|
||||
|
||||
|
||||
data Table = Table
|
||||
{ tableSchema :: Schema
|
||||
, tableName :: TableName
|
||||
, tableDescription :: Maybe Text
|
||||
-- TODO Find a better way to separate tables and views
|
||||
, tableIsView :: Bool
|
||||
-- The following fields identify what HTTP verbs can be executed on the table/view, they're not related to the privileges granted to it
|
||||
, tableInsertable :: Bool
|
||||
, tableUpdatable :: Bool
|
||||
, tableDeletable :: Bool
|
||||
, tablePKCols :: [FieldName]
|
||||
, tableColumns :: ColumnMap
|
||||
}
|
||||
deriving (Show, Generic, JSON.ToJSON)
|
||||
|
||||
tableColumnsList :: Table -> [Column]
|
||||
tableColumnsList = HMI.elems . tableColumns
|
||||
|
||||
instance Eq Table where
|
||||
Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2
|
||||
|
||||
data Column = Column
|
||||
{ colName :: FieldName
|
||||
, colDescription :: Maybe Text
|
||||
, colNullable :: Bool
|
||||
, colType :: Text
|
||||
, colNominalType :: Text
|
||||
, colMaxLen :: Maybe Int32
|
||||
, colDefault :: Maybe Text
|
||||
, colEnum :: [Text]
|
||||
}
|
||||
deriving (Eq, Show, Ord, Generic, JSON.ToJSON)
|
||||
|
||||
type TablesMap = HM.HashMap QualifiedIdentifier Table
|
||||
type ColumnMap = HMI.InsOrdHashMap FieldName Column
|
||||
@@ -0,0 +1,20 @@
|
||||
module PostgREST.TimeIt
|
||||
( timeItT
|
||||
) where
|
||||
|
||||
import GHC.Clock
|
||||
import Protolude
|
||||
|
||||
{-
|
||||
- The signature is the same as https://hackage.haskell.org/package/timeit-2.0/docs/src/System-TimeIt.html#timeIt,
|
||||
- we vendor this functionality because it gave errors as shown on https://github.com/PostgREST/postgrest/issues/4522 plus
|
||||
- the function is small enough. This vendored function is different in that the result is in milliseconds.
|
||||
-}
|
||||
timeItT :: MonadIO m => m a -> m (Double, a)
|
||||
timeItT p = do
|
||||
s <- liftIO getMonotonicTime
|
||||
x <- p
|
||||
e <- liftIO getMonotonicTime
|
||||
let time = (e - s) * 1000
|
||||
return (time, x)
|
||||
|
||||
@@ -0,0 +1,53 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module PostgREST.Unix
|
||||
( installSignalHandlers
|
||||
, createAndBindDomainSocket
|
||||
) where
|
||||
|
||||
#ifndef mingw32_HOST_OS
|
||||
import qualified System.Posix.Signals as Signals
|
||||
#endif
|
||||
import System.Posix.Types (FileMode)
|
||||
import System.PosixCompat.Files (setFileMode)
|
||||
|
||||
import Data.String (String)
|
||||
import qualified Network.Socket as NS
|
||||
import qualified PostgREST.Observation as Observation
|
||||
import Protolude
|
||||
import System.Directory (removeFile)
|
||||
import System.IO.Error (isDoesNotExistError)
|
||||
|
||||
-- | Set signal handlers, only for systems with signals
|
||||
installSignalHandlers :: Observation.ObservationHandler -> IO () -> IO () -> IO () -> IO ()
|
||||
#ifndef mingw32_HOST_OS
|
||||
installSignalHandlers observer interrupt usr1 usr2 = do
|
||||
install Signals.sigINT $ observer (Observation.TerminationUnixSignalObs "SIGINT") >> interrupt
|
||||
install Signals.sigTERM $ observer (Observation.TerminationUnixSignalObs "SIGTERM") >> interrupt
|
||||
install Signals.sigUSR1 usr1
|
||||
install Signals.sigUSR2 usr2
|
||||
where
|
||||
install signal handler =
|
||||
void $ Signals.installHandler signal (Signals.Catch handler) Nothing
|
||||
#else
|
||||
installSignalHandlers _ _ _ _ = pass
|
||||
#endif
|
||||
|
||||
-- | Create a unix domain socket and bind it to the given path.
|
||||
-- | The socket file will be deleted if it already exists.
|
||||
createAndBindDomainSocket :: String -> FileMode -> IO NS.Socket
|
||||
createAndBindDomainSocket path mode = do
|
||||
unless NS.isUnixDomainSocketAvailable $
|
||||
panic "Cannot run with unix socket on non-unix platforms. Consider deleting the `server-unix-socket` config entry in order to continue."
|
||||
deleteSocketFileIfExist path
|
||||
sock <- NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol
|
||||
NS.bind sock $ NS.SockAddrUnix path
|
||||
NS.listen sock (max 2048 NS.maxListenQueue)
|
||||
setFileMode path mode
|
||||
return sock
|
||||
where
|
||||
deleteSocketFileIfExist path' =
|
||||
removeFile path' `catch` handleDoesNotExist
|
||||
handleDoesNotExist e
|
||||
| isDoesNotExistError e = return ()
|
||||
| otherwise = throwIO e
|
||||
@@ -0,0 +1,41 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module PostgREST.Version
|
||||
( docsVersion
|
||||
, prettyVersion
|
||||
) where
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Protolude
|
||||
|
||||
-- Somehow this is not defined in doctests, so when running them
|
||||
-- on a file that includes Version.hs, compilation fails.
|
||||
#ifndef VERSION_postgrest
|
||||
#define VERSION_postgrest "0"
|
||||
#endif
|
||||
|
||||
version :: [Text]
|
||||
version = T.splitOn "." VERSION_postgrest
|
||||
|
||||
-- | User friendly version number such as '14.0'.
|
||||
-- Pre-release versions are tagged as such, e.g., '15 (pre-release)'.
|
||||
prettyVersion :: ByteString
|
||||
prettyVersion =
|
||||
(encodeUtf8 . T.intercalate "." $ take 2 version) <> preRelease
|
||||
where
|
||||
preRelease = if isPreRelease then " (pre-release)" else mempty
|
||||
|
||||
|
||||
-- | Version number used in docs.
|
||||
-- Pre-release versions link to the latest docs
|
||||
-- Uses only the first component of the version. Example: 'v1'
|
||||
docsVersion :: Text
|
||||
docsVersion
|
||||
| isPreRelease = "latest"
|
||||
| otherwise = "v" <> T.intercalate "." (take 1 version)
|
||||
|
||||
|
||||
-- | Versions with one components (e.g., '15') are treated as pre-releases.
|
||||
isPreRelease :: Bool
|
||||
isPreRelease =
|
||||
length version == 1
|
||||
Reference in New Issue
Block a user