diff --git a/.gitignore b/.gitignore index af81dde65d..9a34545196 100644 --- a/.gitignore +++ b/.gitignore @@ -13,7 +13,6 @@ site *#* .#* *.swp -result* dist-* postgrest.hp postgrest.prof diff --git a/cabal.project b/cabal.project index 313d3fc1f4..dbdfaaa0da 100644 --- a/cabal.project +++ b/cabal.project @@ -1,2 +1,29 @@ +with-compiler: ghc-9.4.8 + packages: postgrest.cabal tests: true + +source-repository-package + type: git + location: https://github.com/nikita-volkov/hasql + tag: 3b9cb47a20b7c3fa8b86a89e202fc10686211416 + +source-repository-package + type: git + location: https://github.com/nikita-volkov/hasql-dynamic-statements + tag: fe059d76f381e4bc486dffce928cde767cc54f6a + +source-repository-package + type: git + location: https://github.com/nikita-volkov/hasql-transaction + tag: b355efa7c666f73c1e07a2dcdeba8073da14c0ab + +source-repository-package + type: git + location: https://github.com/nikita-volkov/hasql-pool + tag: ae8957ba43af7804a707fffa29bbf807dd217f41 + +source-repository-package + type: git + location: https://github.com/nikita-volkov/hasql-notifications + tag: fdb39124518c57219d00be08e34f1f830a93adc3 diff --git a/cabal.project.freeze b/cabal.project.freeze deleted file mode 100644 index 969ea8cd03..0000000000 --- a/cabal.project.freeze +++ /dev/null @@ -1 +0,0 @@ -index-state: hackage.haskell.org 2025-10-13T04:53:27Z diff --git a/postgrest.cabal b/postgrest.cabal index 1524f5397b..4a7146f02b 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -66,6 +66,14 @@ library PostgREST.SchemaCache.Representations PostgREST.SchemaCache.Table PostgREST.Error + PostgREST.Error.Algebra + PostgREST.Error.ApiRequestError + PostgREST.Error.Error + PostgREST.Error.PgError + PostgREST.Error.PgError.ServerError + PostgREST.Error.PgError.ServerError.RaisePgrst + PostgREST.Error.PgError.UsageError + PostgREST.Error.SchemaCacheError PostgREST.Listener PostgREST.Logger PostgREST.MainTx @@ -98,7 +106,7 @@ library build-depends: base >= 4.9 && < 4.20 , HTTP >= 4000.3.7 && < 4000.5 , Ranged-sets >= 0.3 && < 0.5 - , aeson >= 2.0.3 && < 2.3 + , aeson >= 2.2.1 && < 2.3 , auto-update >= 0.1.4 && < 0.3 , base64-bytestring >= 1 && < 1.3 , bytestring >= 0.10.8 && < 0.13 @@ -113,11 +121,11 @@ library , either >= 4.4.1 && < 5.1 , extra >= 1.7.0 && < 2.0 , fuzzyset >= 0.2.4 && < 0.3 - , hasql >= 1.6.1.1 && < 1.7 + , hasql >= 1.9 && < 1.11 , hasql-dynamic-statements >= 0.3.1 && < 0.4 - , hasql-notifications >= 0.2.2.2 && < 0.2.3 - , hasql-pool >= 1.0.1 && < 1.1 - , hasql-transaction >= 1.0.1 && < 1.2 + , hasql-notifications >= 0.2.2.2 && < 0.3 + , hasql-pool >= 1.4 && < 1.5 + , hasql-transaction >= 1.2 && < 1.3 , heredoc >= 0.2 && < 0.3 , http-client >= 0.7.19 && < 0.8 , http-types >= 0.12.2 && < 0.13 @@ -262,15 +270,16 @@ test-suite spec Feature.RpcPreRequestGucsSpec SpecHelper build-depends: base >= 4.9 && < 4.20 - , aeson >= 2.0.3 && < 2.3 + , aeson >= 2.2.1 && < 2.3 , aeson-qq >= 0.8.1 && < 0.9 , async >= 2.1.1 && < 2.3 , base64-bytestring >= 1 && < 1.3 , bytestring >= 0.10.8 && < 0.13 , case-insensitive >= 1.2 && < 1.3 , containers >= 0.5.7 && < 0.7 - , hasql-pool >= 1.0.1 && < 1.1 - , hasql-transaction >= 1.0.1 && < 1.2 + , hasql >= 1.9 && < 1.11 + , hasql-pool >= 1.4 && < 1.5 + , hasql-transaction >= 1.2 && < 1.3 , heredoc >= 0.2 && < 0.3 , hspec >= 2.3 && < 2.12 , hspec-expectations >= 0.8.4 && < 0.9 diff --git a/src/PostgREST/AppState.hs b/src/PostgREST/AppState.hs index 9a65871cc6..e61ce4b304 100644 --- a/src/PostgREST/AppState.hs +++ b/src/PostgREST/AppState.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-unused-binds -Wno-unused-imports -Wno-name-shadowing -Wno-incomplete-patterns -Wno-unused-matches -Wno-missing-methods -Wno-unused-record-wildcards -Wno-redundant-constraints -Wno-deprecations #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} @@ -32,10 +33,12 @@ module PostgREST.AppState import qualified Data.ByteString.Char8 as BS import Data.Either.Combinators (whenLeft) -import qualified Data.Text as T (unpack) +import qualified Data.Text as T import qualified Hasql.Pool as SQL import qualified Hasql.Pool.Config as SQL +import qualified Hasql.Connection.Settings as SQL import qualified Hasql.Session as SQL +import qualified Hasql.Errors as SQL import qualified Hasql.Transaction.Sessions as SQL import qualified Network.HTTP.Types.Status as HTTP import qualified Network.Socket as NS @@ -43,8 +46,8 @@ 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 qualified PostgREST.Version as Version import PostgREST.Observation -import PostgREST.Version (prettyVersion) import System.TimeIt (timeItT) import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, @@ -59,7 +62,6 @@ import Data.Time.Clock (UTCTime, getCurrentTime) import PostgREST.Auth.JwtCache (JwtCacheState, update) import PostgREST.Config (AppConfig (..), - addFallbackAppName, readAppConfig) import PostgREST.Config.Database (queryDbSettings, queryPgVersion, @@ -125,7 +127,7 @@ init conf@AppConfig{configLogLevel, configDbPoolSize} = do metricsState <- Metrics.init configDbPoolSize let observer = liftA2 (>>) (Logger.observationLogger loggerState configLogLevel) (Metrics.observationMetrics metricsState) - observer $ AppStartObs prettyVersion + observer $ AppStartObs Version.prettyVersion pool <- initPool conf observer (sock, adminSock) <- initSockets conf @@ -207,7 +209,13 @@ initPool AppConfig{..} observer = do , SQL.acquisitionTimeout $ fromIntegral configDbPoolAcquisitionTimeout , SQL.agingTimeout $ fromIntegral configDbPoolMaxLifetime , SQL.idlenessTimeout $ fromIntegral configDbPoolMaxIdletime - , SQL.staticConnectionSettings (toUtf8 $ addFallbackAppName prettyVersion configDbUri) + , SQL.staticConnectionSettings $ mconcat $ + [ SQL.connectionString configDbUri + , SQL.noPreparedStatements (not configDbPreparedStatements) + , SQL.other + "fallback_application_name" + ("PostgREST " <> Version.prettyVersionText) + ] , SQL.observationHandler $ observer . HasqlPoolObs ] @@ -223,47 +231,50 @@ usePool AppState{stateObserver=observer, stateMainThreadId=mainThreadId, ..} ses whenLeft res (\case SQL.AcquisitionTimeoutUsageError -> observer $ PoolAcqTimeoutObs SQL.AcquisitionTimeoutUsageError - 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 + err@(SQL.ConnectionUsageError (SQL.AuthenticationConnectionError msg)) -> do + observer $ ExitDBFatalError ServerAuthError err + killThread mainThreadId + err@(SQL.ConnectionUsageError _) -> pure () + err@(SQL.SessionUsageError (SQL.StatementSessionError _ _ tpl _ _ statementErr)) -> case statementErr of + SQL.UnexpectedResultStatementError{} -> do + observer $ ExitDBFatalError ServerPgrstBug err killThread mainThreadId - err@(SQL.SessionUsageError (SQL.QueryError tpl _ (SQL.ResultError resultErr))) -> do - case resultErr of - SQL.UnexpectedResult{} -> do - observer $ ExitDBFatalError ServerPgrstBug err - killThread mainThreadId - SQL.RowError{} -> do - observer $ ExitDBFatalError ServerPgrstBug err - killThread mainThreadId - SQL.UnexpectedAmountOfRows{} -> do + SQL.RowStatementError{} -> do + observer $ ExitDBFatalError ServerPgrstBug err + killThread mainThreadId + SQL.UnexpectedRowCountStatementError{} -> do + observer $ ExitDBFatalError ServerPgrstBug err + killThread mainThreadId + SQL.UnexpectedColumnTypeStatementError{} -> do + observer $ ExitDBFatalError ServerPgrstBug err + killThread mainThreadId + -- 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.ServerStatementError (SQL.ServerError "42601" _ _ _ _) -> + unless ("WITH pgrst_source" `T.isPrefixOf` tpl) $ do observer $ ExitDBFatalError ServerPgrstBug err killThread mainThreadId - -- 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 - killThread mainThreadId - -- Check for a "prepared statement 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 - killThread mainThreadId - -- 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 - killThread mainThreadId - SQL.ServerError{} -> - when (Error.status (Error.PgError False err) >= HTTP.status500) $ - observer $ QueryErrorCodeHighObs err - err@(SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ClientError _))) -> - -- An error on the client-side, usually indicates problems wth connection - observer $ QueryErrorCodeHighObs err + -- Check for a "prepared statement 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.ServerStatementError (SQL.ServerError "42P05" _ _ _ _) -> do + observer $ ExitDBFatalError ServerError42P05 err + killThread mainThreadId + -- 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.ServerStatementError (SQL.ServerError "08P01" "transaction blocks not allowed in statement pooling mode" _ _ _) -> do + observer $ ExitDBFatalError ServerError08P01 err + killThread mainThreadId + SQL.ServerStatementError _ -> + when (Error.status (Error.PgError False err) >= HTTP.status500) $ + observer $ QueryErrorCodeHighObs err + err@(SQL.SessionUsageError (SQL.ConnectionSessionError _)) -> + observer $ QueryErrorCodeHighObs err + err@(SQL.SessionUsageError (SQL.DriverSessionError _)) -> + -- An error on the client-side, possibly indicates problems wth connection + observer $ QueryErrorCodeHighObs err ) return res @@ -328,7 +339,7 @@ isConnEstablished appState = do 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") + isRight <$> usePool appState (SQL.script "SELECT 1") putIsListenerOn :: AppState -> Bool -> IO () putIsListenerOn = atomicWriteIORef . stateIsListenerOn @@ -374,7 +385,7 @@ retryingSchemaCacheLoad appState@AppState{stateObserver=observer, stateMainThrea qPgVersion :: IO (Maybe PgVersion) qPgVersion = do AppConfig{..} <- getConfig appState - pgVersion <- usePool appState (queryPgVersion False) -- No need to prepare the query here, as the connection might not be established + pgVersion <- usePool appState queryPgVersion case pgVersion of Left e -> do observer $ QueryPgVersionError e @@ -400,8 +411,7 @@ retryingSchemaCacheLoad appState@AppState{stateObserver=observer, stateMainThrea qSchemaCache = do conf@AppConfig{..} <- getConfig appState (resultTime, result) <- - let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in - timeItT $ usePool appState (transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf) + timeItT $ usePool appState (SQL.transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf) case result of Left e -> do putSCacheStatus appState SCPending @@ -441,7 +451,7 @@ readInDbConfig startingUp appState@AppState{stateObserver=observer} = do pgVer <- getPgVersion appState dbSettings <- if configDbConfig conf then do - qDbSettings <- usePool appState (queryDbSettings (dumpQi <$> configDbPreConfig conf) (configDbPreparedStatements conf)) + qDbSettings <- usePool appState (queryDbSettings (dumpQi <$> configDbPreConfig conf)) case qDbSettings of Left e -> do observer $ ConfigReadErrorObs e @@ -451,7 +461,7 @@ readInDbConfig startingUp appState@AppState{stateObserver=observer} = do pure mempty (roleSettings, roleIsolationLvl) <- if configDbConfig conf then do - rSettings <- usePool appState (queryRoleSettings pgVer (configDbPreparedStatements conf)) + rSettings <- usePool appState (queryRoleSettings pgVer) case rSettings of Left e -> do observer $ QueryRoleSettingsErrorObs e diff --git a/src/PostgREST/CLI.hs b/src/PostgREST/CLI.hs index a635aa0814..e633200347 100644 --- a/src/PostgREST/CLI.hs +++ b/src/PostgREST/CLI.hs @@ -62,9 +62,8 @@ dumpSchema :: AppState -> IO LBS.ByteString dumpSchema appState = do conf@AppConfig{..} <- AppState.getConfig appState result <- - let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in AppState.usePool appState - (transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf) + (SQL.transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf) case result of Left e -> do let observer = AppState.getObserver appState diff --git a/src/PostgREST/Config/Database.hs b/src/PostgREST/Config/Database.hs index aff4b5b8a3..a469c3e6dd 100644 --- a/src/PostgREST/Config/Database.hs +++ b/src/PostgREST/Config/Database.hs @@ -70,11 +70,11 @@ dbSettingsNames = ,"server_timing_enabled" ] -queryPgVersion :: Bool -> Session PgVersion -queryPgVersion prepared = statement mempty $ pgVersionStatement prepared +queryPgVersion :: Session PgVersion +queryPgVersion = statement mempty pgVersionStatement -pgVersionStatement :: Bool -> SQL.Statement () PgVersion -pgVersionStatement = SQL.Statement sql HE.noParams versionRow +pgVersionStatement :: SQL.Statement () PgVersion +pgVersionStatement = SQL.preparable 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 @@ -90,12 +90,11 @@ pgVersionStatement = SQL.Statement sql HE.noParams versionRow -- -- The example above will result in jwt_aud = 'val' -- A setting on the database only will have no effect: ALTER DATABASE postgres SET jwt_aud = 'xx' -queryDbSettings :: Maybe Text -> Bool -> Session [(Text, Text)] -queryDbSettings preConfFunc prepared = - let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction in - transaction SQL.ReadCommitted SQL.Read $ SQL.statement dbSettingsNames $ SQL.Statement sql (arrayParam HE.text) decodeSettings prepared +queryDbSettings :: Maybe Text -> Session [(Text, Text)] +queryDbSettings preConfFunc = + SQL.transaction SQL.ReadCommitted SQL.Read $ SQL.statement dbSettingsNames $ SQL.preparable sql (arrayParam HE.text) decodeSettings where - sql = encodeUtf8 [trimming| + sql = [trimming| WITH role_setting AS ( SELECT setdatabase as database, @@ -131,12 +130,11 @@ queryDbSettings preConfFunc prepared = |]::Text decodeSettings = HD.rowList $ (,) <$> column HD.text <*> column HD.text -queryRoleSettings :: PgVersion -> Bool -> Session (RoleSettings, RoleIsolationLvl) -queryRoleSettings pgVer prepared = - let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction in - transaction SQL.ReadCommitted SQL.Read $ SQL.statement mempty $ SQL.Statement sql HE.noParams (processRows <$> rows) prepared +queryRoleSettings :: PgVersion -> Session (RoleSettings, RoleIsolationLvl) +queryRoleSettings pgVer = + SQL.transaction SQL.ReadCommitted SQL.Read $ SQL.statement mempty $ SQL.preparable sql HE.noParams (processRows <$> rows) where - sql = encodeUtf8 [trimming| + sql = [trimming| with role_setting as ( select r.rolname, unnest(r.rolconfig) as setting @@ -181,7 +179,7 @@ queryRoleSettings pgVer prepared = ) rows :: HD.Result [(Text, Maybe Text, [(Text, Text)])] - rows = HD.rowList $ (,,) <$> column HD.text <*> nullableColumn HD.text <*> compositeArrayColumn ((,) <$> compositeField HD.text <*> compositeField HD.text) + rows = HD.rowList $ (,,) <$> column HD.text <*> nullableColumn HD.text <*> recordArrayColumn ((,) <$> compositeField HD.text <*> compositeField HD.text) column :: HD.Value a -> HD.Row a column = HD.column . HD.nonNullable @@ -192,8 +190,8 @@ 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 +recordArrayColumn :: HD.Composite a -> HD.Row [a] +recordArrayColumn = arrayColumn . HD.record arrayColumn :: HD.Value a -> HD.Row [a] arrayColumn = column . HD.listArray . HD.nonNullable diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index 39217610cf..9e16404d0a 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -2,8 +2,6 @@ Module : PostgREST.Error Description : PostgREST error HTTP responses -} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE RecordWildCards #-} module PostgREST.Error ( errorResponseFor @@ -20,799 +18,8 @@ module PostgREST.Error , status ) 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.SchemaCache.Identifiers (QualifiedIdentifier (..), - Schema) -import PostgREST.SchemaCache.Relationship (Cardinality (..), - Junction (..), - Relationship (..), - RelationshipsMap) -import PostgREST.SchemaCache.Routine (Routine (..), - RoutineParam (..)) -import PostgREST.SchemaCache.Table (Table (..)) -import Protolude - - -class (ErrorBody a, JSON.ToJSON a) => PgrstError a where - status :: a -> HTTP.Status - headers :: a -> [Header] - - errorPayload :: a -> LByteString - errorPayload = JSON.encode - - errorResponseFor :: a -> Response - errorResponseFor err = - let - baseHeader = MediaType.toContentType MTApplicationJSON - cLHeader body = (,) "Content-Length" (show $ LBS.length body) :: Header - in - responseLBS (status err) (baseHeader : cLHeader (errorPayload err) : headers err) $ errorPayload err - -class ErrorBody a where - code :: a -> Text - message :: a -> Text - details :: a -> Maybe JSON.Value - hint :: a -> Maybe JSON.Value - -data ApiRequestError - = AggregatesNotAllowed - | MediaTypeError [ByteString] - | InvalidBody ByteString - | InvalidFilters - | InvalidPreferences [ByteString] - | InvalidRange RangeError - | InvalidRpcMethod ByteString - | NotEmbedded 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 - -instance PgrstError 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 _ = Nothing - - -- HINT: Maybe JSON.Value - hint (NotEmbedded resource) = Just $ JSON.String $ "Verify that '" <> resource <> "' is included in the 'select' query parameter." - 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 JSON.ToJSON ApiRequestError where - toJSON err = toJsonPgrstError - (code err) (message err) (details err) (hint err) - -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 [Table] - deriving Show - -instance PgrstError 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 tbls) = JSON.String <$> tableNotFoundHint schemaName relName tbls - - hint _ = Nothing - -instance JSON.ToJSON SchemaCacheError where - toJSON err = toJsonPgrstError - (code err) (message err) (details err) (hint err) - -toJsonPgrstError :: Text -> Text -> Maybe JSON.Value -> Maybe JSON.Value -> JSON.Value -toJsonPgrstError code' message' details' hint' = JSON.object [ - "code" .= code' - , "message" .= message' - , "details" .= details' - , "hint" .= hint' - ] - --- | --- 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" "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 [] --- Just "Perhaps you meant to call the function api.another" --- --- >>> 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 = Fuzzy.getOne fuzzySetOfProcs procName - | otherwise = (procName <>) <$> Fuzzy.getOne fuzzySetOfParams (listToText params) - --- | --- Do a fuzzy search in all tables in the same schema and return closest result -tableNotFoundHint :: Text -> Text -> [Table] -> Maybe Text -tableNotFoundHint schema tblName tblList - = fmap (\tbl -> "Perhaps you meant the table '" <> schema <> "." <> tbl <> "'") perhapsTable - where - perhapsTable = Fuzzy.getOne fuzzyTableSet tblName - fuzzyTableSet = Fuzzy.fromList [ tableName tbl | tbl <- tblList, tableSchema tbl == schema] - - -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'." - -data PgError = PgError Authenticated SQL.UsageError - deriving Show - -type Authenticated = Bool - -instance PgrstError 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 - -proxyStatusHeader :: Text -> Header -proxyStatusHeader code' = ("Proxy-Status", "PostgREST; error=" <> T.encodeUtf8 code') - -instance JSON.ToJSON PgError where - toJSON (PgError _ usageError) = toJsonPgrstError - (code usageError) (message usageError) (details usageError) (hint usageError) - -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 JSON.ToJSON SQL.UsageError where - toJSON err = toJsonPgrstError - (code err) (message err) (details err) (hint err) - -instance ErrorBody SQL.UsageError where - code (SQL.ConnectionUsageError _) = "PGRST000" - code (SQL.SessionUsageError (SQL.QueryError _ _ e)) = code e - code SQL.AcquisitionTimeoutUsageError = "PGRST003" - - message (SQL.ConnectionUsageError _) = "Database connection error. Retrying the connection." - 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.QueryError _ _ e)) = details e - details SQL.AcquisitionTimeoutUsageError = Nothing - - hint (SQL.ConnectionUsageError _) = Nothing - hint (SQL.SessionUsageError (SQL.QueryError _ _ e)) = hint e - hint SQL.AcquisitionTimeoutUsageError = Nothing - -instance JSON.ToJSON SQL.CommandError where - toJSON err = toJsonPgrstError - (code err) (message err) (details err) (hint err) - -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.QueryError _ _ (SQL.ClientError _))) = HTTP.status503 -pgErrorStatus authed (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError 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 - - -data Error - = ApiRequestError ApiRequestError - | SchemaCacheErr SchemaCacheError - | JwtErr JwtError - | NoSchemaCacheError - | PgErr PgError - deriving Show - -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 - -instance PgrstError Error where - status (ApiRequestError err) = status err - status (SchemaCacheErr err) = status err - status (JwtErr err) = status err - status NoSchemaCacheError = HTTP.status503 - status (PgErr err) = status err - - headers (ApiRequestError err) = proxyStatusHeader (code err) : headers err - headers (SchemaCacheErr err) = proxyStatusHeader (code err) : headers err - headers (JwtErr err) = proxyStatusHeader (code err) : headers err - headers (PgErr err) = proxyStatusHeader (code err) : headers err - headers err@NoSchemaCacheError = proxyStatusHeader (code err) : mempty - -instance JSON.ToJSON Error where - toJSON err = toJsonPgrstError - (code err) (message err) (details err) (hint err) - -instance ErrorBody Error where - code (ApiRequestError err) = code err - code (SchemaCacheErr err) = code err - code (JwtErr err) = code err - code NoSchemaCacheError = "PGRST002" - code (PgErr err) = code err - - message (ApiRequestError 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 (ApiRequestError err) = details err - details (SchemaCacheErr err) = details err - details (JwtErr err) = details err - details NoSchemaCacheError = Nothing - details (PgErr err) = details err - - hint (ApiRequestError err) = hint err - hint (SchemaCacheErr err) = hint err - hint (JwtErr err) = hint err - hint NoSchemaCacheError = Nothing - hint (PgErr err) = hint err - -instance PgrstError 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 JSON.ToJSON JwtError where - toJSON err = toJsonPgrstError - (code err) (message err) (details err) (hint err) - -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 -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 -} - -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) +import PostgREST.Error.Algebra +import PostgREST.Error.ApiRequestError +import PostgREST.Error.Error +import PostgREST.Error.PgError +import PostgREST.Error.SchemaCacheError diff --git a/src/PostgREST/Error/Algebra.hs b/src/PostgREST/Error/Algebra.hs new file mode 100644 index 0000000000..c116bb59d2 --- /dev/null +++ b/src/PostgREST/Error/Algebra.hs @@ -0,0 +1,38 @@ +module PostgREST.Error.Algebra where + +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Lazy as LBS +import qualified Network.HTTP.Types as HTTP +import qualified PostgREST.MediaType as MediaType + +import Network.Wai (Response, responseLBS) +import Protolude + +class (ErrorBody a, JSON.ToJSON a) => PgrstError a where + status :: a -> HTTP.Status + headers :: a -> [HTTP.Header] + + errorPayload :: a -> LByteString + errorPayload = JSON.encode + + errorResponseFor :: a -> Response + errorResponseFor err = + let + baseHeader = MediaType.toContentType MediaType.MTApplicationJSON + cLHeader body = (,) "Content-Length" (show $ LBS.length body) :: HTTP.Header + in + responseLBS (status err) (baseHeader : cLHeader (errorPayload err) : headers err) $ errorPayload err + +class ErrorBody a where + code :: a -> Text + message :: a -> Text + details :: a -> Maybe JSON.Value + hint :: a -> Maybe JSON.Value + +toJsonPgrstError :: Text -> Text -> Maybe JSON.Value -> Maybe JSON.Value -> JSON.Value +toJsonPgrstError code' message' details' hint' = JSON.object [ + "code" JSON..= code' + , "message" JSON..= message' + , "details" JSON..= details' + , "hint" JSON..= hint' + ] diff --git a/src/PostgREST/Error/ApiRequestError.hs b/src/PostgREST/Error/ApiRequestError.hs new file mode 100644 index 0000000000..6ca228e047 --- /dev/null +++ b/src/PostgREST/Error/ApiRequestError.hs @@ -0,0 +1,196 @@ +module PostgREST.Error.ApiRequestError + ( ApiRequestError(..), + QPError(..), + RaiseError(..), + RangeError(..), + ) where + +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Char8 as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Network.HTTP.Types.Status as HTTP + +import PostgREST.Error.Algebra +import Protolude + +data ApiRequestError + = AggregatesNotAllowed + | MediaTypeError [ByteString] + | InvalidBody ByteString + | InvalidFilters + | InvalidPreferences [ByteString] + | InvalidRange RangeError + | InvalidRpcMethod ByteString + | NotEmbedded 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 Text + | DetParseError Text + | NoDetail + deriving Show + +data RangeError + = NegativeLimit + | LowerGTUpper + | OutOfBounds Text Text + deriving Show + +instance PgrstError 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 _ = Nothing + + -- HINT: Maybe JSON.Value + hint (NotEmbedded resource) = Just $ JSON.String $ "Verify that '" <> resource <> "' is included in the 'select' query parameter." + 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 JSON.ToJSON ApiRequestError where + toJSON err = toJsonPgrstError + (code err) (message err) (details err) (hint err) + +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'." + +pgrstParseErrorDetails :: RaiseError -> Text +pgrstParseErrorDetails err = case err of + MsgParseError m -> "Invalid JSON value for MESSAGE: '" <> m <> "'" + DetParseError d -> "Invalid JSON value for DETAIL: '" <> d <> "'" + NoDetail -> "DETAIL is missing in the RAISE statement" diff --git a/src/PostgREST/Error/Error.hs b/src/PostgREST/Error/Error.hs new file mode 100644 index 0000000000..0151000374 --- /dev/null +++ b/src/PostgREST/Error/Error.hs @@ -0,0 +1,157 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module PostgREST.Error.Error + ( Error (..) + , JwtError (..) + , JwtDecodeError (..) + , JwtClaimsError (..) + ) where + +import qualified Data.Aeson as JSON +import qualified Data.Text.Encoding as T +import qualified Network.HTTP.Types as HTTP + +import PostgREST.Error.Algebra +import PostgREST.Error.ApiRequestError +import PostgREST.Error.PgError +import PostgREST.Error.SchemaCacheError +import Protolude + +data Error + = ApiRequestError ApiRequestError + | SchemaCacheErr SchemaCacheError + | JwtErr JwtError + | NoSchemaCacheError + | PgErr PgError + deriving Show + +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 + +instance PgrstError Error where + status (ApiRequestError err) = status err + status (SchemaCacheErr err) = status err + status (JwtErr err) = status err + status NoSchemaCacheError = HTTP.status503 + status (PgErr err) = status err + + headers (ApiRequestError err) = proxyStatusHeader (code err) : headers err + headers (SchemaCacheErr err) = proxyStatusHeader (code err) : headers err + headers (JwtErr err) = proxyStatusHeader (code err) : headers err + headers (PgErr err) = proxyStatusHeader (code err) : headers err + headers err@NoSchemaCacheError = proxyStatusHeader (code err) : mempty + +instance JSON.ToJSON Error where + toJSON err = toJsonPgrstError + (code err) (message err) (details err) (hint err) + +instance ErrorBody Error where + code (ApiRequestError err) = code err + code (SchemaCacheErr err) = code err + code (JwtErr err) = code err + code NoSchemaCacheError = "PGRST002" + code (PgErr err) = code err + + message (ApiRequestError 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 (ApiRequestError err) = details err + details (SchemaCacheErr err) = details err + details (JwtErr err) = details err + details NoSchemaCacheError = Nothing + details (PgErr err) = details err + + hint (ApiRequestError err) = hint err + hint (SchemaCacheErr err) = hint err + hint (JwtErr err) = hint err + hint NoSchemaCacheError = Nothing + hint (PgErr err) = hint err + +instance PgrstError 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 JSON.ToJSON JwtError where + toJSON err = toJsonPgrstError + (code err) (message err) (details err) (hint err) + +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 -> HTTP.Header +invalidTokenHeader m = + ("WWW-Authenticate", "Bearer error=\"invalid_token\", " <> "error_description=" <> encodeUtf8 (show m)) + +requiredTokenHeader :: HTTP.Header +requiredTokenHeader = ("WWW-Authenticate", "Bearer") + +proxyStatusHeader :: Text -> HTTP.Header +proxyStatusHeader code' = ("Proxy-Status", "PostgREST; error=" <> T.encodeUtf8 code') diff --git a/src/PostgREST/Error/PgError.hs b/src/PostgREST/Error/PgError.hs new file mode 100644 index 0000000000..063c8d9686 --- /dev/null +++ b/src/PostgREST/Error/PgError.hs @@ -0,0 +1,41 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ViewPatterns #-} + +module PostgREST.Error.PgError + ( PgError(..), + Authenticated, + ) where + +import qualified Data.Aeson as JSON +import qualified Hasql.Pool as SQL +import qualified Network.HTTP.Types as HTTP +import qualified PostgREST.Error.PgError.UsageError as UsageError + +import PostgREST.Error.Algebra +import Protolude + +data PgError = PgError Authenticated SQL.UsageError + deriving Show + +type Authenticated = Bool + +instance PgrstError PgError where + status (PgError authed usageError) = UsageError.pgErrorStatus authed usageError + + headers (PgError _ (UsageError.maybeHeaders -> Just matchingHeaders)) = + matchingHeaders + + headers err = + if status err == HTTP.status401 + then [("WWW-Authenticate", "Bearer") :: HTTP.Header] + else mempty + +instance JSON.ToJSON PgError where + toJSON (PgError _ usageError) = toJsonPgrstError + (code usageError) (message usageError) (details usageError) (hint usageError) + +instance ErrorBody PgError where + code (PgError _ usageError) = code usageError + message (PgError _ usageError) = message usageError + details (PgError _ usageError) = details usageError + hint (PgError _ usageError) = hint usageError diff --git a/src/PostgREST/Error/PgError/ServerError.hs b/src/PostgREST/Error/PgError/ServerError.hs new file mode 100644 index 0000000000..fefab84692 --- /dev/null +++ b/src/PostgREST/Error/PgError/ServerError.hs @@ -0,0 +1,102 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module PostgREST.Error.PgError.ServerError + ( pgErrorStatus, + maybeHeaders, + ) where + +import qualified Data.Aeson as JSON +import qualified Data.CaseInsensitive as CI +import qualified Data.Map.Internal as M +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Hasql.Errors as SQL +import qualified Network.HTTP.Types as HTTP +import qualified PostgREST.Error.PgError.ServerError.RaisePgrst as RaisePgrst + +import PostgREST.Error.Algebra +import Protolude + +instance ErrorBody SQL.ServerError where + -- Special error raised with code PGRST, to allow full response control + code (SQL.ServerError "PGRST" m d _ _) = + case RaisePgrst.parseRaisePGRST m d of + Right (r, _) -> RaisePgrst.getCode r + Left e -> code e + code (SQL.ServerError c _ _ _ _) = c + + message (SQL.ServerError "PGRST" m d _ _) = + case RaisePgrst.parseRaisePGRST m d of + Right (r, _) -> RaisePgrst.getMessage r + Left e -> message e + message (SQL.ServerError _ m _ _ _) = m + + details (SQL.ServerError "PGRST" m d _ _) = + case RaisePgrst.parseRaisePGRST m d of + Right (r, _) -> JSON.String <$> RaisePgrst.getDetails r + Left e -> details e + details (SQL.ServerError _ _ d _ _) = JSON.String <$> d + + hint (SQL.ServerError "PGRST" m d _ _p) = + case RaisePgrst.parseRaisePGRST m d of + Right (r, _) -> JSON.String <$> RaisePgrst.getHint r + Left e -> hint e + hint (SQL.ServerError _ _ _ h _) = JSON.String <$> h + +pgErrorStatus :: Bool -> SQL.ServerError -> HTTP.Status +pgErrorStatus authed (SQL.ServerError c m d _ _) = case T.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 T.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 T.isPrefixOf "role" m && T.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 T.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 (T.encodeUtf8 m)) + "PGRST" -> + case RaisePgrst.parseRaisePGRST m d of + Right (_, r) -> maybe (toEnum $ RaisePgrst.getStatus r) (HTTP.mkStatus (RaisePgrst.getStatus r) . T.encodeUtf8) (RaisePgrst.getStatusText r) + Left e -> status e + _ -> HTTP.status400 + +maybeHeaders :: SQL.ServerError -> Maybe [HTTP.Header] +maybeHeaders (SQL.ServerError "PGRST" m d _ _p) = + Just $ case RaisePgrst.parseRaisePGRST m d of + Right (_, r) -> map intoHeader (M.toList $ RaisePgrst.getHeaders r) + Left e -> headers e + where + intoHeader (k,v) = (CI.mk $ T.encodeUtf8 k, T.encodeUtf8 v) +maybeHeaders _ = Nothing diff --git a/src/PostgREST/Error/PgError/ServerError/RaisePgrst.hs b/src/PostgREST/Error/PgError/ServerError/RaisePgrst.hs new file mode 100644 index 0000000000..c08028a854 --- /dev/null +++ b/src/PostgREST/Error/PgError/ServerError/RaisePgrst.hs @@ -0,0 +1,46 @@ +module PostgREST.Error.PgError.ServerError.RaisePgrst where + +import qualified Data.Aeson as JSON +import qualified PostgREST.Error.ApiRequestError as ApiRequestError +import Protolude + +-- 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 + } + +instance JSON.FromJSON PgRaiseErrMessage where + parseJSON (JSON.Object m) = + PgRaiseErrMessage + <$> m JSON..: "code" + <*> m JSON..: "message" + <*> m JSON..:? "details" + <*> m JSON..:? "hint" + parseJSON _ = mzero + +data PgRaiseErrDetails = PgRaiseErrDetails + { getStatus :: Int, + getStatusText :: Maybe Text, + getHeaders :: Map Text Text + } + +instance JSON.FromJSON PgRaiseErrDetails where + parseJSON (JSON.Object d) = + PgRaiseErrDetails + <$> d JSON..: "status" + <*> d JSON..:? "status_text" + <*> d JSON..: "headers" + parseJSON _ = mzero + +parseRaisePGRST :: + Text -> + Maybe Text -> + Either ApiRequestError.ApiRequestError (PgRaiseErrMessage, PgRaiseErrDetails) +parseRaisePGRST m d = do + msgJson <- maybeToRight (ApiRequestError.PGRSTParseError $ ApiRequestError.MsgParseError m) (JSON.decodeStrictText m) + det <- maybeToRight (ApiRequestError.PGRSTParseError ApiRequestError.NoDetail) d + detJson <- maybeToRight (ApiRequestError.PGRSTParseError $ ApiRequestError.DetParseError det) (JSON.decodeStrictText det) + return (msgJson, detJson) diff --git a/src/PostgREST/Error/PgError/UsageError.hs b/src/PostgREST/Error/PgError/UsageError.hs new file mode 100644 index 0000000000..83b919eec6 --- /dev/null +++ b/src/PostgREST/Error/PgError/UsageError.hs @@ -0,0 +1,62 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module PostgREST.Error.PgError.UsageError where + +import qualified Data.Aeson as JSON +import qualified Hasql.Pool as SQL +import qualified Hasql.Errors as SQL +import qualified Network.HTTP.Types as HTTP +import qualified PostgREST.Error.PgError.ServerError as ServerError + +import PostgREST.Error.Algebra +import Protolude + + +instance JSON.ToJSON SQL.UsageError where + toJSON err = toJsonPgrstError + (code err) (message err) (details err) (hint err) + +instance ErrorBody SQL.UsageError where + code (SQL.ConnectionUsageError _) = "PGRST000" + code SQL.AcquisitionTimeoutUsageError = "PGRST003" + code (SQL.SessionUsageError (SQL.StatementSessionError _ _ _ _ _ (SQL.ServerStatementError serverError))) = code serverError + code (SQL.SessionUsageError (SQL.StatementSessionError _ _ _ _ _ _)) = "PGRSTX00" + code (SQL.SessionUsageError (SQL.ScriptSessionError _ serverError)) = code serverError + code (SQL.SessionUsageError (SQL.ConnectionSessionError _)) = "PGRST001" + code (SQL.SessionUsageError (SQL.DriverSessionError _)) = "PGRST001" + code (SQL.SessionUsageError (SQL.MissingTypesSessionError _)) = "PGRSTX00" + + message (SQL.ConnectionUsageError _) = "Database connection error. Retrying the connection." + message SQL.AcquisitionTimeoutUsageError = "Timed out acquiring connection from connection pool." + message (SQL.SessionUsageError (SQL.StatementSessionError _ _ _ _ _ (SQL.ServerStatementError serverError))) = message serverError + message (SQL.SessionUsageError (SQL.StatementSessionError _ _ _ _ _ _)) = "Result processing error." + message (SQL.SessionUsageError (SQL.ScriptSessionError _ serverError)) = message serverError + message (SQL.SessionUsageError (SQL.ConnectionSessionError _)) = "Database connection error. Retrying the connection." + message (SQL.SessionUsageError (SQL.DriverSessionError _)) = "Database client error. Retrying the connection." + message (SQL.SessionUsageError (SQL.MissingTypesSessionError _)) = "Missing named types requested." + + details (SQL.ConnectionUsageError e) = Just (JSON.String (SQL.toErrorMessage e)) + details SQL.AcquisitionTimeoutUsageError = Nothing + details (SQL.SessionUsageError (SQL.StatementSessionError _ _ _ _ _ (SQL.ServerStatementError serverError))) = details serverError + details (SQL.SessionUsageError (SQL.ScriptSessionError _ serverError)) = details serverError + details (SQL.SessionUsageError sessionError) = Just (JSON.String (SQL.toErrorMessage sessionError)) + + hint (SQL.SessionUsageError (SQL.StatementSessionError _ _ _ _ _ (SQL.ServerStatementError serverError))) = + hint serverError + hint (SQL.SessionUsageError (SQL.ScriptSessionError _ serverError)) = + hint serverError + hint _ = Nothing + +pgErrorStatus :: Bool -> SQL.UsageError -> HTTP.Status +pgErrorStatus _ (SQL.ConnectionUsageError _) = HTTP.status503 +pgErrorStatus _ SQL.AcquisitionTimeoutUsageError = HTTP.status504 +pgErrorStatus authed (SQL.SessionUsageError (SQL.StatementSessionError _ _ _ _ _ (SQL.ServerStatementError serverError))) = + ServerError.pgErrorStatus authed serverError +pgErrorStatus authed (SQL.SessionUsageError (SQL.ScriptSessionError _ serverError)) = + ServerError.pgErrorStatus authed serverError +pgErrorStatus _ (SQL.SessionUsageError _) = HTTP.status503 + +maybeHeaders :: SQL.UsageError -> Maybe [HTTP.Header] +maybeHeaders (SQL.SessionUsageError (SQL.StatementSessionError _ _ _ _ _ (SQL.ServerStatementError serverError))) = + ServerError.maybeHeaders serverError +maybeHeaders _ = Nothing diff --git a/src/PostgREST/Error/SchemaCacheError.hs b/src/PostgREST/Error/SchemaCacheError.hs new file mode 100644 index 0000000000..f5b9489191 --- /dev/null +++ b/src/PostgREST/Error/SchemaCacheError.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE RecordWildCards #-} +module PostgREST.Error.SchemaCacheError + ( SchemaCacheError (..), + ) where + +import qualified Data.Aeson as JSON +import qualified Data.FuzzySet as Fuzzy +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import qualified Network.HTTP.Types.Status as HTTP + +import PostgREST.MediaType (MediaType (..)) +import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..), + Schema) +import PostgREST.SchemaCache.Relationship (Cardinality (..), + Junction (..), + Relationship (..), + RelationshipsMap) +import PostgREST.SchemaCache.Routine (Routine (..), + RoutineParam (..)) +import PostgREST.SchemaCache.Table (Table (..)) +import PostgREST.Error.Algebra +import Protolude + +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 [Table] + deriving Show + +instance PgrstError 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 tbls) = JSON.String <$> tableNotFoundHint schemaName relName tbls + + hint _ = Nothing + +instance JSON.ToJSON SchemaCacheError where + toJSON err = toJsonPgrstError + (code err) (message err) (details err) (hint err) + +-- | +-- Do a fuzzy search in all tables in the same schema and return closest result +tableNotFoundHint :: Text -> Text -> [Table] -> Maybe Text +tableNotFoundHint schema tblName tblList + = fmap (\tbl -> "Perhaps you meant the table '" <> schema <> "." <> tbl <> "'") perhapsTable + where + perhapsTable = Fuzzy.getOne fuzzyTableSet tblName + fuzzyTableSet = Fuzzy.fromList [ tableName tbl | tbl <- tblList, tableSchema tbl == schema] + +-- | +-- 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 [] +-- Just "Perhaps you meant to call the function api.another" +-- +-- >>> 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 = Fuzzy.getOne fuzzySetOfProcs procName + | otherwise = (procName <>) <$> Fuzzy.getOne fuzzySetOfParams (listToText params) + +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 + +-- | +-- 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" "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] + +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" JSON..= (qiName relTable <> " with " <> qiName relForeignTable :: Text)) + : case relCardinality of + M2M Junction{..} -> [ + "cardinality" JSON..= ("many-to-many" :: Text) + , "relationship" JSON..= (qiName junTable <> " using " <> junConstraint1 <> fmtEls (snd <$> junColsSource) <> " and " <> junConstraint2 <> fmtEls (snd <$> junColsTarget)) + ] + M2O cons relColumns -> [ + "cardinality" JSON..= ("many-to-one" :: Text) + , "relationship" JSON..= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns)) + ] + O2O cons relColumns _ -> [ + "cardinality" JSON..= ("one-to-one" :: Text) + , "relationship" JSON..= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns)) + ] + O2M cons relColumns -> [ + "cardinality" JSON..= ("one-to-many" :: Text) + , "relationship" JSON..= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns)) + ] diff --git a/src/PostgREST/Listener.hs b/src/PostgREST/Listener.hs index 0c5c42d4eb..b24429a537 100644 --- a/src/PostgREST/Listener.hs +++ b/src/PostgREST/Listener.hs @@ -3,17 +3,17 @@ module PostgREST.Listener (runListener) where -import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Char8 as BS +import qualified Hasql.Connection as SQL +import qualified Hasql.Connection.Settings as SQL +import qualified Hasql.Notifications as SQL -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 PostgREST.Version (prettyVersion) import qualified PostgREST.AppState as AppState -import qualified PostgREST.Config as Config +import qualified PostgREST.Version as Version import Protolude @@ -46,7 +46,13 @@ retryingListen appState = do -- forkFinally allows to detect if the thread dies void . flip forkFinally handleFinally $ do - dbOrError <- SQL.acquire $ toUtf8 (Config.addTargetSessionAttrs $ Config.addFallbackAppName prettyVersion configDbUri) + dbOrError <- SQL.acquire $ mconcat $ + [ SQL.connectionString configDbUri, + SQL.noPreparedStatements (not configDbPreparedStatements), + SQL.other + "fallback_application_name" + ("PostgREST " <> Version.prettyVersionText) + ] case dbOrError of Right db -> do SQL.listen db $ SQL.toPgIdentifier dbChannel diff --git a/src/PostgREST/Logger.hs b/src/PostgREST/Logger.hs index 8f61509852..504da36918 100644 --- a/src/PostgREST/Logger.hs +++ b/src/PostgREST/Logger.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-unused-binds -Wno-unused-imports -Wno-name-shadowing -Wno-incomplete-patterns -Wno-unused-matches -Wno-missing-methods -Wno-unused-record-wildcards -Wno-redundant-constraints -Wno-deprecations #-} {-# LANGUAGE RecordWildCards #-} {-| Module : PostgREST.Logger @@ -126,17 +127,7 @@ logWithZTime loggerState txt = do logMainQ :: LoggerState -> MainQuery -> IO () logMainQ loggerState MainQuery{mqOpenAPI=(x, y, z),..} = - let snipts = renderSnippet <$> [mqTxVars, fromMaybe mempty mqPreReq, mqMain, x, y, z, fromMaybe mempty mqExplain] + let snipts = SQL.toTemplate <$> [mqTxVars, fromMaybe mempty mqPreReq, mqMain, x, y, z, fromMaybe mempty mqExplain] -- Does not log SQL when it's empty (happens on OPTIONS requests and when the openapi queries are not generated) - logQ q = when (q /= mempty) $ logWithZTime loggerState $ showOnSingleLine '\n' $ T.decodeUtf8 q in + logQ q = when (q /= mempty) $ logWithZTime loggerState $ showOnSingleLine '\n' q in mapM_ logQ snipts - --- 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 prepared - decoder = HD.noResult -- unused - prepared = False -- unused - in - sql diff --git a/src/PostgREST/MainTx.hs b/src/PostgREST/MainTx.hs index 6a072e7360..e8bf5732c2 100644 --- a/src/PostgREST/MainTx.hs +++ b/src/PostgREST/MainTx.hs @@ -95,18 +95,15 @@ data ResultSet 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 isoLvl txMode dbHandler transaction +mainTx genQ@MainQuery{..} conf AuthResult{..} apiReq (Db plan) sCache = + DbTx isoLvl txMode dbHandler SQL.transaction where - transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction isoLvl = planIsoLvl conf authRole plan txMode = planTxMode plan dbHandler = do - lift $ SQL.statement mempty $ SQL.dynamicallyParameterized mqTxVars - HD.noResult configDbPreparedStatements + lift $ SQL.statement mempty $ SQL.dynamicallyParameterized mqTxVars HD.noResult True lift $ whenJust mqPreReq $ \q -> - SQL.statement mempty $ SQL.dynamicallyParameterized q - HD.noResult configDbPreparedStatements + SQL.statement mempty $ SQL.dynamicallyParameterized q HD.noResult True actionResult genQ plan conf apiReq sCache planTxMode :: DbActionPlan -> SQL.Mode @@ -121,8 +118,8 @@ planIsoLvl AppConfig{configRoleIsoLvl} role actPlan = case actPlan of 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 +actionResult MainQuery{..} (DbCrud True plan) conf apiReq _ = do + explRes <- lift $ SQL.statement mempty $ SQL.dynamicallyParameterized mqMain planRow True optionalRollback conf apiReq pure $ DbPlanResult (pMedia plan) explRes @@ -131,7 +128,7 @@ actionResult MainQuery{..} (DbCrud _ plan@WrappedReadPlan{..}) conf@AppConfig{.. failNotSingular pMedia resultSet optionalRollback conf apiReq explainTotal <- lift . fmap join $ traverse (\snip -> - SQL.statement mempty $ SQL.dynamicallyParameterized snip decodeExplain configDbPreparedStatements) + SQL.statement mempty $ SQL.dynamicallyParameterized snip decodeExplain True) mqExplain pure $ DbCrudResult plan @@ -142,20 +139,20 @@ actionResult MainQuery{..} (DbCrud _ plan@WrappedReadPlan{..}) conf@AppConfig{.. else tableTotal _ -> tableTotal} where - dynStmt decod = SQL.dynamicallyParameterized mqMain decod configDbPreparedStatements + dynStmt decod = SQL.dynamicallyParameterized mqMain decod True 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 +actionResult MainQuery{..} (DbCrud _ plan@MutateReadPlan{..}) conf 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 + dynStmt decod = SQL.dynamicallyParameterized mqMain decod True failMutation resultSet = case mrMutation of MutationCreate -> do failNotSingular pMedia resultSet @@ -169,14 +166,14 @@ actionResult MainQuery{..} (DbCrud _ plan@MutateReadPlan{..}) conf@AppConfig{..} 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 +actionResult MainQuery{..} (DbCrud _ plan@CallReadPlan{..}) conf 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 + dynStmt decod = SQL.dynamicallyParameterized mqMain decod True 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 = @@ -185,14 +182,14 @@ actionResult MainQuery{mqOpenAPI=(tblsQ, funcsQ, schQ)} (MayUseDb plan@InspectPl 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 + tableAccess <- SQL.statement mempty $ SQL.dynamicallyParameterized tblsQ decodeAccessibleIdentifiers True + accFuncs <- SQL.statement mempty $ SQL.dynamicallyParameterized funcsQ SchemaCache.decodeFuncs True + schDesc <- SQL.statement mempty $ SQL.dynamicallyParameterized schQ decodeSchemaDesc True 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) + schDesc <- SQL.statement mempty (SQL.dynamicallyParameterized schQ decodeSchemaDesc True) let tbls = HM.filterWithKey (\(QualifiedIdentifier sch _) _ -> sch == tSchema) (SchemaCache.dbTables sCache) routs = HM.filterWithKey (\(QualifiedIdentifier sch _) _ -> sch == tSchema) (SchemaCache.dbRoutines sCache) diff --git a/src/PostgREST/Metrics.hs b/src/PostgREST/Metrics.hs index 7a39557751..87553cc8cc 100644 --- a/src/PostgREST/Metrics.hs +++ b/src/PostgREST/Metrics.hs @@ -53,9 +53,9 @@ observationMetrics MetricsState{..} obs = case obs of (PoolAcqTimeoutObs _) -> do incCounter poolTimeouts (HasqlPoolObs (SQL.ConnectionObservation _ status)) -> case status of - SQL.ReadyForUseConnectionStatus -> do + SQL.ReadyForUseConnectionStatus _ -> do incGauge poolAvailable - SQL.InUseConnectionStatus -> do + SQL.InUseConnectionStatus -> do decGauge poolAvailable SQL.TerminatedConnectionStatus _ -> do decGauge poolAvailable diff --git a/src/PostgREST/Observation.hs b/src/PostgREST/Observation.hs index 42a16c77a7..76fcd86473 100644 --- a/src/PostgREST/Observation.hs +++ b/src/PostgREST/Observation.hs @@ -18,7 +18,7 @@ import qualified Data.ByteString.Lazy as LBS import Data.List.NonEmpty (toList) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Hasql.Connection as SQL +import qualified Hasql.Errors as SQL import qualified Hasql.Pool as SQL import qualified Hasql.Pool.Observation as SQL import Network.HTTP.Types.Status (Status) @@ -137,10 +137,11 @@ observationMessage = \case HasqlPoolObs (SQL.ConnectionObservation uuid status) -> "Connection " <> show uuid <> ( case status of - SQL.ConnectingConnectionStatus -> " is being established" - SQL.ReadyForUseConnectionStatus -> " is available" - SQL.InUseConnectionStatus -> " is used" + SQL.ConnectingConnectionStatus -> " is being established" + SQL.ReadyForUseConnectionStatus _ -> " is available" + SQL.InUseConnectionStatus -> " is used" SQL.TerminatedConnectionStatus reason -> " is terminated due to " <> case reason of + SQL.InitializationErrorTerminationReason _ -> "initialization error" SQL.AgingConnectionTerminationReason -> "max lifetime" SQL.IdlenessConnectionTerminationReason -> "max idletime" SQL.ReleaseConnectionTerminationReason -> "release" @@ -162,7 +163,7 @@ observationMessage = \case showListenerConnError :: SQL.ConnectionError -> Text - showListenerConnError = maybe "Connection error" (showOnSingleLine '\t' . T.decodeUtf8) + showListenerConnError = showOnSingleLine '\t' . SQL.toErrorMessage showListenerException :: Either SomeException () -> Text showListenerException (Right _) = "Failed getting notifications" -- should not happen as the listener will never finish (hasql-notifications uses `forever` internally) with a Right result diff --git a/src/PostgREST/Query/QueryBuilder.hs b/src/PostgREST/Query/QueryBuilder.hs index d69a3709bd..cf291d29ba 100644 --- a/src/PostgREST/Query/QueryBuilder.hs +++ b/src/PostgREST/Query/QueryBuilder.hs @@ -18,9 +18,9 @@ module PostgREST.Query.QueryBuilder ) 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 Data.Text as T import qualified Hasql.DynamicStatements.Snippet as SQL import qualified Hasql.Encoders as HE @@ -177,7 +177,7 @@ callPlanToQuery (FunctionCall qi params arguments returnsScalar returnsSetOfScal DirectArgs args -> Just $ JSON.encode args JsonArgs json -> json fromCall = case params of - OnePosParam prm -> "FROM " <> callIt (singleParameter jsonArgs $ encodeUtf8 $ ppType prm) + OnePosParam prm -> "FROM " <> callIt (singleParameter jsonArgs $ ppType prm) KeyParams [] -> "FROM " <> callIt mempty KeyParams prms -> case arguments of DirectArgs args -> "FROM " <> callIt (fmtArgs prms args) @@ -201,7 +201,7 @@ callPlanToQuery (FunctionCall qi params arguments returnsScalar returnsSetOfScal " := " <> encodeArg (HM.lookup ppName args) <> "::" <> - SQL.sql (encodeUtf8 ppTypeMaxLength) + SQL.sql 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 @@ -262,7 +262,7 @@ readPlanToCountQuery (Node ReadPlan{from=mainQi, fromAlias=tblAlias, where_=logi 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) +limitedQuery query maxRows = query <> SQL.sql (maybe mempty (\x -> " LIMIT " <> T.pack (show x)) maxRows) -- TODO refactor so this function is uneeded and ComputedRelationship QualifiedIdentifier comes from the ReadPlan type getQualifiedIdentifier :: Maybe Relationship -> QualifiedIdentifier -> Maybe Alias -> QualifiedIdentifier diff --git a/src/PostgREST/Query/SqlFragment.hs b/src/PostgREST/Query/SqlFragment.hs index 461d4e8274..27ca85ebe9 100644 --- a/src/PostgREST/Query/SqlFragment.hs +++ b/src/PostgREST/Query/SqlFragment.hs @@ -140,7 +140,7 @@ ftsOperator = \case FilterFtsPhrase -> "@@ phraseto_tsquery" FilterFtsWebsearch -> "@@ websearch_to_tsquery" -singleParameter :: Maybe LBS.ByteString -> ByteString -> SQL.Snippet +singleParameter :: Maybe LBS.ByteString -> Text -> SQL.Snippet singleParameter body typ = if typ == "bytea" -- TODO: Hasql fails when using HE.unknown with bytea(pg tries to utf8 encode). @@ -162,7 +162,7 @@ pgBuildArrayLiteral 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 +pgFmtIdent x = SQL.sql $ 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 @@ -228,7 +228,7 @@ 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|( +locationF pKeys = SQL.sql $ [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 @@ -248,7 +248,7 @@ 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 <> ")" +pgFmtCallUnary f x = SQL.sql f <> "(" <> x <> ")" pgFmtField :: QualifiedIdentifier -> CoercibleField -> SQL.Snippet pgFmtField table cf = case cfToTsVector cf of @@ -286,7 +286,7 @@ pgFmtApplyAggregate (Just agg) aggCast snippet = where convertAggFunction :: AggregateFunction -> SQL.Snippet -- Convert from e.g. Sum (the data type) to SUM - convertAggFunction = SQL.sql . BS.map toUpper . BS.pack . show + convertAggFunction = SQL.sql . T.toUpper . T.pack . show aggregatedSnippet = convertAggFunction agg <> "(" <> snippet <> ")" pgFmtSpreadJoinSelectItem :: Alias -> [CoercibleOrderTerm] -> SpreadSelectField -> SQL.Snippet @@ -302,7 +302,7 @@ 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) <> " )" +pgFmtApplyCast (Just cast) snippet = "CAST( " <> snippet <> " AS " <> SQL.sql cast <> " )" pgFmtFullSelName :: Alias -> FieldName -> SQL.Snippet pgFmtFullSelName aggAlias fieldName = case fieldName of @@ -324,7 +324,7 @@ fromJsonBodyF body fields includeSelect includeLimitOne includeDefaults = namedCols = intercalateSnippet ", " $ fromQi . QualifiedIdentifier "pgrst_body" . cfName <$> fields parsedCols = intercalateSnippet ", " $ pgFmtCoerceNamed <$> fields - typedCols = intercalateSnippet ", " $ pgFmtIdent . cfName <> const " " <> SQL.sql . encodeUtf8 . cfIRType <$> fields + typedCols = intercalateSnippet ", " $ pgFmtIdent . cfName <> const " " <> SQL.sql . cfIRType <$> fields lateralFieldsSource = if null fields then emptyFieldsSource else nonEmptyFieldsSource where @@ -335,10 +335,10 @@ fromJsonBodyF body fields includeSelect includeLimitOne includeDefaults = 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 <> ")" + defsJsonb = SQL.sql $ "jsonb_build_object(" <> T.intercalate "," fieldsWDefaults <> ")" fieldsWDefaults = mapMaybe extractFieldDefault fields where - extractFieldDefault CoercibleField{cfName=nam, cfDefault=Just def} = Just $ encodeUtf8 (pgFmtLit nam <> ", " <> def) + extractFieldDefault CoercibleField{cfName=nam, cfDefault=Just def} = Just (pgFmtLit nam <> ", " <> def) extractFieldDefault CoercibleField{cfDefault=Nothing} = Nothing (finalBodyF, jsonArrayElementsF, jsonToRecordsetF) = @@ -355,7 +355,7 @@ fromJsonBodyF body fields includeSelect includeLimitOne includeDefaults = pgFmtOrderTerm :: QualifiedIdentifier -> CoercibleOrderTerm -> SQL.Snippet pgFmtOrderTerm qi ot = fmtOTerm ot <> " " <> - SQL.sql (BS.unwords [ + SQL.sql (T.unwords [ maybe mempty direction $ coDirection ot, maybe mempty nullOrder $ coNullOrder ot]) where @@ -535,17 +535,17 @@ unknownEncoder = SQL.encoderAndParam (HE.nonNullable HE.unknown) unknownLiteral :: Text -> SQL.Snippet unknownLiteral = unknownEncoder . encodeUtf8 -intercalateSnippet :: ByteString -> [SQL.Snippet] -> SQL.Snippet +intercalateSnippet :: Text -> [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))) <> + SQL.sql (T.intercalate ", " (fmtPlanFmt fmt : (fmtPlanOpt <$> opts))) <> ") " <> snip where - fmtPlanOpt :: MTVndPlanOption -> BS.ByteString + fmtPlanOpt :: MTVndPlanOption -> T.Text fmtPlanOpt PlanAnalyze = "ANALYZE" fmtPlanOpt PlanVerbose = "VERBOSE" fmtPlanOpt PlanSettings = "SETTINGS" @@ -596,14 +596,14 @@ schemaDescription schema = encoded = SQL.encoderAndParam (HE.nonNullable HE.unknown) $ encodeUtf8 schema accessibleTables :: Text -> SQL.Snippet -accessibleTables schema = SQL.sql (encodeUtf8 [trimming| +accessibleTables schema = SQL.sql ([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 c.relnamespace = |]) <> encodedSchema <> "::regnamespace " <> SQL.sql ([trimming| AND ( pg_has_role(c.relowner, 'USAGE') or has_table_privilege(c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER') @@ -620,7 +620,7 @@ accessibleFuncs schema = baseFuncSqlQuery <> "AND p.pronamespace = " <> encodedS encodedSchema = SQL.encoderAndParam (HE.nonNullable HE.text) schema baseFuncSqlQuery :: SQL.Snippet -baseFuncSqlQuery = SQL.sql $ encodeUtf8 [trimming| +baseFuncSqlQuery = SQL.sql $ [trimming| WITH base_types AS ( WITH RECURSIVE diff --git a/src/PostgREST/SchemaCache.hs b/src/PostgREST/SchemaCache.hs index 528d7905f4..97ae7b20b8 100644 --- a/src/PostgREST/SchemaCache.hs +++ b/src/PostgREST/SchemaCache.hs @@ -136,22 +136,22 @@ data KeyDep deriving (Eq, Generic, Hashable) -- | A SQL query that can be executed independently -type SqlQuery = ByteString +type SqlQuery = Text querySchemaCache :: AppConfig -> SQL.Transaction SchemaCache querySchemaCache conf@AppConfig{..} = do SQL.sql "set local schema ''" -- This voids the search path. The following queries need this for getting the fully qualified name(schema.name) of every db object - tabs <- SQL.statement conf $ allTables prepared - keyDeps <- SQL.statement conf $ allViewsKeyDependencies prepared - m2oRels <- SQL.statement mempty $ allM2OandO2ORels prepared - funcs <- SQL.statement conf $ allFunctions prepared - cRels <- SQL.statement mempty $ allComputedRels prepared - reps <- SQL.statement conf $ dataRepresentations prepared - mHdlers <- SQL.statement conf $ mediaHandlers prepared - tzones <- SQL.statement mempty $ timezones prepared + tabs <- SQL.statement conf allTables + keyDeps <- SQL.statement conf allViewsKeyDependencies + m2oRels <- SQL.statement mempty allM2OandO2ORels + funcs <- SQL.statement conf allFunctions + cRels <- SQL.statement mempty allComputedRels + reps <- SQL.statement conf dataRepresentations + mHdlers <- SQL.statement conf mediaHandlers + tzones <- SQL.statement mempty timezones _ <- - let sleepCall = SQL.Statement "select pg_sleep($1 / 1000.0)" (param HE.int4) HD.noResult prepared in + let sleepCall = SQL.preparable "select pg_sleep($1 / 1000.0)" (param HE.int4) HD.noResult in for_ configInternalSCQuerySleep (`SQL.statement` sleepCall) -- only used for testing let tabsWViewsPks = addViewPrimaryKeys tabs keyDeps @@ -169,7 +169,6 @@ querySchemaCache conf@AppConfig{..} = do } where schemas = toList configDbSchemas - prepared = configDbPreparedStatements delayEval confDelay result = maybe result (unsafePerformIO . (($> result) . (threadDelay . (1000 *) . fromIntegral))) confDelay -- | overrides detected relationships with the computed relationships and gets the RelationshipsMap @@ -223,7 +222,7 @@ decodeTables = <*> column HD.bool <*> column HD.bool <*> arrayColumn HD.text - <*> parseCols (compositeArrayColumn + <*> parseCols (recordArrayColumn (Column <$> compositeField HD.text <*> nullableCompositeField HD.text @@ -249,7 +248,7 @@ decodeRels = (QualifiedIdentifier <$> column HD.text <*> column HD.text) <*> column HD.bool <*> column HD.text <*> - compositeArrayColumn ((,) <$> compositeField HD.text <*> compositeField HD.text) <*> + recordArrayColumn ((,) <$> compositeField HD.text <*> compositeField HD.text) <*> column HD.bool decodeViewKeyDeps :: HD.Result [ViewKeyDependency] @@ -260,7 +259,7 @@ decodeViewKeyDeps = <$> column HD.text <*> column HD.text <*> column HD.text <*> column HD.text <*> column HD.text <*> column HD.text - <*> compositeArrayColumn + <*> recordArrayColumn ((,) <$> compositeField HD.text <*> compositeFieldArray HD.text) @@ -281,7 +280,7 @@ decodeFuncs = <$> column HD.text <*> column HD.text <*> nullableColumn HD.text - <*> compositeArrayColumn + <*> recordArrayColumn (RoutineParam <$> compositeField HD.text <*> compositeField HD.text @@ -297,7 +296,7 @@ decodeFuncs = <*> (parseVolatility <$> column HD.char) <*> column HD.bool <*> nullableColumn (toIsolationLevel <$> HD.text) - <*> compositeArrayColumn ((,) <$> compositeField HD.text <*> compositeField HD.text) -- function setting + <*> recordArrayColumn ((,) <$> compositeField HD.text <*> compositeField HD.text) -- function setting addKey :: Routine -> (QualifiedIdentifier, Routine) addKey pd = (QualifiedIdentifier (pdSchema pd) (pdName pd), pd) @@ -331,10 +330,10 @@ decodeRepresentations = -- 2. implicit -- For the time being it must also be to/from JSON or text, although one can imagine a future where we support special -- cases like CSV specific representations. -dataRepresentations :: Bool -> SQL.Statement AppConfig RepresentationsMap -dataRepresentations = SQL.Statement sql mempty decodeRepresentations +dataRepresentations :: SQL.Statement AppConfig RepresentationsMap +dataRepresentations = SQL.preparable sql mempty decodeRepresentations where - sql = encodeUtf8 [trimming| + sql = [trimming| SELECT c.castsource::regtype::text, c.casttarget::regtype::text, @@ -353,8 +352,8 @@ dataRepresentations = SQL.Statement sql mempty decodeRepresentations OR (dst_t.typtype = 'd' AND c.castsource IN ('json'::regtype::oid , 'text'::regtype::oid))) |] -allFunctions :: Bool -> SQL.Statement AppConfig RoutineMap -allFunctions = SQL.Statement funcsSqlQuery params decodeFuncs +allFunctions :: SQL.Statement AppConfig RoutineMap +allFunctions = SQL.preparable funcsSqlQuery params decodeFuncs where params = (map escapeIdent . toList . configDbSchemas >$< arrayParam HE.text) <> @@ -391,7 +390,7 @@ baseTypesCte = [trimming| |] funcsSqlQuery :: SqlQuery -funcsSqlQuery = encodeUtf8 [trimming| +funcsSqlQuery = [trimming| WITH $baseTypesCte, arguments AS ( @@ -566,8 +565,8 @@ addViewPrimaryKeys tabs keyDeps = takeFirstPK = mapMaybe (head . snd) indexedDeps = HM.fromListWith (++) $ fmap ((keyDepType &&& keyDepView) &&& pure) keyDeps -allTables :: Bool -> SQL.Statement AppConfig TablesMap -allTables = SQL.Statement tablesSqlQuery params decodeTables +allTables :: SQL.Statement AppConfig TablesMap +allTables = SQL.preparable tablesSqlQuery params decodeTables where params = map escapeIdent . toList . configDbSchemas >$< arrayParam HE.text @@ -579,7 +578,7 @@ tablesSqlQuery = -- (pg_has_role(ss.relowner, 'USAGE'::text) OR has_column_privilege(ss.roid, a.attnum, 'SELECT, INSERT, UPDATE, REFERENCES'::text)); -- on the "columns" CTE, left joining on pg_depend and pg_class is used to obtain the sequence name as a column default in case there are GENERATED .. AS IDENTITY, -- generated columns are only available from pg >= 10 but the query is agnostic to versions. dep.deptype = 'i' is done because there are other 'a' dependencies on PKs - encodeUtf8 [trimming| + [trimming| WITH $baseTypesCte, columns AS ( @@ -714,12 +713,12 @@ tablesSqlQuery = ORDER BY table_schema, table_name|] -- | Gets many-to-one relationships and one-to-one(O2O) relationships, which are a refinement of the many-to-one's -allM2OandO2ORels :: Bool -> SQL.Statement () [Relationship] +allM2OandO2ORels :: SQL.Statement () [Relationship] allM2OandO2ORels = - SQL.Statement sql HE.noParams decodeRels + SQL.preparable sql HE.noParams decodeRels where -- We use jsonb_agg for comparing the uniques/pks instead of array_agg to avoid the ERROR: cannot accumulate arrays of different dimensionality - sql = encodeUtf8 [trimming| + sql = [trimming| WITH pks_uniques_cols AS ( SELECT @@ -758,11 +757,11 @@ allM2OandO2ORels = AND traint.conparentid = 0 ORDER BY traint.conrelid, traint.conname|] -allComputedRels :: Bool -> SQL.Statement () [Relationship] +allComputedRels :: SQL.Statement () [Relationship] allComputedRels = - SQL.Statement sql HE.noParams (HD.rowList cRelRow) + SQL.preparable sql HE.noParams (HD.rowList cRelRow) where - sql = encodeUtf8 [trimming| + sql = [trimming| with all_relations as ( select reltype @@ -804,9 +803,9 @@ allComputedRels = column HD.bool -- | Returns all the views' primary keys and foreign keys dependencies -allViewsKeyDependencies :: Bool -> SQL.Statement AppConfig [ViewKeyDependency] +allViewsKeyDependencies :: SQL.Statement AppConfig [ViewKeyDependency] allViewsKeyDependencies = - SQL.Statement sql params decodeViewKeyDeps + SQL.preparable sql params decodeViewKeyDeps -- query explanation at: -- * rationale: https://gist.github.com/wolfgangwalther/5425d64e7b0d20aad71f6f68474d9f19 -- * json transformation: https://gist.github.com/wolfgangwalther/3a8939da680c24ad767e93ad2c183089 @@ -814,7 +813,7 @@ allViewsKeyDependencies = params = (map escapeIdent . toList . configDbSchemas >$< arrayParam HE.text) <> (map escapeIdent . toList . configDbExtraSearchPath >$< arrayParam HE.text) - sql = encodeUtf8 [trimming| + sql = [trimming| with recursive pks_fks as ( -- pk + fk referencing col @@ -1014,12 +1013,12 @@ initialMediaHandlers = HM.insert (RelAnyElement, MediaType.MTGeoJSON ) (BuiltinOvAggGeoJson, MediaType.MTGeoJSON) HM.empty -mediaHandlers :: Bool -> SQL.Statement AppConfig MediaHandlerMap +mediaHandlers :: SQL.Statement AppConfig MediaHandlerMap mediaHandlers = - SQL.Statement sql params decodeMediaHandlers + SQL.preparable sql params decodeMediaHandlers where params = map escapeIdent . toList . configDbSchemas >$< arrayParam HE.text - sql = encodeUtf8 [trimming| + sql = [trimming| with all_relations as ( select reltype @@ -1090,8 +1089,8 @@ decodeMediaHandlers = <*> (MediaType.decodeMediaType . encodeUtf8 <$> column HD.text) <*> (MediaType.decodeMediaType . encodeUtf8 <$> column HD.text) -timezones :: Bool -> SQL.Statement () TimezoneNames -timezones = SQL.Statement sql HE.noParams decodeTimezones +timezones :: SQL.Statement () TimezoneNames +timezones = SQL.preparable sql HE.noParams decodeTimezones where sql = "SELECT name FROM pg_timezone_names" decodeTimezones :: HD.Result TimezoneNames @@ -1103,8 +1102,8 @@ param = HE.param . HE.nonNullable arrayParam :: HE.Value a -> HE.Params [a] arrayParam = param . HE.foldableArray . HE.nonNullable -compositeArrayColumn :: HD.Composite a -> HD.Row [a] -compositeArrayColumn = arrayColumn . HD.composite +recordArrayColumn :: HD.Composite a -> HD.Row [a] +recordArrayColumn = arrayColumn . HD.record compositeField :: HD.Value a -> HD.Composite a compositeField = HD.field . HD.nonNullable diff --git a/src/PostgREST/Version.hs b/src/PostgREST/Version.hs index c1a9cf549c..c9e62e9109 100644 --- a/src/PostgREST/Version.hs +++ b/src/PostgREST/Version.hs @@ -2,6 +2,7 @@ module PostgREST.Version ( docsVersion , prettyVersion + , prettyVersionText ) where import qualified Data.Text as T @@ -14,8 +15,13 @@ 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 +prettyVersion = encodeUtf8 prettyVersionText + +-- | User friendly version number such as '14.0'. +-- Pre-release versions are tagged as such, e.g., '15 (pre-release)'. +prettyVersionText :: Text +prettyVersionText = + (T.intercalate "." $ take 2 version) <> preRelease where preRelease = if isPreRelease then " (pre-release)" else mempty diff --git a/test/spec/Main.hs b/test/spec/Main.hs index e847926b6f..27023e3b81 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -3,6 +3,7 @@ module Main where import qualified Hasql.Pool as P import qualified Hasql.Pool.Config as P import qualified Hasql.Transaction.Sessions as HT +import qualified Hasql.Connection.Settings as ConnectionSettings import Data.Function (id) @@ -77,10 +78,13 @@ main = do , P.acquisitionTimeout 10 , P.agingTimeout 60 , P.idlenessTimeout 60 - , P.staticConnectionSettings (toUtf8 $ configDbUri testCfg) + , P.staticConnectionSettings $ mconcat $ + [ ConnectionSettings.connectionString $ configDbUri testCfg + , ConnectionSettings.noPreparedStatements (not (configDbPreparedStatements testCfg)) + ] ] - actualPgVersion <- either (panic . show) id <$> P.use pool (queryPgVersion False) + actualPgVersion <- either (panic . show) id <$> P.use pool queryPgVersion -- cached schema cache so most tests run fast baseSchemaCache <- loadSCache pool testCfg