From f99fd6cbad23763e3dad788b7a08d38fe2f659db Mon Sep 17 00:00:00 2001
From: Remo Rechkemmer <59358383+monacoremo@users.noreply.github.com>
Date: Sun, 11 Apr 2021 18:28:01 +0200
Subject: [PATCH] refactor: Split up Types.hs and logically organize modules
(#1793)
---
main/Main.hs | 35 +-
postgrest.cabal | 28 +-
src/PostgREST/App.hs | 66 +-
src/PostgREST/Auth.hs | 9 +-
src/PostgREST/Config.hs | 97 +--
src/PostgREST/Config/JSPath.hs | 59 ++
.../{Private/ProxyUri.hs => Config/Proxy.hs} | 16 +-
src/PostgREST/ContentType.hs | 64 ++
src/PostgREST/DbStructure.hs | 90 ++-
src/PostgREST/DbStructure/Identifiers.hs | 28 +
src/PostgREST/DbStructure/PgVersion.hs | 60 ++
src/PostgREST/DbStructure/Proc.hs | 120 ++++
src/PostgREST/DbStructure/Relation.hs | 76 +++
src/PostgREST/DbStructure/Table.hs | 58 ++
src/PostgREST/Error.hs | 47 +-
src/PostgREST/GucHeader.hs | 37 ++
src/PostgREST/Middleware.hs | 132 ++--
src/PostgREST/OpenAPI.hs | 90 +--
src/PostgREST/{ => Query}/QueryBuilder.hs | 35 +-
.../QueryFragment.hs => Query/SqlFragment.hs} | 116 +++-
src/PostgREST/{ => Query}/Statements.hs | 58 +-
src/PostgREST/{ => Request}/ApiRequest.hs | 74 ++-
.../{ => Request}/DbRequestBuilder.hs | 123 ++--
src/PostgREST/{ => Request}/Parsers.hs | 76 +--
src/PostgREST/Request/Preferences.hs | 54 ++
src/PostgREST/Request/Types.hs | 211 +++++++
src/PostgREST/Types.hs | 580 ------------------
test/Feature/AndOrParamsSpec.hs | 5 +-
test/Feature/AuthSpec.hs | 5 +-
test/Feature/InsertSpec.hs | 6 +-
test/Feature/JsonOperatorSpec.hs | 7 +-
test/Feature/MultipleSchemaSpec.hs | 2 +-
test/Feature/QuerySpec.hs | 6 +-
test/Feature/RpcSpec.hs | 10 +-
test/Main.hs | 12 +-
test/QueryCost.hs | 8 +-
test/SpecHelper.hs | 4 +-
37 files changed, 1496 insertions(+), 1008 deletions(-)
create mode 100644 src/PostgREST/Config/JSPath.hs
rename src/PostgREST/{Private/ProxyUri.hs => Config/Proxy.hs} (90%)
create mode 100644 src/PostgREST/ContentType.hs
create mode 100644 src/PostgREST/DbStructure/Identifiers.hs
create mode 100644 src/PostgREST/DbStructure/PgVersion.hs
create mode 100644 src/PostgREST/DbStructure/Proc.hs
create mode 100644 src/PostgREST/DbStructure/Relation.hs
create mode 100644 src/PostgREST/DbStructure/Table.hs
create mode 100644 src/PostgREST/GucHeader.hs
rename src/PostgREST/{ => Query}/QueryBuilder.hs (91%)
rename src/PostgREST/{Private/QueryFragment.hs => Query/SqlFragment.hs} (79%)
rename src/PostgREST/{ => Query}/Statements.hs (86%)
rename src/PostgREST/{ => Request}/ApiRequest.hs (88%)
rename src/PostgREST/{ => Request}/DbRequestBuilder.hs (79%)
rename src/PostgREST/{ => Request}/Parsers.hs (84%)
create mode 100644 src/PostgREST/Request/Preferences.hs
create mode 100644 src/PostgREST/Request/Types.hs
delete mode 100644 src/PostgREST/Types.hs
diff --git a/main/Main.hs b/main/Main.hs
index 203a3aa3e..9b899915b 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -30,17 +30,18 @@ import System.CPUTime (getCPUTime)
import System.IO (BufferMode (..), hSetBuffering)
import Text.Printf (hPrintf)
-import PostgREST.App (postgrest)
+import PostgREST.App (postgrest)
import PostgREST.Config
-import PostgREST.DbStructure (getDbStructure, getPgVersion)
-import PostgREST.Error (PgError (PgError), checkIsFatal,
- errorPayload)
-import PostgREST.Statements (dbSettingsStatement)
-import PostgREST.Types (ConnectionStatus (..), DbStructure,
- PgVersion (..), SCacheStatus (..),
- minimumPgVersion)
-import Protolude hiding (hPutStrLn, head, toS)
-import Protolude.Conv (toS)
+import PostgREST.DbStructure (DbStructure, getDbStructure,
+ getPgVersion)
+import PostgREST.DbStructure.PgVersion (PgVersion (..),
+ minimumPgVersion)
+import PostgREST.Error (PgError (PgError),
+ checkIsFatal, errorPayload)
+import PostgREST.Query.Statements (dbSettingsStatement)
+
+import Protolude hiding (hPutStrLn, head, toS)
+import Protolude.Conv (toS)
#ifndef mingw32_HOST_OS
@@ -48,6 +49,20 @@ import System.Posix.Signals
import UnixSocket
#endif
+
+-- | Current database connection status data ConnectionStatus
+data ConnectionStatus
+ = NotConnected
+ | Connected PgVersion
+ | FatalConnectionError Text
+ deriving (Eq)
+
+-- | Schema cache status
+data SCacheStatus
+ = SCLoaded
+ | SCOnRetry
+ | SCFatalFail
+
-- | This is where everything starts.
main :: IO ()
main = do
diff --git a/postgrest.cabal b/postgrest.cabal
index 59431f98f..161df14db 100644
--- a/postgrest.cabal
+++ b/postgrest.cabal
@@ -34,24 +34,32 @@ library
default-extensions: OverloadedStrings
NoImplicitPrelude
hs-source-dirs: src
- exposed-modules: PostgREST.ApiRequest
- PostgREST.App
+ exposed-modules: PostgREST.App
PostgREST.Auth
PostgREST.Config
- PostgREST.DbRequestBuilder
+ PostgREST.Config.JSPath
+ PostgREST.Config.Proxy
+ PostgREST.ContentType
PostgREST.DbStructure
+ PostgREST.DbStructure.Identifiers
+ PostgREST.DbStructure.PgVersion
+ PostgREST.DbStructure.Proc
+ PostgREST.DbStructure.Relation
+ PostgREST.DbStructure.Table
PostgREST.Error
+ PostgREST.GucHeader
PostgREST.Middleware
PostgREST.OpenAPI
- PostgREST.Parsers
- PostgREST.QueryBuilder
- PostgREST.Statements
+ PostgREST.Query.QueryBuilder
+ PostgREST.Query.SqlFragment
+ PostgREST.Query.Statements
PostgREST.RangeQuery
- PostgREST.Types
+ PostgREST.Request.ApiRequest
+ PostgREST.Request.DbRequestBuilder
+ PostgREST.Request.Parsers
+ PostgREST.Request.Preferences
+ PostgREST.Request.Types
other-modules: Paths_postgrest
- PostgREST.Private.Common
- PostgREST.Private.ProxyUri
- PostgREST.Private.QueryFragment
build-depends: base >= 4.9 && < 4.15
, HTTP >= 4000.3.7 && < 4000.4
, Ranged-sets >= 0.3 && < 0.5
diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs
index 1ab873bd8..81dd85023 100644
--- a/src/PostgREST/App.hs
+++ b/src/PostgREST/App.hs
@@ -30,23 +30,43 @@ import qualified Network.HTTP.Types.Status as HTTP
import qualified Network.HTTP.Types.URI as HTTP
import qualified Network.Wai as Wai
-import qualified PostgREST.ApiRequest as ApiRequest
-import qualified PostgREST.Auth as Auth
-import qualified PostgREST.DbRequestBuilder as ReqBuilder
-import qualified PostgREST.DbStructure as DbStructure
-import qualified PostgREST.Error as Error
-import qualified PostgREST.Middleware as Middleware
-import qualified PostgREST.OpenAPI as OpenAPI
-import qualified PostgREST.QueryBuilder as QueryBuilder
-import qualified PostgREST.RangeQuery as RangeQuery
-import qualified PostgREST.Statements as Statements
+import qualified PostgREST.Auth as Auth
+import qualified PostgREST.DbStructure as DbStructure
+import qualified PostgREST.Error as Error
+import qualified PostgREST.Middleware as Middleware
+import qualified PostgREST.OpenAPI as OpenAPI
+import qualified PostgREST.Query.QueryBuilder as QueryBuilder
+import qualified PostgREST.Query.Statements as Statements
+import qualified PostgREST.RangeQuery as RangeQuery
+import qualified PostgREST.Request.ApiRequest as ApiRequest
+import qualified PostgREST.Request.DbRequestBuilder as ReqBuilder
-import PostgREST.ApiRequest (Action (..), ApiRequest (..),
- InvokeMethod (..), Target (..))
-import PostgREST.Config (AppConfig (..))
-import PostgREST.Error (Error)
+import PostgREST.Config (AppConfig (..),
+ LogLevel (..))
+import PostgREST.ContentType (ContentType (..))
+import PostgREST.DbStructure (DbStructure (..),
+ tablePKCols)
+import PostgREST.DbStructure.Identifiers (FieldName,
+ QualifiedIdentifier (..),
+ Schema)
+import PostgREST.DbStructure.Proc (ProcDescription (..),
+ ProcVolatility (..))
+import PostgREST.DbStructure.Table (Table (..))
+import PostgREST.Error (Error)
+import PostgREST.GucHeader (GucHeader,
+ addHeadersIfNotIncluded,
+ unwrapGucHeader)
+import PostgREST.Request.ApiRequest (Action (..),
+ ApiRequest (..),
+ InvokeMethod (..),
+ Target (..))
+import PostgREST.Request.Preferences (PreferCount (..),
+ PreferParameters (..),
+ PreferRepresentation (..))
+import PostgREST.Request.Types (ReadRequest, fstFieldNames)
-import PostgREST.Types
+import qualified PostgREST.ContentType as ContentType
+import qualified PostgREST.DbStructure.Proc as Proc
import Protolude hiding (Handler, toS)
import Protolude.Conv (toS)
@@ -123,7 +143,7 @@ postgrestResponse conf@AppConfig{..} maybeDbStructure pool time req = do
Just ct ->
return ct
Nothing ->
- throwError . Error.ContentTypeError $ map toMime iAccepts
+ throwError . Error.ContentTypeError $ map ContentType.toMime iAccepts
let
handleReq apiReq =
@@ -352,9 +372,9 @@ handleInvoke invMethod proc context@RequestContext{..} = do
identifier =
QualifiedIdentifier
(pdSchema proc)
- (fromMaybe (pdName proc) $ procTableName proc)
+ (fromMaybe (pdName proc) $ Proc.procTableName proc)
- returnsSingle (ApiRequest.TargetProc target _) = procReturnsSingle target
+ returnsSingle (ApiRequest.TargetProc target _) = Proc.procReturnsSingle target
returnsSingle _ = False
req <- readRequest identifier context
@@ -367,7 +387,7 @@ handleInvoke invMethod proc context@RequestContext{..} = do
(returnsSingle iTarget)
(QueryBuilder.requestToCallProcQuery
(QualifiedIdentifier (pdSchema proc) (pdName proc))
- (specifiedProcArgs iColumns proc)
+ (Proc.specifiedProcArgs iColumns proc)
iPayload
(returnsScalar iTarget)
iPreferParameters
@@ -405,7 +425,7 @@ handleOpenApi headersOnly tSchema (RequestContext conf@AppConfig{..} dbStructure
return $
Wai.responseLBS HTTP.status200
- (toHeader CTOpenAPI : maybeToList (profileHeader apiRequest))
+ (ContentType.toHeader CTOpenAPI : maybeToList (profileHeader apiRequest))
(if headersOnly then mempty else toS body)
txMode :: ApiRequest -> SQL.Mode
@@ -491,7 +511,7 @@ shouldCount preferCount =
preferCount == Just ExactCount || preferCount == Just EstimatedCount
returnsScalar :: ApiRequest.Target -> Bool
-returnsScalar (TargetProc proc _) = procReturnsScalar proc
+returnsScalar (TargetProc proc _) = Proc.procReturnsScalar proc
returnsScalar _ = False
readRequest :: Monad m => QualifiedIdentifier -> RequestContext -> Handler m ReadRequest
@@ -503,7 +523,7 @@ readRequest QualifiedIdentifier{..} (RequestContext AppConfig{..} dbStructure ap
contentTypeHeaders :: RequestContext -> [HTTP.Header]
contentTypeHeaders RequestContext{..} =
- toHeader ctxContentType : maybeToList (profileHeader ctxApiRequest)
+ ContentType.toHeader ctxContentType : maybeToList (profileHeader ctxApiRequest)
requestContentTypes :: AppConfig -> ApiRequest -> [ContentType]
requestContentTypes conf ApiRequest{..} =
@@ -542,7 +562,7 @@ binaryField RequestContext{..} readReq
rawContentTypes :: AppConfig -> [ContentType]
rawContentTypes AppConfig{..} =
- (decodeContentType <$> configRawMediaTypes) `union` [CTOctetStream, CTTextPlain]
+ (ContentType.decodeContentType <$> configRawMediaTypes) `union` [CTOctetStream, CTTextPlain]
profileHeader :: ApiRequest -> Maybe HTTP.Header
profileHeader ApiRequest{..} =
diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs
index 3d73e622f..7ffac3b8e 100644
--- a/src/PostgREST/Auth.hs
+++ b/src/PostgREST/Auth.hs
@@ -11,7 +11,11 @@ In the test suite there is an example of simple login function that can be used
very simple authentication system inside the PostgreSQL database.
-}
{-# LANGUAGE RecordWildCards #-}
-module PostgREST.Auth (containsRole, jwtClaims, JWTClaims) where
+module PostgREST.Auth
+ ( containsRole
+ , jwtClaims
+ , JWTClaims
+ ) where
import qualified Crypto.JWT as JWT
import qualified Data.Aeson as JSON
@@ -23,9 +27,8 @@ import Control.Monad.Except (liftEither)
import Data.Either.Combinators (mapLeft)
import Data.Time.Clock (UTCTime)
-import PostgREST.Config (AppConfig (..))
+import PostgREST.Config (AppConfig (..), JSPath, JSPathExp (..))
import PostgREST.Error (Error (..))
-import PostgREST.Types (JSPath, JSPathExp (..))
import Protolude
diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs
index e5956905c..e1b09efd3 100644
--- a/src/PostgREST/Config.hs
+++ b/src/PostgREST/Config.hs
@@ -24,9 +24,11 @@ Other hardcoded options such as the minimum version number also belong here.
module PostgREST.Config
( prettyVersion
, docsVersion
+ , LogLevel(..)
, CLI (..)
, Command (..)
, AppConfig (..)
+ , Proxy(..)
, configDbPoolTimeout'
, dumpAppConfig
, Environment
@@ -36,6 +38,10 @@ module PostgREST.Config
, readDbUriFile
, readSecretFile
, parseSecret
+ , JSPath
+ , JSPathExp(..)
+ , isMalformedProxyUri
+ , toURI
) where
import qualified Crypto.JOSE.Types as JOSE
@@ -46,6 +52,9 @@ import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BS
import qualified Data.Configurator as C
import qualified Data.Map.Strict as M
+import qualified Data.Text as T
+
+import qualified GHC.Show (show)
import Control.Lens (preview)
import Control.Monad (fail)
@@ -56,31 +65,25 @@ import Data.List (lookup)
import Data.List.NonEmpty (fromList, toList)
import Data.Maybe (fromJust)
import Data.Scientific (floatingOrInteger)
-import Data.Text (dropEnd, dropWhileEnd, filter,
- intercalate, pack, replace, splitOn,
- strip, stripPrefix, take, toLower,
- toTitle, unpack)
import Data.Version (versionBranch)
import Development.GitRev (gitHash)
import Numeric (readOct, showOct)
+import Options.Applicative (Parser, customExecParser, flag,
+ footer, fullDesc, help, helper, info,
+ infoOption, long, metavar, prefs,
+ progDesc, short, showHelpOnEmpty,
+ showHelpOnError, strArgument)
import Paths_postgrest (version)
import System.Environment (getEnvironment)
import System.Posix.Types (FileMode)
+import Text.Heredoc (str)
-import Control.Applicative
-import Data.Monoid
-import Options.Applicative hiding (str)
-import Text.Heredoc (str)
+import PostgREST.Config.JSPath (JSPath, JSPathExp (..), pRoleClaimKey)
+import PostgREST.Config.Proxy (Proxy (..), isMalformedProxyUri,
+ toURI)
-import PostgREST.Parsers (pRoleClaimKey)
-import PostgREST.Private.ProxyUri (isMalformedProxyUri)
-import PostgREST.Types (JSPath, JSPathExp (..),
- LogLevel (..))
-import Protolude hiding (concat, filter, hPutStrLn,
- intercalate, null, replace, take,
- toList, toLower, toS, toTitle,
- (<>))
-import Protolude.Conv (toS)
+import Protolude hiding (Proxy, toList, toS)
+import Protolude.Conv (toS)
-- | Command line interface options
data CLI = CLI
@@ -128,19 +131,27 @@ configDbPoolTimeout' :: (Fractional a) => AppConfig -> a
configDbPoolTimeout' =
fromRational . toRational . configDbPoolTimeout
+data LogLevel = LogCrit | LogError | LogWarn | LogInfo
+
+instance Show LogLevel where
+ show LogCrit = "crit"
+ show LogError = "error"
+ show LogWarn = "warn"
+ show LogInfo = "info"
+
-- | User friendly version number
prettyVersion :: Text
prettyVersion =
- intercalate "." (map show $ versionBranch version) <> gitRev
+ T.intercalate "." (map show $ versionBranch version) <> gitRev
where
gitRev =
if $(gitHash) == "UNKNOWN"
then mempty
- else " (" <> take 7 $(gitHash) <> ")"
+ else " (" <> T.take 7 $(gitHash) <> ")"
-- | Version number used in docs
docsVersion :: Text
-docsVersion = "v" <> dropEnd 1 (dropWhileEnd (/= '.') prettyVersion)
+docsVersion = "v" <> T.dropEnd 1 (T.dropWhileEnd (/= '.') prettyVersion)
-- | Read command line interface options. Also prints help.
readCLIShowHelp :: Environment -> IO CLI
@@ -280,36 +291,36 @@ dumpAppConfig conf =
pgrstSettings = (\(k, v) -> (k, v conf)) <$>
[("db-anon-role", q . configDbAnonRole)
,("db-channel", q . configDbChannel)
- ,("db-channel-enabled", toLower . show . configDbChannelEnabled)
- ,("db-extra-search-path", q . intercalate "," . configDbExtraSearchPath)
+ ,("db-channel-enabled", T.toLower . show . configDbChannelEnabled)
+ ,("db-extra-search-path", q . T.intercalate "," . configDbExtraSearchPath)
,("db-max-rows", maybe "\"\"" show . configDbMaxRows)
,("db-pool", show . configDbPoolSize)
,("db-pool-timeout", show . configDbPoolTimeout)
,("db-pre-request", q . fromMaybe mempty . configDbPreRequest)
- ,("db-prepared-statements", toLower . show . configDbPreparedStatements)
+ ,("db-prepared-statements", T.toLower . show . configDbPreparedStatements)
,("db-root-spec", q . fromMaybe mempty . configDbRootSpec)
- ,("db-schemas", q . intercalate "," . toList . configDbSchemas)
- ,("db-config", q . toLower . show . configDbConfig)
+ ,("db-schemas", q . T.intercalate "," . toList . configDbSchemas)
+ ,("db-config", q . T.toLower . show . configDbConfig)
,("db-tx-end", q . showTxEnd)
,("db-uri", q . configDbUri)
,("jwt-aud", toS . encode . maybe "" toJSON . configJwtAudience)
- ,("jwt-role-claim-key", q . intercalate mempty . fmap show . configJwtRoleClaimKey)
+ ,("jwt-role-claim-key", q . T.intercalate mempty . fmap show . configJwtRoleClaimKey)
,("jwt-secret", q . toS . showJwtSecret)
- ,("jwt-secret-is-base64", toLower . show . configJwtSecretIsBase64)
+ ,("jwt-secret-is-base64", T.toLower . show . configJwtSecretIsBase64)
,("log-level", q . show . configLogLevel)
,("openapi-server-proxy-uri", q . fromMaybe mempty . configOpenApiServerProxyUri)
,("raw-media-types", q . toS . B.intercalate "," . configRawMediaTypes)
,("server-host", q . configServerHost)
,("server-port", show . configServerPort)
- ,("server-unix-socket", q . maybe mempty pack . configServerUnixSocket)
- ,("server-unix-socket-mode", q . pack . showSocketMode)
+ ,("server-unix-socket", q . maybe mempty T.pack . configServerUnixSocket)
+ ,("server-unix-socket-mode", q . T.pack . showSocketMode)
]
-- quote all app.settings
appSettings = second q <$> configAppSettings conf
-- quote strings and replace " with \"
- q s = "\"" <> replace "\"" "\\\"" s <> "\""
+ q s = "\"" <> T.replace "\"" "\\\"" s <> "\""
showTxEnd c = case (configDbTxRollbackAll c, configDbTxAllowOverride c) of
( False, False ) -> "commit"
@@ -384,7 +395,7 @@ readAppConfig dbSettings env optPath dbUriFile secretFile = do
<*> (maybe [] (fmap encodeUtf8 . splitOnCommas) <$> optValue "raw-media-types")
<*> (fromMaybe "!4" <$> optString "server-host")
<*> (fromMaybe 3000 <$> optInt "server-port")
- <*> (fmap unpack <$> optString "server-unix-socket")
+ <*> (fmap T.unpack <$> optString "server-unix-socket")
<*> parseSocketFileMode "server-unix-socket-mode"
parseDbUri :: C.Key -> C.Parser C.Config Text
@@ -397,11 +408,11 @@ readAppConfig dbSettings env optPath dbUriFile secretFile = do
let secStr = encodeUtf8 sec
secFile = fromMaybe secStr secretFile
-- replace because the JWT is actually base64url encoded which must be turned into just base64 before decoding.
- replaceUrlChars = replace "_" "/" . replace "-" "+" . replace "." "="
+ replaceUrlChars = T.replace "_" "/" . T.replace "-" "+" . T.replace "." "="
willBeFile = isPrefixOf "@" (toS secStr) && isNothing secretFile
in
if isB64 && not willBeFile -- don't decode in bas64 if the secret will be a file or it will err. The secFile will be filled with the file contents in a later stage.
- then case B64.decode $ encodeUtf8 $ strip $ replaceUrlChars $ decodeUtf8 secFile of
+ then case B64.decode . encodeUtf8 . T.strip . replaceUrlChars $ decodeUtf8 secFile of
Left errMsg -> fail errMsg
Right bs -> pure $ Just bs
else pure $ Just secFile
@@ -411,14 +422,14 @@ readAppConfig dbSettings env optPath dbUriFile secretFile = do
where
addFromEnv f = M.toList $ M.union fromEnv $ M.fromList f
fromEnv = M.mapKeys fromJust $ M.filterWithKey (\k _ -> isJust k) $ M.mapKeys normalize env
- normalize k = ("app.settings." <>) <$> stripPrefix "PGRST_APP_SETTINGS_" (toS k)
+ normalize k = ("app.settings." <>) <$> T.stripPrefix "PGRST_APP_SETTINGS_" (toS k)
parseSocketFileMode :: C.Key -> C.Parser C.Config FileMode
parseSocketFileMode k =
optString k >>= \case
Nothing -> pure 432 -- return default 660 mode if no value was provided
Just fileModeText ->
- case (readOct . unpack) fileModeText of
+ case readOct $ T.unpack fileModeText of
[] ->
fail "Invalid server-unix-socket-mode: not an octal"
(fileMode, _):_ ->
@@ -437,7 +448,7 @@ readAppConfig dbSettings env optPath dbUriFile secretFile = do
parseJwtAudience k =
optString k >>= \case
Nothing -> pure Nothing -- no audience in config file
- Just aud -> case preview stringOrUri (unpack aud) of
+ Just aud -> case preview stringOrUri (T.unpack aud) of
Nothing -> fail "Invalid Jwt audience. Check your configuration."
aud' -> pure aud'
@@ -510,7 +521,7 @@ readAppConfig dbSettings env optPath dbUriFile secretFile = do
dashToUnderscore c = c
envVarName = "PGRST_" <> (toUpper . dashToUnderscore <$> toS key)
reloadableDbSetting =
- let dbSettingName = pack $ dashToUnderscore <$> toS key in
+ let dbSettingName = T.pack $ dashToUnderscore <$> toS key in
if dbSettingName `notElem` [
"server_host", "server_port", "server_unix_socket", "server_unix_socket_mode", "log_level",
"db_anon_role", "db_uri", "db_channel_enabled", "db_channel", "db_pool", "db_pool_timeout", "db_config"]
@@ -530,14 +541,14 @@ readAppConfig dbSettings env optPath dbUriFile secretFile = do
coerceBool (C.Bool b) = Just b
coerceBool (C.String s) =
-- parse all kinds of text: True, true, TRUE, "true", ...
- case readMaybe . toS $ toTitle $ filter isAlpha $ toS s of
+ case readMaybe . toS $ T.toTitle $ T.filter isAlpha $ toS s of
Just b -> Just b
-- numeric instead?
Nothing -> (> 0) <$> (readMaybe $ toS s :: Maybe Integer)
coerceBool _ = Nothing
splitOnCommas :: C.Value -> [Text]
- splitOnCommas (C.String s) = strip <$> splitOn "," s
+ splitOnCommas (C.String s) = T.strip <$> T.splitOn "," s
splitOnCommas _ = []
{-|
@@ -562,13 +573,13 @@ type Environment = M.Map [Char] Text
readEnvironment :: IO Environment
readEnvironment = getEnvironment <&> pgrst
where
- pgrst env = M.filterWithKey (\k _ -> "PGRST_" `isPrefixOf` k) $ M.map pack $ M.fromList env
+ pgrst env = M.filterWithKey (\k _ -> "PGRST_" `isPrefixOf` k) $ M.map T.pack $ M.fromList env
-- | Read the JWT secret from a file if configJwtSecret is actually a filepath(has @ as its prefix).
-- | To check if the JWT secret is provided is in fact a file path, it must be decoded as 'Text' to be processed.
readSecretFile :: Maybe B.ByteString -> IO (Maybe B.ByteString)
readSecretFile mSecret =
- case (stripPrefix "@" . decodeUtf8) =<< mSecret of
+ case (T.stripPrefix "@" . decodeUtf8) =<< mSecret of
Nothing -> return Nothing
Just filename -> Just . chomp <$> BS.readFile (toS filename)
where
@@ -576,6 +587,6 @@ readSecretFile mSecret =
-- | Read database uri from a separate file if `db-uri` is a filepath.
readDbUriFile :: Text -> IO (Maybe Text)
-readDbUriFile dbUri = case stripPrefix "@" dbUri of
+readDbUriFile dbUri = case T.stripPrefix "@" dbUri of
Nothing -> return Nothing
- Just filename -> Just . strip <$> readFile (toS filename)
+ Just filename -> Just . T.strip <$> readFile (toS filename)
diff --git a/src/PostgREST/Config/JSPath.hs b/src/PostgREST/Config/JSPath.hs
new file mode 100644
index 000000000..f5e9c8b2f
--- /dev/null
+++ b/src/PostgREST/Config/JSPath.hs
@@ -0,0 +1,59 @@
+{-|
+Module : PostgREST.Types
+Description : PostgREST common types and functions used by the rest of the modules
+-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module PostgREST.Config.JSPath
+ ( JSPath
+ , JSPathExp(..)
+ , pRoleClaimKey
+ ) where
+
+import qualified Text.ParserCombinators.Parsec as P
+
+import Data.Either.Combinators (mapLeft)
+import Text.ParserCombinators.Parsec (())
+import Text.Read (read)
+
+import qualified GHC.Show (show)
+
+import Protolude hiding (toS)
+import Protolude.Conv (toS)
+
+
+-- | full jspath, e.g. .property[0].attr.detail
+type JSPath = [JSPathExp]
+
+-- | jspath expression, e.g. .property, .property[0] or ."property-dash"
+data JSPathExp
+ = JSPKey Text
+ | JSPIdx Int
+
+instance Show JSPathExp where
+ -- TODO: this needs to be quoted properly for special chars
+ show (JSPKey k) = "." <> show k
+ show (JSPIdx i) = "[" <> show i <> "]"
+
+-- Used for the config value "role-claim-key"
+pRoleClaimKey :: Text -> Either Text JSPath
+pRoleClaimKey selStr =
+ mapLeft show $ P.parse pJSPath ("failed to parse role-claim-key value (" <> toS selStr <> ")") (toS selStr)
+
+pJSPath :: P.Parser JSPath
+pJSPath = toJSPath <$> (period *> pPath `P.sepBy` period <* P.eof)
+ where
+ toJSPath :: [(Text, Maybe Int)] -> JSPath
+ toJSPath = concatMap (\(key, idx) -> JSPKey key : maybeToList (JSPIdx <$> idx))
+ period = P.char '.' "period (.)"
+ pPath :: P.Parser (Text, Maybe Int)
+ pPath = (,) <$> pJSPKey <*> P.optionMaybe pJSPIdx
+
+pJSPKey :: P.Parser Text
+pJSPKey = toS <$> P.many1 (P.alphaNum <|> P.oneOf "_$@") <|> pQuotedValue "attribute name [a..z0..9_$@])"
+
+pJSPIdx :: P.Parser Int
+pJSPIdx = P.char '[' *> (read <$> P.many1 P.digit) <* P.char ']' "array index [0..n]"
+
+pQuotedValue :: P.Parser Text
+pQuotedValue = toS <$> (P.char '"' *> P.many (P.noneOf "\"") <* P.char '"')
diff --git a/src/PostgREST/Private/ProxyUri.hs b/src/PostgREST/Config/Proxy.hs
similarity index 90%
rename from src/PostgREST/Private/ProxyUri.hs
rename to src/PostgREST/Config/Proxy.hs
index 3b33f9906..b3d44792c 100644
--- a/src/PostgREST/Private/ProxyUri.hs
+++ b/src/PostgREST/Config/Proxy.hs
@@ -3,10 +3,11 @@
Module : PostgREST.Private.ProxyUri
Description : Proxy Uri validator
-}
-module PostgREST.Private.ProxyUri (
- isMalformedProxyUri
-, toURI
-) where
+module PostgREST.Config.Proxy
+ ( Proxy(..)
+ , isMalformedProxyUri
+ , toURI
+ ) where
import Data.Maybe (fromJust)
import Data.Text (pack, toLower)
@@ -16,6 +17,13 @@ import Protolude hiding (Proxy, dropWhile, get, intercalate,
toLower, toS, (&))
import Protolude.Conv (toS)
+data Proxy = Proxy
+ { proxyScheme :: Text
+ , proxyHost :: Text
+ , proxyPort :: Integer
+ , proxyPath :: Text
+ }
+
{-|
Test whether a proxy uri is malformed or not.
A valid proxy uri should be an absolute uri without query and user info,
diff --git a/src/PostgREST/ContentType.hs b/src/PostgREST/ContentType.hs
new file mode 100644
index 000000000..7be307e3d
--- /dev/null
+++ b/src/PostgREST/ContentType.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module PostgREST.ContentType
+ ( ContentType(..)
+ , toHeader
+ , toMime
+ , decodeContentType
+ ) where
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Internal as BS (c2w)
+
+import Network.HTTP.Types.Header (Header, hContentType)
+
+import Protolude
+
+-- | Enumeration of currently supported response content types
+data ContentType
+ = CTApplicationJSON
+ | CTSingularJSON
+ | CTTextCSV
+ | CTTextPlain
+ | CTOpenAPI
+ | CTUrlEncoded
+ | CTOctetStream
+ | CTAny
+ | CTOther ByteString
+ deriving (Eq)
+
+-- | Convert from ContentType to a full HTTP Header
+toHeader :: ContentType -> Header
+toHeader ct = (hContentType, toMime ct <> charset)
+ where
+ charset = case ct of
+ CTOctetStream -> mempty
+ CTOther _ -> mempty
+ _ -> "; charset=utf-8"
+
+-- | Convert from ContentType to a ByteString representing the mime type
+toMime :: ContentType -> ByteString
+toMime CTApplicationJSON = "application/json"
+toMime CTTextCSV = "text/csv"
+toMime CTTextPlain = "text/plain"
+toMime CTOpenAPI = "application/openapi+json"
+toMime CTSingularJSON = "application/vnd.pgrst.object+json"
+toMime CTUrlEncoded = "application/x-www-form-urlencoded"
+toMime CTOctetStream = "application/octet-stream"
+toMime CTAny = "*/*"
+toMime (CTOther ct) = ct
+
+-- | Convert from ByteString to ContentType. Warning: discards MIME parameters
+decodeContentType :: BS.ByteString -> ContentType
+decodeContentType ct =
+ case BS.takeWhile (/= BS.c2w ';') ct of
+ "application/json" -> CTApplicationJSON
+ "text/csv" -> CTTextCSV
+ "text/plain" -> CTTextPlain
+ "application/openapi+json" -> CTOpenAPI
+ "application/vnd.pgrst.object+json" -> CTSingularJSON
+ "application/vnd.pgrst.object" -> CTSingularJSON
+ "application/x-www-form-urlencoded" -> CTUrlEncoded
+ "application/octet-stream" -> CTOctetStream
+ "*/*" -> CTAny
+ ct' -> CTOther ct'
diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs
index 1da433c75..62eead3ab 100644
--- a/src/PostgREST/DbStructure.hs
+++ b/src/PostgREST/DbStructure.hs
@@ -8,6 +8,8 @@ The schema cache is necessary for resource embedding, foreign keys are used for
These queries are executed once at startup or when PostgREST is reloaded.
-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
@@ -16,14 +18,18 @@ These queries are executed once at startup or when PostgREST is reloaded.
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
-module PostgREST.DbStructure (
- getDbStructure
-, accessibleTables
-, accessibleProcs
-, schemaDescription
-, getPgVersion
-) where
+module PostgREST.DbStructure
+ ( DbStructure(..)
+ , getDbStructure
+ , accessibleTables
+ , accessibleProcs
+ , schemaDescription
+ , getPgVersion
+ , tableCols
+ , tablePKCols
+ ) where
+import qualified Data.Aeson as JSON
import qualified Data.HashMap.Strict as M
import qualified Data.List as L
import qualified Hasql.Decoders as HD
@@ -35,13 +41,52 @@ import qualified Hasql.Transaction as HT
import Contravariant.Extras (contrazip2)
import Data.Set as S (fromList)
import Data.Text (split)
-import Protolude hiding (toS)
-import Protolude.Conv (toS)
-import Protolude.Unsafe (unsafeHead)
import Text.InterpolatedString.Perl6 (q)
-import PostgREST.Private.Common
-import PostgREST.Types
+import PostgREST.DbStructure.Identifiers (QualifiedIdentifier (..),
+ Schema, TableName)
+import PostgREST.DbStructure.PgVersion (PgVersion (..))
+import PostgREST.DbStructure.Proc (PgArg (..), PgType (..),
+ ProcDescription (..),
+ ProcVolatility (..),
+ ProcsMap, RetType (..))
+import PostgREST.DbStructure.Relation (Cardinality (..),
+ ForeignKey (..), Link (..),
+ PrimaryKey (..),
+ Relation (..))
+import PostgREST.DbStructure.Table (Column (..), Table (..))
+
+import Protolude hiding (toS)
+import Protolude.Conv (toS)
+import Protolude.Unsafe (unsafeHead)
+
+
+data DbStructure = DbStructure
+ { dbTables :: [Table]
+ , dbColumns :: [Column]
+ , dbRelations :: [Relation]
+ , dbPrimaryKeys :: [PrimaryKey]
+ , dbProcs :: ProcsMap
+ , pgVersion :: PgVersion
+ }
+ deriving (Generic, JSON.ToJSON)
+
+-- TODO Table could hold references to all its Columns
+tableCols :: DbStructure -> Schema -> TableName -> [Column]
+tableCols dbs tSchema tName = filter (\Column{colTable=Table{tableSchema=s, tableName=t}} -> s==tSchema && t==tName) $ dbColumns dbs
+
+-- TODO Table could hold references to all its PrimaryKeys
+tablePKCols :: DbStructure -> Schema -> TableName -> [Text]
+tablePKCols dbs tSchema tName = pkName <$> filter (\pk -> tSchema == (tableSchema . pkTable) pk && tName == (tableName . pkTable) pk) (dbPrimaryKeys dbs)
+
+
+
+-- | The source table column a view column refers to
+type SourceColumn = (Column, ViewColumn)
+type ViewColumn = Column
+
+-- | A SQL query that can be executed independently
+type SqlQuery = ByteString
getDbStructure :: [Schema] -> [Schema] -> PgVersion -> Bool -> HT.Transaction DbStructure
getDbStructure schemas extraSearchPath pgVer prepared = do
@@ -839,3 +884,24 @@ getPgVersion = H.statement mempty $ H.Statement sql HE.noParams versionRow False
where
sql = "SELECT current_setting('server_version_num')::integer, current_setting('server_version')"
versionRow = HD.singleRow $ PgVersion <$> column HD.int4 <*> column HD.text
+
+param :: HE.Value a -> HE.Params a
+param = HE.param . HE.nonNullable
+
+arrayParam :: HE.Value a -> HE.Params [a]
+arrayParam = param . HE.foldableArray . HE.nonNullable
+
+compositeArrayColumn :: HD.Composite a -> HD.Row [a]
+compositeArrayColumn = arrayColumn . HD.composite
+
+compositeField :: HD.Value a -> HD.Composite a
+compositeField = HD.field . HD.nonNullable
+
+column :: HD.Value a -> HD.Row a
+column = HD.column . HD.nonNullable
+
+nullableColumn :: HD.Value a -> HD.Row (Maybe a)
+nullableColumn = HD.column . HD.nullable
+
+arrayColumn :: HD.Value a -> HD.Row [a]
+arrayColumn = column . HD.listArray . HD.nonNullable
diff --git a/src/PostgREST/DbStructure/Identifiers.hs b/src/PostgREST/DbStructure/Identifiers.hs
new file mode 100644
index 000000000..f20d7e812
--- /dev/null
+++ b/src/PostgREST/DbStructure/Identifiers.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module PostgREST.DbStructure.Identifiers
+ ( QualifiedIdentifier(..)
+ , Schema
+ , TableName
+ , FieldName
+ ) where
+
+import qualified Data.Aeson as JSON
+
+import Protolude
+
+
+-- | Represents a pg identifier with a prepended schema name "schema.table".
+-- When qiSchema is "", the schema is defined by the pg search_path.
+data QualifiedIdentifier = QualifiedIdentifier
+ { qiSchema :: Schema
+ , qiName :: TableName
+ }
+ deriving (Eq, Ord, Generic, JSON.ToJSON, JSON.ToJSONKey)
+
+instance Hashable QualifiedIdentifier
+
+type Schema = Text
+type TableName = Text
+type FieldName = Text
diff --git a/src/PostgREST/DbStructure/PgVersion.hs b/src/PostgREST/DbStructure/PgVersion.hs
new file mode 100644
index 000000000..20616bba6
--- /dev/null
+++ b/src/PostgREST/DbStructure/PgVersion.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+module PostgREST.DbStructure.PgVersion
+ ( PgVersion(..)
+ , minimumPgVersion
+ , pgVersion95
+ , pgVersion96
+ , pgVersion100
+ , pgVersion109
+ , pgVersion110
+ , pgVersion112
+ , pgVersion114
+ , pgVersion121
+ , pgVersion130
+ ) where
+
+import qualified Data.Aeson as JSON
+
+import Protolude
+
+
+data PgVersion = PgVersion
+ { pgvNum :: Int32
+ , pgvName :: Text
+ }
+ deriving (Eq, Generic, JSON.ToJSON)
+
+instance Ord PgVersion where
+ (PgVersion v1 _) `compare` (PgVersion v2 _) = v1 `compare` v2
+
+-- | Tells the minimum PostgreSQL version required by this version of PostgREST
+minimumPgVersion :: PgVersion
+minimumPgVersion = pgVersion95
+
+pgVersion95 :: PgVersion
+pgVersion95 = PgVersion 90500 "9.5"
+
+pgVersion96 :: PgVersion
+pgVersion96 = PgVersion 90600 "9.6"
+
+pgVersion100 :: PgVersion
+pgVersion100 = PgVersion 100000 "10"
+
+pgVersion109 :: PgVersion
+pgVersion109 = PgVersion 100009 "10.9"
+
+pgVersion110 :: PgVersion
+pgVersion110 = PgVersion 110000 "11.0"
+
+pgVersion112 :: PgVersion
+pgVersion112 = PgVersion 110002 "11.2"
+
+pgVersion114 :: PgVersion
+pgVersion114 = PgVersion 110004 "11.4"
+
+pgVersion121 :: PgVersion
+pgVersion121 = PgVersion 120001 "12.1"
+
+pgVersion130 :: PgVersion
+pgVersion130 = PgVersion 130000 "13.0"
diff --git a/src/PostgREST/DbStructure/Proc.hs b/src/PostgREST/DbStructure/Proc.hs
new file mode 100644
index 000000000..59927b403
--- /dev/null
+++ b/src/PostgREST/DbStructure/Proc.hs
@@ -0,0 +1,120 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module PostgREST.DbStructure.Proc
+ ( PgArg(..)
+ , PgType(..)
+ , ProcDescription(..)
+ , ProcVolatility(..)
+ , ProcsMap
+ , RetType(..)
+ , findProc
+ , procReturnsScalar
+ , procReturnsSingle
+ , procTableName
+ , specifiedProcArgs
+ ) where
+
+import qualified Data.Aeson as JSON
+import qualified Data.HashMap.Strict as M
+import qualified Data.Set as S
+
+import PostgREST.DbStructure.Identifiers (FieldName,
+ QualifiedIdentifier (..),
+ Schema, TableName)
+
+import Protolude
+
+
+data PgArg = PgArg
+ { pgaName :: Text
+ , pgaType :: Text
+ , pgaReq :: Bool
+ , pgaVar :: Bool
+ }
+ deriving (Eq, Ord, Generic, JSON.ToJSON)
+
+data PgType
+ = Scalar
+ | Composite QualifiedIdentifier
+ deriving (Eq, Ord, Generic, JSON.ToJSON)
+
+data RetType
+ = Single PgType
+ | SetOf PgType
+ deriving (Eq, Ord, Generic, JSON.ToJSON)
+
+data ProcVolatility
+ = Volatile
+ | Stable
+ | Immutable
+ deriving (Eq, Ord, Generic, JSON.ToJSON)
+
+data ProcDescription = ProcDescription
+ { pdSchema :: Schema
+ , pdName :: Text
+ , pdDescription :: Maybe Text
+ , pdArgs :: [PgArg]
+ , pdReturnType :: RetType
+ , pdVolatility :: ProcVolatility
+ , pdHasVariadic :: Bool
+ }
+ deriving (Eq, Generic, JSON.ToJSON)
+
+-- Order by least number of args in the case of overloaded functions
+instance Ord ProcDescription where
+ ProcDescription schema1 name1 des1 args1 rt1 vol1 hasVar1 `compare` ProcDescription schema2 name2 des2 args2 rt2 vol2 hasVar2
+ | schema1 == schema2 && name1 == name2 && length args1 < length args2 = LT
+ | schema2 == schema2 && name1 == name2 && length args1 > length args2 = GT
+ | otherwise = (schema1, name1, des1, args1, rt1, vol1, hasVar1) `compare` (schema2, name2, des2, args2, rt2, vol2, hasVar2)
+
+-- | A map of all procs, all of which can be overloaded(one entry will have more than one ProcDescription).
+-- | It uses a HashMap for a faster lookup.
+type ProcsMap = M.HashMap QualifiedIdentifier [ProcDescription]
+
+{-|
+ Search a pg procedure by its parameters. Since a function can be overloaded, the name is not enough to find it.
+ An overloaded function can have a different volatility or even a different return type.
+ Ideally, handling overloaded functions should be left to pg itself. But we need to know certain proc attributes in advance.
+-}
+findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> ProcsMap -> ProcDescription
+findProc qi payloadKeys paramsAsSingleObject allProcs = fromMaybe fallback bestMatch
+ where
+ -- instead of passing Maybe ProcDescription around, we create a fallback description here when we can't find a matching function
+ -- args is empty, but because "specifiedProcArgs" will fill the missing arguments with default type text, this is not a problem
+ fallback = ProcDescription (qiSchema qi) (qiName qi) Nothing mempty (SetOf $ Composite $ QualifiedIdentifier mempty "record") Volatile False
+ bestMatch =
+ case M.lookup qi allProcs of
+ Nothing -> Nothing
+ Just [proc] -> Just proc -- if it's not an overloaded function then immediately get the ProcDescription
+ Just procs -> find matches procs -- Handle overloaded functions case
+ matches proc =
+ if paramsAsSingleObject
+ -- if the arg is not of json type let the db give the err
+ then length (pdArgs proc) == 1
+ else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs proc)
+
+{-|
+ Search the procedure parameters by matching them with the specified keys.
+ If the key doesn't match a parameter, a parameter with a default type "text" is assumed.
+-}
+specifiedProcArgs :: S.Set FieldName -> ProcDescription -> [PgArg]
+specifiedProcArgs keys proc =
+ (\k -> fromMaybe (PgArg k "text" True False) (find ((==) k . pgaName) (pdArgs proc))) <$> S.toList keys
+
+procReturnsScalar :: ProcDescription -> Bool
+procReturnsScalar proc = case proc of
+ ProcDescription{pdReturnType = (Single Scalar)} -> True
+ ProcDescription{pdReturnType = (SetOf Scalar)} -> True
+ _ -> False
+
+procReturnsSingle :: ProcDescription -> Bool
+procReturnsSingle proc = case proc of
+ ProcDescription{pdReturnType = (Single _)} -> True
+ _ -> False
+
+procTableName :: ProcDescription -> Maybe TableName
+procTableName proc = case pdReturnType proc of
+ SetOf (Composite qi) -> Just $ qiName qi
+ Single (Composite qi) -> Just $ qiName qi
+ _ -> Nothing
diff --git a/src/PostgREST/DbStructure/Relation.hs b/src/PostgREST/DbStructure/Relation.hs
new file mode 100644
index 000000000..572572b5f
--- /dev/null
+++ b/src/PostgREST/DbStructure/Relation.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module PostgREST.DbStructure.Relation
+ ( Cardinality(..)
+ , Constraint
+ , ForeignKey(..)
+ , Link(..)
+ , PrimaryKey(..)
+ , Relation(..)
+ , isSelfReference
+ ) where
+
+import qualified Data.Aeson as JSON
+
+import PostgREST.DbStructure.Table (Column (..), ForeignKey (..),
+ Table (..))
+
+import qualified GHC.Show (show)
+
+import Protolude
+
+
+-- | "Relation"ship between two tables.
+--
+-- The order of the relColumns and relFColumns should be maintained to get the
+-- join conditions right.
+--
+-- TODO merge relColumns and relFColumns to a tuple or Data.Bimap
+data Relation = Relation
+ { relTable :: Table
+ , relColumns :: [Column]
+ , relFTable :: Table
+ , relFColumns :: [Column]
+ , relType :: Cardinality
+ , relLink :: Link -- ^ Constraint on O2M/M2O, Junction for M2M Cardinality
+ }
+ deriving (Eq, Generic, JSON.ToJSON)
+
+type ConstraintName = Text
+
+-- | Junction table on an M2M relationship
+data Link
+ = Constraint
+ { constName :: ConstraintName }
+ | Junction
+ { junTable :: Table
+ , junLink1 :: Link
+ , junCols1 :: [Column]
+ , junLink2 :: Link
+ , junCols2 :: [Column]
+ }
+ deriving (Eq, Generic, JSON.ToJSON)
+
+data PrimaryKey = PrimaryKey
+ { pkTable :: Table
+ , pkName :: Text
+ }
+ deriving (Generic, JSON.ToJSON)
+
+-- | The relationship
+-- [cardinality](https://en.wikipedia.org/wiki/Cardinality_(data_modeling)).
+-- TODO: missing one-to-one
+data Cardinality
+ = O2M -- ^ one-to-many, previously known as Parent
+ | M2O -- ^ many-to-one, previously known as Child
+ | M2M -- ^ many-to-many, previously known as Many
+ deriving (Eq, Generic, JSON.ToJSON)
+
+instance Show Cardinality where
+ show O2M = "o2m"
+ show M2O = "m2o"
+ show M2M = "m2m"
+
+isSelfReference :: Relation -> Bool
+isSelfReference r = relTable r == relFTable r
diff --git a/src/PostgREST/DbStructure/Table.hs b/src/PostgREST/DbStructure/Table.hs
new file mode 100644
index 000000000..088ef505d
--- /dev/null
+++ b/src/PostgREST/DbStructure/Table.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module PostgREST.DbStructure.Table
+ ( Column(..)
+ , ForeignKey(..)
+ , Table(..)
+ , tableQi
+ ) where
+
+import qualified Data.Aeson as JSON
+
+import PostgREST.DbStructure.Identifiers (FieldName,
+ QualifiedIdentifier (..),
+ Schema, TableName)
+
+import Protolude
+
+
+data Table = Table
+ { tableSchema :: Schema
+ , tableName :: TableName
+ , tableDescription :: Maybe Text
+ , tableInsertable :: Bool
+ }
+ deriving (Show, Ord, Generic, JSON.ToJSON)
+
+instance Eq Table where
+ Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2
+
+tableQi :: Table -> QualifiedIdentifier
+tableQi Table{tableSchema=s, tableName=n} = QualifiedIdentifier s n
+
+newtype ForeignKey = ForeignKey
+ { fkCol :: Column }
+ deriving (Eq, Ord, Generic, JSON.ToJSON)
+
+data Column = Column
+ { colTable :: Table
+ , colName :: FieldName
+ , colDescription :: Maybe Text
+ , colNullable :: Bool
+ , colType :: Text
+ , colMaxLen :: Maybe Int32
+ , colDefault :: Maybe Text
+ , colEnum :: [Text]
+ , colFK :: Maybe ForeignKey
+ }
+ deriving (Ord, Generic, JSON.ToJSON)
+
+instance Eq Column where
+ Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2
+
+data PrimaryKey = PrimaryKey
+ { pkTable :: Table
+ , pkName :: Text
+ }
+ deriving (Generic, JSON.ToJSON)
diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs
index c5d97fbbe..11ed32c46 100644
--- a/src/PostgREST/Error.hs
+++ b/src/PostgREST/Error.hs
@@ -5,15 +5,15 @@ Description : PostgREST error HTTP responses
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE RecordWildCards #-}
-module PostgREST.Error (
- errorResponseFor
-, ApiRequestError(..)
-, PgError(..)
-, Error(..)
-, errorPayload
-, checkIsFatal
-, singularityError
-) where
+module PostgREST.Error
+ ( errorResponseFor
+ , ApiRequestError(..)
+ , PgError(..)
+ , Error(..)
+ , errorPayload
+ , checkIsFatal
+ , singularityError
+ ) where
import qualified Data.Aeson as JSON
import qualified Data.Text as T
@@ -24,11 +24,16 @@ import qualified Network.HTTP.Types.Status as HT
import Data.Aeson ((.=))
import Network.Wai (Response, responseLBS)
-import Network.HTTP.Types.Header
+import Network.HTTP.Types.Header (Header)
-import PostgREST.Types
-import Protolude hiding (toS)
-import Protolude.Conv (toS, toSL)
+import PostgREST.ContentType (ContentType (..))
+import qualified PostgREST.ContentType as ContentType
+
+import PostgREST.DbStructure.Relation (Link (..), Relation (..))
+import PostgREST.DbStructure.Table (Column (..), Table (..))
+
+import Protolude hiding (toS)
+import Protolude.Conv (toS, toSL)
class (JSON.ToJSON a) => PgrstError a where
@@ -67,7 +72,7 @@ instance PgrstError ApiRequestError where
status AmbiguousRelBetween{} = HT.status300
status (UnacceptableSchema _) = HT.status406
- headers _ = [toHeader CTApplicationJSON]
+ headers _ = [ContentType.toHeader CTApplicationJSON]
instance JSON.ToJSON ApiRequestError where
toJSON (ParseRequestError message details) = JSON.object [
@@ -120,8 +125,8 @@ instance PgrstError PgError where
headers err =
if status err == HT.status401
- then [toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header]
- else [toHeader CTApplicationJSON]
+ then [ContentType.toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header]
+ else [ContentType.toHeader CTApplicationJSON]
instance JSON.ToJSON PgError where
toJSON (PgError _ usageError) = JSON.toJSON usageError
@@ -249,11 +254,11 @@ instance PgrstError Error where
status (PgErr err) = status err
status (ApiRequestError err) = status err
- headers (SingularityError _) = [toHeader CTSingularJSON]
- headers (JwtTokenInvalid m) = [toHeader CTApplicationJSON, invalidTokenHeader m]
+ headers (SingularityError _) = [ContentType.toHeader CTSingularJSON]
+ headers (JwtTokenInvalid m) = [ContentType.toHeader CTApplicationJSON, invalidTokenHeader m]
headers (PgErr err) = headers err
headers (ApiRequestError err) = headers err
- headers _ = [toHeader CTApplicationJSON]
+ headers _ = [ContentType.toHeader CTApplicationJSON]
instance JSON.ToJSON Error where
toJSON GucHeadersError = JSON.object [
@@ -261,7 +266,7 @@ instance JSON.ToJSON Error where
toJSON GucStatusError = JSON.object [
"message" .= ("response.status guc must be a valid status code" :: Text)]
toJSON (BinaryFieldError ct) = JSON.object [
- "message" .= ((toS (toMime ct) <> " requested but more than one column was selected") :: Text)]
+ "message" .= ((toS (ContentType.toMime ct) <> " requested but more than one column was selected") :: Text)]
toJSON ConnectionLostError = JSON.object [
"message" .= ("Database connection lost. Retrying the connection." :: Text)]
@@ -274,7 +279,7 @@ instance JSON.ToJSON Error where
"message" .= ("None of these Content-Types are available: " <> (toS . intercalate ", " . map toS) cts :: Text)]
toJSON (SingularityError n) = JSON.object [
"message" .= ("JSON object requested, multiple (or no) rows returned" :: Text),
- "details" .= T.unwords ["Results contain", show n, "rows,", toS (toMime CTSingularJSON), "requires 1 row"]]
+ "details" .= T.unwords ["Results contain", show n, "rows,", toS (ContentType.toMime CTSingularJSON), "requires 1 row"]]
toJSON JwtTokenMissing = JSON.object [
"message" .= ("Server lacks JWT secret" :: Text)]
diff --git a/src/PostgREST/GucHeader.hs b/src/PostgREST/GucHeader.hs
new file mode 100644
index 000000000..22bcba17f
--- /dev/null
+++ b/src/PostgREST/GucHeader.hs
@@ -0,0 +1,37 @@
+module PostgREST.GucHeader
+ ( GucHeader
+ , unwrapGucHeader
+ , addHeadersIfNotIncluded
+ ) where
+
+import qualified Data.Aeson as JSON
+import qualified Data.CaseInsensitive as CI
+import qualified Data.HashMap.Strict as M
+
+import Network.HTTP.Types.Header (Header)
+
+import Protolude hiding (toS)
+import Protolude.Conv (toS)
+
+
+{-|
+ Custom guc header, it's obtained by parsing the json in a:
+ `SET LOCAL "response.headers" = '[{"Set-Cookie": ".."}]'
+-}
+newtype GucHeader = GucHeader (CI.CI ByteString, ByteString)
+
+instance JSON.FromJSON GucHeader where
+ parseJSON (JSON.Object o) = case headMay (M.toList o) of
+ Just (k, JSON.String s) | M.size o == 1 -> pure $ GucHeader (CI.mk $ toS k, toS s)
+ | otherwise -> mzero
+ _ -> mzero
+ parseJSON _ = mzero
+
+unwrapGucHeader :: GucHeader -> Header
+unwrapGucHeader (GucHeader (k, v)) = (k, v)
+
+-- | Add headers not already included to allow the user to override them instead of duplicating them
+addHeadersIfNotIncluded :: [Header] -> [Header] -> [Header]
+addHeadersIfNotIncluded newHeaders initialHeaders =
+ filter (\(nk, _) -> isNothing $ find (\(ik, _) -> ik == nk) initialHeaders) newHeaders ++
+ initialHeaders
diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs
index 5e6732ba9..a74196233 100644
--- a/src/PostgREST/Middleware.hs
+++ b/src/PostgREST/Middleware.hs
@@ -12,50 +12,49 @@ module PostgREST.Middleware
, optionalRollback
) where
-import qualified Hasql.Decoders as HD
-import qualified Hasql.DynamicStatements.Statement as H
-import PostgREST.Private.Common
+import qualified Data.Aeson as JSON
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.CaseInsensitive as CI
+import qualified Data.HashMap.Strict as M
+import qualified Data.Text as T
+import qualified Hasql.Decoders as HD
+import qualified Hasql.DynamicStatements.Snippet as H hiding
+ (sql)
+import qualified Hasql.DynamicStatements.Statement as H
+import qualified Hasql.Transaction as H
+import qualified Network.HTTP.Types.Header as HTTP
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Logger as Wai
+import qualified Network.Wai.Middleware.Cors as Wai
+import qualified Network.Wai.Middleware.Gzip as Wai
+import qualified Network.Wai.Middleware.RequestLogger as Wai
+import qualified Network.Wai.Middleware.Static as Wai
-import qualified Data.Aeson as JSON
-import qualified Data.ByteString.Char8 as BS
-import qualified Data.CaseInsensitive as CI
-import Data.Function (id)
-import qualified Data.HashMap.Strict as M
-import Data.List (lookup)
-import Data.Scientific (FPFormat (..),
- formatScientific,
- isInteger)
-import qualified Data.Text as T
-import qualified Hasql.Transaction as H
-import qualified Network.HTTP.Types.Header as HTTP
-import Network.HTTP.Types.Status (Status, status400,
- status500, statusCode)
-import qualified Network.Wai as Wai
-import Network.Wai.Logger (showSockAddr)
-import System.Log.FastLogger (toLogStr)
+import Data.Function (id)
+import Data.List (lookup)
+import Data.Scientific (FPFormat (..), formatScientific,
+ isInteger)
+import Network.HTTP.Types.Status (Status, status400, status500,
+ statusCode)
+import System.IO.Unsafe (unsafePerformIO)
+import System.Log.FastLogger (toLogStr)
-import Network.Wai
-import Network.Wai.Middleware.Cors (CorsResourcePolicy (..),
- cors)
-import Network.Wai.Middleware.Gzip (def, gzip)
-import Network.Wai.Middleware.RequestLogger
-import Network.Wai.Middleware.Static (only, staticPolicy)
+import PostgREST.Config (AppConfig (..), LogLevel (..))
+import PostgREST.Error (Error, errorResponseFor)
+import PostgREST.GucHeader (addHeadersIfNotIncluded)
+import PostgREST.Query.SqlFragment (intercalateSnippet,
+ unknownLiteral)
+import PostgREST.Request.ApiRequest (ApiRequest (..))
-import qualified PostgREST.Types as Types
+import PostgREST.Request.Preferences
-import PostgREST.ApiRequest (ApiRequest (..))
-import PostgREST.Config (AppConfig (..))
-import PostgREST.Error (Error, errorResponseFor)
-import PostgREST.QueryBuilder (setConfigLocal)
-import PostgREST.Types (LogLevel (..))
-import Protolude hiding (head, toS)
-import Protolude.Conv (toS)
-import System.IO.Unsafe (unsafePerformIO)
+import Protolude hiding (head, toS)
+import Protolude.Conv (toS)
-- | Runs local(transaction scoped) GUCs for every request, plus the pre-request function
runPgLocals :: AppConfig -> M.HashMap Text JSON.Value ->
- (ApiRequest -> ExceptT Error H.Transaction Response) ->
- ApiRequest -> ExceptT Error H.Transaction Response
+ (ApiRequest -> ExceptT Error H.Transaction Wai.Response) ->
+ ApiRequest -> ExceptT Error H.Transaction Wai.Response
runPgLocals conf claims app req = do
lift $ H.statement mempty $ H.dynamicallyParameterized
("select " <> intercalateSnippet ", " (searchPathSql : roleSql ++ claimsSql ++ [methodSql, pathSql] ++ headersSql ++ cookiesSql ++ appSettingsSql))
@@ -78,11 +77,16 @@ runPgLocals conf claims app req = do
setConfigLocal mempty ("search_path", schemas)
preReqSql = (\f -> "select " <> toS f <> "();") <$> configDbPreRequest conf
+ -- | Do a pg set_config(setting, value, true) call. This is equivalent to a SET LOCAL.
+ setConfigLocal :: Text -> (Text, Text) -> H.Snippet
+ setConfigLocal prefix (k, v) =
+ "set_config(" <> unknownLiteral (prefix <> k) <> ", " <> unknownLiteral v <> ", true)"
+
-- | Log in apache format. Only requests that have a status greater than minStatus are logged.
-- | There's no way to filter logs in the apache format on wai-extra: https://hackage.haskell.org/package/wai-extra-3.0.29.2/docs/Network-Wai-Middleware-RequestLogger.html#t:OutputFormat.
-- | So here we copy wai-logger apacheLogStr function: https://github.com/kazu-yamamoto/logger/blob/a4f51b909a099c51af7a3f75cf16e19a06f9e257/wai-logger/Network/Wai/Logger/Apache.hs#L45
-- | TODO: Add the ability to filter apache logs on wai-extra and remove this function.
-pgrstFormat :: Status -> OutputFormatter
+pgrstFormat :: Status -> Wai.OutputFormatter
pgrstFormat minStatus date req status responseSize =
if status < minStatus
then mempty
@@ -90,55 +94,55 @@ pgrstFormat minStatus date req status responseSize =
<> " - - ["
<> toLogStr date
<> "] \""
- <> toLogStr (requestMethod req)
+ <> toLogStr (Wai.requestMethod req)
<> " "
- <> toLogStr (rawPathInfo req <> rawQueryString req)
+ <> toLogStr (Wai.rawPathInfo req <> Wai.rawQueryString req)
<> " "
- <> toLogStr (show (httpVersion req)::Text)
+ <> toLogStr (show (Wai.httpVersion req)::Text)
<> "\" "
<> toLogStr (show (statusCode status)::Text)
<> " "
<> toLogStr (maybe "-" show responseSize::Text)
<> " \""
- <> toLogStr (fromMaybe mempty $ requestHeaderReferer req)
+ <> toLogStr (fromMaybe mempty $ Wai.requestHeaderReferer req)
<> "\" \""
- <> toLogStr (fromMaybe mempty $ requestHeaderUserAgent req)
+ <> toLogStr (fromMaybe mempty $ Wai.requestHeaderUserAgent req)
<> "\"\n"
where
- getSourceFromSocket = BS.pack . showSockAddr . remoteHost
+ getSourceFromSocket = BS.pack . Wai.showSockAddr . Wai.remoteHost
-pgrstMiddleware :: LogLevel -> Application -> Application
+pgrstMiddleware :: LogLevel -> Wai.Application -> Wai.Application
pgrstMiddleware logLevel =
logger
- . gzip def
- . cors corsPolicy
- . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
+ . Wai.gzip Wai.def
+ . Wai.cors corsPolicy
+ . Wai.staticPolicy (Wai.only [("favicon.ico", "static/favicon.ico")])
where
logger = case logLevel of
LogCrit -> id
- LogError -> unsafePerformIO $ mkRequestLogger def { outputFormat = CustomOutputFormat $ pgrstFormat status500}
- LogWarn -> unsafePerformIO $ mkRequestLogger def { outputFormat = CustomOutputFormat $ pgrstFormat status400}
- LogInfo -> logStdout
+ LogError -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status500}
+ LogWarn -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status400}
+ LogInfo -> Wai.logStdout
-defaultCorsPolicy :: CorsResourcePolicy
-defaultCorsPolicy = CorsResourcePolicy Nothing
+defaultCorsPolicy :: Wai.CorsResourcePolicy
+defaultCorsPolicy = Wai.CorsResourcePolicy Nothing
["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"] ["Authorization"] Nothing
(Just $ 60*60*24) False False True
-- | CORS policy to be used in by Wai Cors middleware
-corsPolicy :: Request -> Maybe CorsResourcePolicy
+corsPolicy :: Wai.Request -> Maybe Wai.CorsResourcePolicy
corsPolicy req = case lookup "origin" headers of
Just origin -> Just defaultCorsPolicy {
- corsOrigins = Just ([origin], True)
- , corsRequestHeaders = "Authentication":accHeaders
- , corsExposedHeaders = Just [
+ Wai.corsOrigins = Just ([origin], True)
+ , Wai.corsRequestHeaders = "Authentication" : accHeaders
+ , Wai.corsExposedHeaders = Just [
"Content-Encoding", "Content-Location", "Content-Range", "Content-Type"
, "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"
]
}
Nothing -> Nothing
where
- headers = requestHeaders req
+ headers = Wai.requestHeaders req
accHeaders = case lookup "access-control-request-headers" headers of
Just hdrs -> map (CI.mk . toS . T.strip . toS) $ BS.split ',' hdrs
Nothing -> []
@@ -164,15 +168,15 @@ optionalRollback AppConfig{..} ApiRequest{..} transaction = do
return $ Wai.mapResponseHeaders preferenceApplied resp
where
shouldCommit =
- configDbTxAllowOverride && iPreferTransaction == Just Types.Commit
+ configDbTxAllowOverride && iPreferTransaction == Just Commit
shouldRollback =
- configDbTxAllowOverride && iPreferTransaction == Just Types.Rollback
+ configDbTxAllowOverride && iPreferTransaction == Just Rollback
preferenceApplied
| shouldCommit =
- Types.addHeadersIfNotIncluded
- [(HTTP.hPreferenceApplied, BS.pack (show Types.Commit))]
+ addHeadersIfNotIncluded
+ [(HTTP.hPreferenceApplied, BS.pack (show Commit))]
| shouldRollback =
- Types.addHeadersIfNotIncluded
- [(HTTP.hPreferenceApplied, BS.pack (show Types.Rollback))]
+ addHeadersIfNotIncluded
+ [(HTTP.hPreferenceApplied, BS.pack (show Rollback))]
| otherwise =
identity
diff --git a/src/PostgREST/OpenAPI.hs b/src/PostgREST/OpenAPI.hs
index 2d8f33c34..d935d0c90 100644
--- a/src/PostgREST/OpenAPI.hs
+++ b/src/PostgREST/OpenAPI.hs
@@ -9,32 +9,34 @@ import qualified Data.Aeson as JSON
import qualified Data.ByteString.Lazy as LBS
import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashSet.InsOrd as Set
+import qualified Data.Text as T
import Control.Arrow ((&&&))
import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList)
import Data.Maybe (fromJust)
import Data.String (IsString (..))
-import Data.Text (append, breakOn, dropWhile, init,
- intercalate, pack, tail, toLower,
- unpack)
import Network.URI (URI (..), URIAuth (..))
-import Control.Lens
+import Control.Lens (at, (.~), (?~))
+
import Data.Swagger
-import PostgREST.ApiRequest (ContentType (..))
-import PostgREST.Config (AppConfig (..), docsVersion,
- prettyVersion)
-import PostgREST.Private.ProxyUri (isMalformedProxyUri, toURI)
-import PostgREST.Types (Column (..), DbStructure (..),
- ForeignKey (..), PgArg (..),
- PrimaryKey (..),
- ProcDescription (..), Proxy (..),
- Table (..), tableCols, tableName,
- tablePKCols, tableSchema, toMime)
-import Protolude hiding (Proxy, dropWhile, get,
- intercalate, toLower, toS, (&))
-import Protolude.Conv (toS)
+import PostgREST.Config (AppConfig (..), Proxy (..),
+ docsVersion,
+ isMalformedProxyUri,
+ prettyVersion, toURI)
+import PostgREST.DbStructure (DbStructure (..), tableCols,
+ tablePKCols)
+import PostgREST.DbStructure.Proc (PgArg (..),
+ ProcDescription (..))
+import PostgREST.DbStructure.Relation (PrimaryKey (..))
+import PostgREST.DbStructure.Table (Column (..), ForeignKey (..),
+ Table (..))
+
+import PostgREST.ContentType
+
+import Protolude hiding (Proxy, get, toS)
+import Protolude.Conv (toS)
encode :: AppConfig -> DbStructure -> [Table] -> Maybe Text -> HashMap.HashMap k [ProcDescription] -> LBS.ByteString
encode conf dbStructure tables schemaDescription procs =
@@ -47,7 +49,7 @@ encode conf dbStructure tables schemaDescription procs =
(dbPrimaryKeys dbStructure)
makeMimeList :: [ContentType] -> MimeList
-makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs
+makeMimeList cs = MimeList $ fmap (fromString . toS . toMime) cs
toSwaggerType :: Text -> SwaggerType t
toSwaggerType "character varying" = SwaggerString
@@ -68,15 +70,15 @@ makeTableDef pks (t, cs, _) =
(tn, (mempty :: Schema)
& description .~ tableDescription t
& type_ ?~ SwaggerObject
- & properties .~ fromList (map (makeProperty pks) cs)
- & required .~ map colName (filter (not . colNullable) cs))
+ & properties .~ fromList (fmap (makeProperty pks) cs)
+ & required .~ fmap colName (filter (not . colNullable) cs))
makeProperty :: [PrimaryKey] -> Column -> (Text, Referenced Schema)
makeProperty pks c = (colName c, Inline s)
where
e = if null $ colEnum c then Nothing else JSON.decode $ JSON.encode $ colEnum c
fk ForeignKey{fkCol=Column{colTable=Table{tableName=a}, colName=b}} =
- intercalate "" ["This is a Foreign Key to `", a, ".", b, "`."]
+ T.intercalate "" ["This is a Foreign Key to `", a, ".", b, "`."]
pk :: Bool
pk = any (\p -> pkTable p == colTable c && pkName p == colName c) pks
n = catMaybes
@@ -86,7 +88,7 @@ makeProperty pks c = (colName c, Inline s)
]
d =
if length n > 1 then
- Just $ append (maybe "" (`append` "\n\n") $ colDescription c) (intercalate "\n" n)
+ Just $ T.append (maybe "" (`T.append` "\n\n") $ colDescription c) (T.intercalate "\n" n)
else
colDescription c
s =
@@ -103,8 +105,8 @@ makeProcSchema pd =
(mempty :: Schema)
& description .~ pdDescription pd
& type_ ?~ SwaggerObject
- & properties .~ fromList (map makeProcProperty (pdArgs pd))
- & required .~ map pgaName (filter pgaReq (pdArgs pd))
+ & properties .~ fromList (fmap makeProcProperty (pdArgs pd))
+ & required .~ fmap pgaName (filter pgaReq (pdArgs pd))
makeProcProperty :: PgArg -> (Text, Referenced Schema)
makeProcProperty (PgArg n t _ _) = (n, Inline s)
@@ -203,7 +205,7 @@ makeObjectBody tn =
makeRowFilter :: Text -> Column -> (Text, Param)
makeRowFilter tn c =
- (intercalate "." ["rowFilter", tn, colName c], (mempty :: Param)
+ (T.intercalate "." ["rowFilter", tn, colName c], (mempty :: Param)
& name .~ colName c
& description .~ colDescription c
& required ?~ False
@@ -213,21 +215,21 @@ makeRowFilter tn c =
& format ?~ colType c))
makeRowFilters :: Text -> [Column] -> [(Text, Param)]
-makeRowFilters tn = map (makeRowFilter tn)
+makeRowFilters tn = fmap (makeRowFilter tn)
makePathItem :: (Table, [Column], [Text]) -> (FilePath, PathItem)
-makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t)
+makePathItem (t, cs, _) = ("/" ++ T.unpack tn, p $ tableInsertable t)
where
-- Use first line of table description as summary; rest as description (if present)
-- We strip leading newlines from description so that users can include a blank line between summary and description
- (tSum, tDesc) = fmap fst &&& fmap (dropWhile (=='\n') . snd) $
- breakOn "\n" <$> tableDescription t
+ (tSum, tDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $
+ T.breakOn "\n" <$> tableDescription t
tOp = (mempty :: Operation)
& tags .~ Set.fromList [tn]
& summary .~ tSum
& description .~ mfilter (/="") tDesc
getOp = tOp
- & parameters .~ map ref (rs <> ["select", "order", "range", "rangeUnit", "offset", "limit", "preferCount"])
+ & parameters .~ fmap ref (rs <> ["select", "order", "range", "rangeUnit", "offset", "limit", "preferCount"])
& at 206 ?~ "Partial Content"
& at 200 ?~ Inline ((mempty :: Response)
& description .~ "OK"
@@ -237,20 +239,20 @@ makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t)
)
)
postOp = tOp
- & parameters .~ map ref ["body." <> tn, "select", "preferReturn"]
+ & parameters .~ fmap ref ["body." <> tn, "select", "preferReturn"]
& at 201 ?~ "Created"
patchOp = tOp
- & parameters .~ map ref (rs <> ["body." <> tn, "preferReturn"])
+ & parameters .~ fmap ref (rs <> ["body." <> tn, "preferReturn"])
& at 204 ?~ "No Content"
deletOp = tOp
- & parameters .~ map ref (rs <> ["preferReturn"])
+ & parameters .~ fmap ref (rs <> ["preferReturn"])
& at 204 ?~ "No Content"
pr = (mempty :: PathItem) & get ?~ getOp
pw = pr & post ?~ postOp & patch ?~ patchOp & delete ?~ deletOp
p False = pr
p True = pw
tn = tableName t
- rs = [ intercalate "." ["rowFilter", tn, colName c ] | c <- cs ]
+ rs = [ T.intercalate "." ["rowFilter", tn, colName c ] | c <- cs ]
ref = Ref . Reference
makeProcPathItem :: ProcDescription -> (FilePath, PathItem)
@@ -258,8 +260,8 @@ makeProcPathItem pd = ("/rpc/" ++ toS (pdName pd), pe)
where
-- Use first line of proc description as summary; rest as description (if present)
-- We strip leading newlines from description so that users can include a blank line between summary and description
- (pSum, pDesc) = fmap fst &&& fmap (dropWhile (=='\n') . snd) $
- breakOn "\n" <$> pdDescription pd
+ (pSum, pDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $
+ T.breakOn "\n" <$> pdDescription pd
postOp = (mempty :: Operation)
& summary .~ pSum
& description .~ mfilter (/="") pDesc
@@ -282,7 +284,7 @@ makeRootPathItem = ("/", p)
makePathItems :: [ProcDescription] -> [(Table, [Column], [Text])] -> InsOrdHashMap FilePath PathItem
makePathItems pds ti = fromList $ makeRootPathItem :
- map makePathItem ti ++ map makeProcPathItem pds
+ fmap makePathItem ti ++ fmap makeProcPathItem pds
escapeHostName :: Text -> Text
escapeHostName "*" = "0.0.0.0"
@@ -294,7 +296,7 @@ escapeHostName h = h
postgrestSpec :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] -> Swagger
postgrestSpec pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
- & basePath ?~ unpack b
+ & basePath ?~ T.unpack b
& schemes ?~ [s']
& info .~ ((mempty :: Info)
& version .~ prettyVersion
@@ -304,14 +306,14 @@ postgrestSpec pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
& description ?~ "PostgREST Documentation"
& url .~ URL ("https://postgrest.org/en/" <> docsVersion <> "/api.html"))
& host .~ h'
- & definitions .~ fromList (map (makeTableDef pks) ti)
+ & definitions .~ fromList (makeTableDef pks <$> ti)
& parameters .~ fromList (makeParamDefs ti)
& paths .~ makePathItems pds ti
& produces .~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
& consumes .~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
where
s' = if s == "http" then Http else Https
- h' = Just $ Host (unpack $ escapeHostName h) (Just (fromInteger p))
+ h' = Just $ Host (T.unpack $ escapeHostName h) (Just (fromInteger p))
d = fromMaybe "This is a dynamic API generated by PostgREST" sd
pickProxy :: Maybe Text -> Maybe Proxy
@@ -329,19 +331,19 @@ pickProxy proxy
}
where
uri = toURI $ fromJust proxy
- scheme = init $ toLower $ pack $ uriScheme uri
+ scheme = T.init $ T.toLower $ T.pack $ uriScheme uri
path URI {uriPath = ""} = "/"
path URI {uriPath = p} = p
- path' = pack $ path uri
+ path' = T.pack $ path uri
authority = fromJust $ uriAuthority uri
- host' = pack $ uriRegName authority
+ host' = T.pack $ uriRegName authority
port' = uriPort authority
readPort = fromMaybe 80 . readMaybe
port'' :: Integer
port'' = case (port', scheme) of
("", "http") -> 80
("", "https") -> 443
- _ -> readPort $ unpack $ tail $ pack port'
+ _ -> readPort $ T.unpack $ T.tail $ T.pack port'
proxyUri :: AppConfig -> (Text, Text, Integer, Text)
proxyUri AppConfig{..} =
diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/Query/QueryBuilder.hs
similarity index 91%
rename from src/PostgREST/QueryBuilder.hs
rename to src/PostgREST/Query/QueryBuilder.hs
index b392a3451..1ba5a3171 100644
--- a/src/PostgREST/QueryBuilder.hs
+++ b/src/PostgREST/Query/QueryBuilder.hs
@@ -1,22 +1,18 @@
{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
{-|
-Module : PostgREST.QueryBuilder
+Module : PostgREST.Query.QueryBuilder
Description : PostgREST SQL queries generating functions.
This module provides functions to consume data types that
represent database queries (e.g. ReadRequest, MutateRequest) and SqlFragment
to produce SqlQuery type outputs.
-}
-module PostgREST.QueryBuilder (
- readRequestToQuery
+module PostgREST.Query.QueryBuilder
+ ( readRequestToQuery
, mutateRequestToQuery
, readRequestToCountQuery
, requestToCallProcQuery
, limitedQuery
- , setConfigLocal
) where
import qualified Data.ByteString.Char8 as BS
@@ -25,12 +21,20 @@ import qualified Hasql.DynamicStatements.Snippet as H
import Data.Tree (Tree (..))
-import Data.Maybe
-import PostgREST.Private.Common
-import PostgREST.Private.QueryFragment
-import PostgREST.Types
-import Protolude hiding (cast, intercalate,
- replace)
+import PostgREST.DbStructure.Identifiers (FieldName,
+ QualifiedIdentifier (..))
+import PostgREST.DbStructure.Proc (PgArg (..))
+import PostgREST.DbStructure.Relation (Cardinality (..),
+ Relation (..))
+import PostgREST.DbStructure.Table (Table (..))
+import PostgREST.Request.ApiRequest (PayloadJSON (..))
+import PostgREST.Request.Preferences (PreferParameters (..),
+ PreferResolution (..))
+
+import PostgREST.Query.SqlFragment
+import PostgREST.Request.Types
+
+import Protolude
readRequestToQuery :: ReadRequest -> H.Snippet
readRequestToQuery (Node (Select colSelects mainQi tblAlias implJoins logicForest joinConditions_ ordts range, _) forest) =
@@ -175,8 +179,3 @@ readRequestToCountQuery (Node (Select{from=qi, where_=logicForest}, _) _) =
limitedQuery :: H.Snippet -> Maybe Integer -> H.Snippet
limitedQuery query maxRows = query <> H.sql (maybe mempty (\x -> " LIMIT " <> BS.pack (show x)) maxRows)
-
--- | Do a pg set_config(setting, value, true) call. This is equivalent to a SET LOCAL.
-setConfigLocal :: Text -> (Text, Text) -> H.Snippet
-setConfigLocal prefix (k, v) =
- "set_config(" <> unknownLiteral (prefix <> k) <> ", " <> unknownLiteral v <> ", true)"
diff --git a/src/PostgREST/Private/QueryFragment.hs b/src/PostgREST/Query/SqlFragment.hs
similarity index 79%
rename from src/PostgREST/Private/QueryFragment.hs
rename to src/PostgREST/Query/SqlFragment.hs
index a63cf22aa..2dff2bbd3 100644
--- a/src/PostgREST/Private/QueryFragment.hs
+++ b/src/PostgREST/Query/SqlFragment.hs
@@ -1,42 +1,106 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-|
-Module : PostgREST.Private.QueryFragment
+Module : PostgREST.Query.SqlFragment
Description : Helper functions for PostgREST.QueryBuilder.
Any function that outputs a SqlFragment should be in this module.
-}
-module PostgREST.Private.QueryFragment where
+module PostgREST.Query.SqlFragment
+ ( noLocationF
+ , SqlFragment
+ , asBinaryF
+ , asCsvF
+ , asJsonF
+ , asJsonSingleF
+ , countF
+ , fromQi
+ , ftsOperators
+ , jsonPlaceHolder
+ , limitOffsetF
+ , locationF
+ , normalizedBody
+ , operators
+ , pgFmtColumn
+ , pgFmtIdent
+ , pgFmtJoinCondition
+ , pgFmtLogicTree
+ , pgFmtOrderTerm
+ , pgFmtSelectItem
+ , responseHeadersF
+ , responseStatusF
+ , returningF
+ , selectBody
+ , sourceCTEName
+ , unknownLiteral
+ , intercalateSnippet
+ ) where
-import qualified Data.ByteString.Char8 as BS (intercalate,
- pack, unwords)
+import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as HM
-import Data.Maybe
-import qualified Data.Text as T (intercalate,
- isInfixOf, map,
- null, replace,
- takeWhile,
- toLower)
+import qualified Data.Text as T
import qualified Hasql.DynamicStatements.Snippet as H
-import PostgREST.RangeQuery (NonnegRange,
- allRange,
- rangeLimit,
- rangeOffset)
-import PostgREST.Types
-import Protolude hiding (cast,
- intercalate,
- replace, toLower,
- toS)
-import Protolude.Conv (toS)
-import Text.InterpolatedString.Perl6 (qc)
+import qualified Hasql.Encoders as HE
-import qualified Hasql.Encoders as HE
-import PostgREST.Private.Common
+import Data.Foldable (foldr1)
+import Text.InterpolatedString.Perl6 (qc)
+
+import PostgREST.DbStructure.Identifiers (FieldName,
+ QualifiedIdentifier (..))
+import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion96)
+import PostgREST.RangeQuery (NonnegRange, allRange,
+ rangeLimit, rangeOffset)
+import PostgREST.Request.Types (Alias, Field, Filter (..),
+ JoinCondition (..),
+ JsonOperand (..),
+ JsonOperation (..),
+ JsonPath, LogicTree (..),
+ OpExpr (..), Operation (..),
+ OrderTerm (..), SelectItem)
+
+import Protolude hiding (cast, toS)
+import Protolude.Conv (toS)
+
+
+-- | A part of a SQL query that cannot be executed independently
+type SqlFragment = ByteString
noLocationF :: SqlFragment
noLocationF = "array[]::text[]"
+sourceCTEName :: SqlFragment
+sourceCTEName = "pgrst_source"
+
+operators :: HM.HashMap Text SqlFragment
+operators = HM.union (HM.fromList [
+ ("eq", "="),
+ ("gte", ">="),
+ ("gt", ">"),
+ ("lte", "<="),
+ ("lt", "<"),
+ ("neq", "<>"),
+ ("like", "LIKE"),
+ ("ilike", "ILIKE"),
+ ("in", "IN"),
+ ("is", "IS"),
+ ("cs", "@>"),
+ ("cd", "<@"),
+ ("ov", "&&"),
+ ("sl", "<<"),
+ ("sr", ">>"),
+ ("nxr", "&<"),
+ ("nxl", "&>"),
+ ("adj", "-|-")]) ftsOperators
+
+ftsOperators :: HM.HashMap Text SqlFragment
+ftsOperators = HM.fromList [
+ ("fts", "@@ to_tsquery"),
+ ("plfts", "@@ plainto_tsquery"),
+ ("phfts", "@@ phraseto_tsquery"),
+ ("wfts", "@@ websearch_to_tsquery")
+ ]
+
-- |
-- These CTEs convert a json object into a json array, this way we can use json_populate_recordset for all json payloads
-- Otherwise we'd have to use json_populate_record for json objects and json_populate_recordset for json arrays
@@ -245,9 +309,13 @@ currentSettingF setting =
-- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15
"nullif(current_setting(" <> pgFmtLit setting <> ", true), '')"
--- Hasql Snippet utilitarians
+-- Hasql Snippet utilities
unknownEncoder :: ByteString -> H.Snippet
unknownEncoder = H.encoderAndParam (HE.nonNullable HE.unknown)
unknownLiteral :: Text -> H.Snippet
unknownLiteral = unknownEncoder . encodeUtf8
+
+intercalateSnippet :: ByteString -> [H.Snippet] -> H.Snippet
+intercalateSnippet _ [] = mempty
+intercalateSnippet frag snippets = foldr1 (\a b -> a <> H.sql frag <> b) snippets
diff --git a/src/PostgREST/Statements.hs b/src/PostgREST/Query/Statements.hs
similarity index 86%
rename from src/PostgREST/Statements.hs
rename to src/PostgREST/Query/Statements.hs
index ccf831fd6..025b01c26 100644
--- a/src/PostgREST/Statements.hs
+++ b/src/PostgREST/Query/Statements.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE QuasiQuotes #-}
{-|
-Module : PostgREST.Statements
+Module : PostgREST.Query.Statements
Description : PostgREST single SQL statements.
This module constructs single SQL statements that can be parametrized and prepared.
@@ -10,38 +10,41 @@ This module constructs single SQL statements that can be parametrized and prepar
TODO: Currently, createReadStatement is not using prepared statements. See https://github.com/PostgREST/postgrest/issues/718.
-}
-module PostgREST.Statements (
- createWriteStatement
+module PostgREST.Query.Statements
+ ( createWriteStatement
, createReadStatement
, callProcStatement
, createExplainStatement
, dbSettingsStatement
-) where
-
-
-import Control.Lens ((^?))
-import Data.Aeson as JSON
-import qualified Data.Aeson.Lens as L
-import qualified Data.ByteString.Char8 as BS
-import Data.Maybe
-import Data.Text.Read (decimal)
-import qualified Hasql.Decoders as HD
-import qualified Hasql.Encoders as HE
-import qualified Hasql.Statement as H
-import Network.HTTP.Types.Status
-import PostgREST.Error
-import PostgREST.Private.Common
-import PostgREST.Private.QueryFragment
-import PostgREST.Types
-import Protolude hiding (cast,
- replace, toS)
-import Protolude.Conv (toS)
+ ) where
+import qualified Data.Aeson as JSON
+import qualified Data.Aeson.Lens as L
+import qualified Data.ByteString.Char8 as BS
+import qualified Hasql.Decoders as HD
import qualified Hasql.DynamicStatements.Snippet as H
import qualified Hasql.DynamicStatements.Statement as H
+import qualified Hasql.Encoders as HE
+import qualified Hasql.Statement as H
+import Control.Lens ((^?))
+import Data.Maybe (fromJust)
+import Data.Text.Read (decimal)
+import Network.HTTP.Types.Status (Status)
import Text.InterpolatedString.Perl6 (q)
+import PostgREST.DbStructure.PgVersion (PgVersion)
+import PostgREST.Error (Error (..))
+import PostgREST.GucHeader (GucHeader)
+
+import PostgREST.DbStructure.Identifiers (FieldName)
+import PostgREST.Query.SqlFragment
+import PostgREST.Request.Preferences
+
+import Protolude hiding (toS)
+import Protolude.Conv (toS)
+
+
{-| The generic query result format used by API responses. The location header
is represented as a list of strings containing variable bindings like
@"k1=eq.42"@, or the empty list if there is no location header.
@@ -216,3 +219,12 @@ dbSettingsStatement = H.Statement sql HE.noParams decodeSettings False
order by key, setdatabase desc;
|]
decodeSettings = HD.rowList $ (,) <$> column HD.text <*> column HD.text
+
+column :: HD.Value a -> HD.Row a
+column = HD.column . HD.nonNullable
+
+nullableColumn :: HD.Value a -> HD.Row (Maybe a)
+nullableColumn = HD.column . HD.nullable
+
+arrayColumn :: HD.Value a -> HD.Row [a]
+arrayColumn = column . HD.listArray . HD.nonNullable
diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/Request/ApiRequest.hs
similarity index 88%
rename from src/PostgREST/ApiRequest.hs
rename to src/PostgREST/Request/ApiRequest.hs
index 2b969e09d..72d17eee9 100644
--- a/src/PostgREST/ApiRequest.hs
+++ b/src/PostgREST/Request/ApiRequest.hs
@@ -1,20 +1,21 @@
{-|
-Module : PostgREST.ApiRequest
+Module : PostgREST.Request.ApiRequest
Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
-module PostgREST.ApiRequest (
- ApiRequest(..)
-, InvokeMethod(..)
-, ContentType(..)
-, Action(..)
-, Target(..)
-, mutuallyAgreeable
-, userApiRequest
-) where
+module PostgREST.Request.ApiRequest
+ ( ApiRequest(..)
+ , InvokeMethod(..)
+ , ContentType(..)
+ , Action(..)
+ , Target(..)
+ , PayloadJSON(..)
+ , mutuallyAgreeable
+ , userApiRequest
+ ) where
import qualified Data.Aeson as JSON
import qualified Data.ByteString as BS
@@ -32,6 +33,7 @@ import Data.Aeson.Types (emptyArray, emptyObject)
import Data.List (last, lookup, partition)
import Data.List.NonEmpty (head)
import Data.Maybe (fromJust)
+import Data.Ranged.Boundaries (Boundary (..))
import Data.Ranged.Ranges (Range (..), emptyRange,
rangeIntersection)
import Network.HTTP.Base (urlEncodeVars)
@@ -42,20 +44,48 @@ import Network.Wai (Request (..))
import Network.Wai.Parse (parseHttpAccept)
import Web.Cookie (parseCookiesText)
+import PostgREST.ContentType (ContentType (..))
+import PostgREST.DbStructure (DbStructure (..))
+import PostgREST.DbStructure.Identifiers (FieldName,
+ QualifiedIdentifier (..),
+ Schema)
+import PostgREST.DbStructure.Proc (PgArg (..),
+ ProcDescription (..),
+ findProc)
+import PostgREST.Error (ApiRequestError (..))
+import PostgREST.Query.SqlFragment (ftsOperators, operators)
+import PostgREST.RangeQuery (NonnegRange, allRange,
+ rangeGeq, rangeLimit,
+ rangeOffset, rangeRequested,
+ restrictRange)
+import PostgREST.Request.Parsers (pRequestColumns)
+import PostgREST.Request.Preferences (PreferCount (..),
+ PreferParameters (..),
+ PreferRepresentation (..),
+ PreferResolution (..),
+ PreferTransaction (..))
-import Data.Ranged.Boundaries
+import qualified PostgREST.ContentType as ContentType
+
+import Protolude hiding (head, toS)
+import Protolude.Conv (toS)
-import PostgREST.Error (ApiRequestError (..))
-import PostgREST.Parsers (pRequestColumns)
-import PostgREST.RangeQuery (NonnegRange, allRange, rangeGeq,
- rangeLimit, rangeOffset, rangeRequested,
- restrictRange)
-import PostgREST.Types
-import Protolude hiding (head, toS)
-import Protolude.Conv (toS)
type RequestBody = BL.ByteString
+data PayloadJSON
+ = ProcessedJSON -- ^ Cached attributes of a JSON payload
+ { pjRaw :: BL.ByteString
+ -- ^ This is the raw ByteString that comes from the request body. We
+ -- cache this instead of an Aeson Value because it was detected that for
+ -- large payloads the encoding had high memory usage, see
+ -- https://github.com/PostgREST/postgrest/pull/1005 for more details
+ , pjKeys :: S.Set Text
+ -- ^ Keys of the object or if it's an array these keys are guaranteed to
+ -- be the same across all its objects
+ }
+ | RawJSON { pjRaw :: BL.ByteString }
+
data InvokeMethod = InvHead | InvGet | InvPost deriving Eq
-- | Types of things a user wants to do to tables/views/procs
data Action = ActionCreate | ActionRead{isHead :: Bool}
@@ -143,7 +173,7 @@ userApiRequest confSchemas rootSpec dbStructure req reqBody
, iTarget = target
, iRange = ranges
, iTopLevelRange = topLevelRange
- , iAccepts = maybe [CTAny] (map decodeContentType . parseHttpAccept) $ lookupHeader "accept"
+ , iAccepts = maybe [CTAny] (map ContentType.decodeContentType . parseHttpAccept) $ lookupHeader "accept"
, iPayload = relevantPayload
, iPreferRepresentation = representation
, iPreferParameters = if | hasPrefer (show SingleObject) -> Just SingleObject
@@ -202,7 +232,7 @@ userApiRequest confSchemas rootSpec dbStructure req reqBody
isTargetingDefaultSpec = case target of
TargetDefaultSpec _ -> True
_ -> False
- contentType = decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type"
+ contentType = ContentType.decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type"
columns
| action `elem` [ActionCreate, ActionUpdate, ActionInvoke InvPost] = toS <$> join (lookup "columns" qParams)
| otherwise = Nothing
@@ -236,7 +266,7 @@ userApiRequest confSchemas rootSpec dbStructure req reqBody
let paramsMap = M.fromList $ (toS *** JSON.String . toS) <$> urlEncodedBody in
Right $ ProcessedJSON (JSON.encode paramsMap) $ S.fromList (M.keys paramsMap)
ct ->
- Left $ toS $ "Content-Type not acceptable: " <> toMime ct
+ Left $ toS $ "Content-Type not acceptable: " <> ContentType.toMime ct
topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges -- if no limit is specified, get all the request rows
action =
case method of
diff --git a/src/PostgREST/DbRequestBuilder.hs b/src/PostgREST/Request/DbRequestBuilder.hs
similarity index 79%
rename from src/PostgREST/DbRequestBuilder.hs
rename to src/PostgREST/Request/DbRequestBuilder.hs
index a52a30f08..dd17b35d6 100644
--- a/src/PostgREST/DbRequestBuilder.hs
+++ b/src/PostgREST/Request/DbRequestBuilder.hs
@@ -1,21 +1,25 @@
{-|
-Module : PostgREST.DbRequestBuilder
+Module : PostgREST.Request.DbRequestBuilder
Description : PostgREST database request builder
-This module is in charge of building an intermediate representation(ReadRequest, MutateRequest) between the HTTP request and the final resulting SQL query.
+This module is in charge of building an intermediate
+representation(ReadRequest, MutateRequest) between the HTTP request and the
+final resulting SQL query.
-A query tree is built in case of resource embedding. By inferring the relationship between tables, join conditions are added for every embedded resource.
+A query tree is built in case of resource embedding. By inferring the
+relationship between tables, join conditions are added for every embedded
+resource.
-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
-module PostgREST.DbRequestBuilder (
- readRequest
-, mutateRequest
-, returningCols
-) where
+module PostgREST.Request.DbRequestBuilder
+ ( readRequest
+ , mutateRequest
+ , returningCols
+ ) where
import qualified Data.HashMap.Strict as M
import qualified Data.Set as S
@@ -24,16 +28,31 @@ import Control.Arrow ((***))
import Data.Either.Combinators (mapLeft)
import Data.List (delete)
import Data.Text (isInfixOf)
+import Data.Tree (Tree (..))
-import Control.Applicative
-import Data.Tree
+import PostgREST.DbStructure.Identifiers (FieldName,
+ QualifiedIdentifier (..),
+ Schema, TableName)
+import PostgREST.DbStructure.Relation (Cardinality (..), Link (..),
+ Relation (..))
+import PostgREST.DbStructure.Table (Column (..), Table (..),
+ tableQi)
+import PostgREST.Error (ApiRequestError (..),
+ Error (..))
+import PostgREST.Query.SqlFragment (sourceCTEName)
+import PostgREST.RangeQuery (NonnegRange, allRange,
+ restrictRange)
+import PostgREST.Request.ApiRequest (Action (..),
+ ApiRequest (..),
+ PayloadJSON (..))
-import PostgREST.ApiRequest (Action (..), ApiRequest (..))
-import PostgREST.Error (ApiRequestError (..), Error (..))
-import PostgREST.Parsers
-import PostgREST.RangeQuery (NonnegRange, allRange, restrictRange)
-import PostgREST.Types
-import Protolude hiding (from)
+import PostgREST.Request.Parsers
+import PostgREST.Request.Preferences
+import PostgREST.Request.Types
+
+import qualified PostgREST.DbStructure.Relation as Relation
+
+import Protolude hiding (from)
-- | Builds the ReadRequest tree on a number of stages.
-- | Adds filters, order, limits on its respective nodes.
@@ -50,23 +69,27 @@ readRequest schema rootTableName maxRows allRels apiRequest =
(rootName, rootRels) = rootWithRels schema rootTableName allRels (iAction apiRequest)
-- Get the root table name with its relationships according to the Action type.
--- This is done because of the shape of the final SQL Query. The mutation cases are wrapped in a WITH {sourceCTEName}(see Statements.hs).
--- So we need a FROM {sourceCTEName} instead of FROM {tableName}.
+-- This is done because of the shape of the final SQL Query. The mutation cases
+-- are wrapped in a WITH {sourceCTEName}(see Statements.hs). So we need a FROM
+-- {sourceCTEName} instead of FROM {tableName}.
rootWithRels :: Schema -> TableName -> [Relation] -> Action -> (QualifiedIdentifier, [Relation])
rootWithRels schema rootTableName allRels action = case action of
ActionRead _ -> (QualifiedIdentifier schema rootTableName, allRels) -- normal read case
_ -> (QualifiedIdentifier mempty _sourceCTEName, mapMaybe toSourceRel allRels ++ allRels) -- mutation cases and calling proc
where
_sourceCTEName = decodeUtf8 sourceCTEName
- -- To enable embedding in the sourceCTEName cases we need to replace the foreign key tableName in the Relation
- -- with {sourceCTEName}. This way findRel can find relationships with sourceCTEName.
+ -- To enable embedding in the sourceCTEName cases we need to replace the
+ -- foreign key tableName in the Relation with {sourceCTEName}. This way
+ -- findRel can find relationships with sourceCTEName.
toSourceRel :: Relation -> Maybe Relation
toSourceRel r@Relation{relTable=t}
| rootTableName == tableName t = Just $ r {relTable=t {tableName=_sourceCTEName}}
| otherwise = Nothing
--- Build the initial tree with a Depth attribute so when a self join occurs we can differentiate the parent and child tables by having
--- an alias like "table_depth", this is related to http://github.com/PostgREST/postgrest/issues/987.
+-- Build the initial tree with a Depth attribute so when a self join occurs we
+-- can differentiate the parent and child tables by having an alias like
+-- "table_depth", this is related to
+-- http://github.com/PostgREST/postgrest/issues/987.
initReadRequest :: QualifiedIdentifier -> [Tree SelectItem] -> ReadRequest
initReadRequest rootQi =
foldr (treeEntry rootDepth) initial
@@ -114,10 +137,12 @@ addRels schema allRels parentNode (Node (query@Select{from=tbl}, (nodeName, _, a
updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest]
updateForest rq = addRels schema allRels rq `traverse` forest
--- Finds a relationship between an origin and a target in the request: /origin?select=target(*)
--- If more than one relationship is found then the request is ambiguous and we return an error.
--- In that case the request can be disambiguated by adding precision to the target or by using a hint: /origin?select=target!hint(*)
--- The elements will be matched according to these rules:
+-- Finds a relationship between an origin and a target in the request:
+-- /origin?select=target(*) If more than one relationship is found then the
+-- request is ambiguous and we return an error. In that case the request can
+-- be disambiguated by adding precision to the target or by using a hint:
+-- /origin?select=target!hint(*) The elements will be matched according to
+-- these rules:
-- origin = table / view
-- target = table / view / constraint / column-from-origin
-- hint = table / view / constraint / column-from-origin / column-from-target
@@ -128,11 +153,14 @@ findRel schema allRels origin target hint =
[] -> Left $ NoRelBetween origin target
[r] -> Right r
rs ->
- -- Return error if more than one relationship is found, unless we're in a self reference case.
+ -- Return error if more than one relationship is found, unless we're in a
+ -- self reference case.
--
- -- Here we handle a self reference relationship to not cause a breaking change:
- -- In a self reference we get two relationships with the same foreign key and relTable/relFtable but with different cardinalities(m2o/o2m)
- -- We output the O2M rel, the M2O rel can be obtained by using the origin column as an embed hint.
+ -- Here we handle a self reference relationship to not cause a breaking
+ -- change: In a self reference we get two relationships with the same
+ -- foreign key and relTable/relFtable but with different
+ -- cardinalities(m2o/o2m) We output the O2M rel, the M2O rel can be
+ -- obtained by using the origin column as an embed hint.
let [rel0, rel1] = take 2 rs in
if length rs == 2 && relLink rel0 == relLink rel1 && relTable rel0 == relTable rel1 && relFTable rel0 == relFTable rel1
then note (NoRelBetween origin target) (find (\r -> relType r == O2M) rs)
@@ -189,7 +217,7 @@ addJoinConditions previousAlias (Node node@(query@Select{from=tbl}, nodeProps@(_
Just r -> Node (augmentQuery r, nodeProps) <$> updatedForest
Nothing -> Node node <$> updatedForest
where
- newAlias = case isSelfReference <$> rel of
+ newAlias = case Relation.isSelfReference <$> rel of
Just True
| depth /= 0 -> Just (qiName tbl <> "_" <> show depth) -- root node doesn't get aliased
| otherwise -> Nothing
@@ -217,9 +245,10 @@ getJoinConditions previousAlias newAlias (Relation Table{tableSchema=tSchema, ta
JoinCondition (maybe qi1 (QualifiedIdentifier mempty) previousAlias, colName c)
(maybe qi2 (QualifiedIdentifier mempty) newAlias, colName fc)
- -- On mutation and calling proc cases we wrap the target table in a WITH {sourceCTEName}
- -- if this happens remove the schema `FROM "schema"."{sourceCTEName}"` and use only the
- -- `FROM "{sourceCTEName}"`. If the schema remains the FROM would be invalid.
+ -- On mutation and calling proc cases we wrap the target table in a WITH
+ -- {sourceCTEName} if this happens remove the schema `FROM
+ -- "schema"."{sourceCTEName}"` and use only the `FROM "{sourceCTEName}"`.
+ -- If the schema remains the FROM would be invalid.
removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier
removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == decodeUtf8 sourceCTEName then mempty else schema) tbl
@@ -318,16 +347,19 @@ mutateRequest schema tName apiRequest pkCols readReq = mapLeft ApiRequestError $
returningCols :: ReadRequest -> [FieldName] -> [FieldName]
returningCols rr@(Node _ forest) pkCols
- -- if * is part of the select, we must not add pk or fk columns manually - otherwise those would be selected and output twice
+ -- if * is part of the select, we must not add pk or fk columns manually -
+ -- otherwise those would be selected and output twice
| "*" `elem` fldNames = ["*"]
| otherwise = returnings
where
fldNames = fstFieldNames rr
- -- Without fkCols, when a mutateRequest to /projects?select=name,clients(name) occurs, the RETURNING SQL part would be
- -- `RETURNING name`(see QueryBuilder).
- -- This would make the embedding fail because the following JOIN would need the "client_id" column from projects.
- -- So this adds the foreign key columns to ensure the embedding succeeds, result would be `RETURNING name, client_id`.
- -- This also works for the other relType's.
+ -- Without fkCols, when a mutateRequest to
+ -- /projects?select=name,clients(name) occurs, the RETURNING SQL part would
+ -- be `RETURNING name`(see QueryBuilder). This would make the embedding
+ -- fail because the following JOIN would need the "client_id" column from
+ -- projects. So this adds the foreign key columns to ensure the embedding
+ -- succeeds, result would be `RETURNING name, client_id`. This also works
+ -- for the other relType's.
fkCols = concat $ mapMaybe (\case
Node (_, (_, Just Relation{relColumns=cols, relType=relTyp}, _, _, _)) _ -> case relTyp of
O2M -> Just cols
@@ -335,10 +367,13 @@ returningCols rr@(Node _ forest) pkCols
M2M -> Just cols
_ -> Nothing
) forest
- -- However if the "client_id" is present, e.g. mutateRequest to /projects?select=client_id,name,clients(name)
- -- we would get `RETURNING client_id, name, client_id` and then we would produce the "column reference \"client_id\" is ambiguous"
- -- error from PostgreSQL. So we deduplicate with Set:
- -- We are adding the primary key columns as well to make sure, that a proper location header can always be built for INSERT/POST
+ -- However if the "client_id" is present, e.g. mutateRequest to
+ -- /projects?select=client_id,name,clients(name) we would get `RETURNING
+ -- client_id, name, client_id` and then we would produce the "column
+ -- reference \"client_id\" is ambiguous" error from PostgreSQL. So we
+ -- deduplicate with Set: We are adding the primary key columns as well to
+ -- make sure, that a proper location header can always be built for
+ -- INSERT/POST
returnings = S.toList . S.fromList $ fldNames ++ (colName <$> fkCols) ++ pkCols
-- Traditional filters(e.g. id=eq.1) are added as root nodes of the LogicTree
diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Request/Parsers.hs
similarity index 84%
rename from src/PostgREST/Parsers.hs
rename to src/PostgREST/Request/Parsers.hs
index 00eb223e7..0c4cbb979 100644
--- a/src/PostgREST/Parsers.hs
+++ b/src/PostgREST/Request/Parsers.hs
@@ -1,30 +1,54 @@
{-|
-Module : PostgREST.Parsers
+Module : PostgREST.Request.Parsers
Description : PostgREST parser combinators
This module is in charge of parsing all the querystring values in an url, e.g. the select, id, order in `/projects?select=id,name&id=eq.1&order=id,name.desc`.
-}
-module PostgREST.Parsers where
+module PostgREST.Request.Parsers
+ ( pColumns
+ , pLogicPath
+ , pLogicSingleVal
+ , pLogicTree
+ , pOrder
+ , pOrderTerm
+ , pRequestColumns
+ , pRequestFilter
+ , pRequestLogicTree
+ , pRequestOnConflict
+ , pRequestOrder
+ , pRequestRange
+ , pRequestSelect
+ , pSingleVal
+ , pTreePath
+ ) where
import qualified Data.HashMap.Strict as M
import qualified Data.Set as S
-import Data.Either.Combinators (mapLeft)
-import Data.Foldable (foldl1)
-import Data.List (init, last)
-import Data.Text (intercalate, replace, strip)
-import Text.Read (read)
+import Data.Either.Combinators (mapLeft)
+import Data.Foldable (foldl1)
+import Data.List (init, last)
+import Data.Text (intercalate, replace, strip)
+import Data.Tree (Tree (..))
+import Text.Parsec.Error (errorMessages,
+ showErrorMessages)
+import Text.ParserCombinators.Parsec (GenParser, ParseError, Parser,
+ anyChar, between, char, digit,
+ eof, errorPos, letter,
+ lookAhead, many1, noneOf,
+ notFollowedBy, oneOf, option,
+ optionMaybe, parse, sepBy1,
+ string, try, ())
-import Data.Tree
-import Text.Parsec.Error
-import Text.ParserCombinators.Parsec hiding (many, (<|>))
+import PostgREST.DbStructure.Identifiers (FieldName)
+import PostgREST.Error (ApiRequestError (ParseRequestError))
+import PostgREST.Query.SqlFragment (ftsOperators, operators)
+import PostgREST.RangeQuery (NonnegRange)
-import PostgREST.Error (ApiRequestError (ParseRequestError))
-import PostgREST.RangeQuery (NonnegRange)
-import PostgREST.Types
-import Protolude hiding (intercalate, option, replace, toS,
- try)
-import Protolude.Conv (toS)
+import PostgREST.Request.Types
+
+import Protolude hiding (intercalate, option, replace, toS, try)
+import Protolude.Conv (toS)
pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem]
pRequestSelect selStr =
@@ -250,23 +274,3 @@ mapError = mapLeft translateError
message = show $ errorPos e
details = strip $ replace "\n" " " $ toS
$ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
-
--- Used for the config value "role-claim-key"
-pRoleClaimKey :: Text -> Either Text JSPath
-pRoleClaimKey selStr =
- mapLeft show $ parse pJSPath ("failed to parse role-claim-key value (" <> toS selStr <> ")") (toS selStr)
-
-pJSPath :: Parser JSPath
-pJSPath = toJSPath <$> (period *> pPath `sepBy` period <* eof)
- where
- toJSPath :: [(Text, Maybe Int)] -> JSPath
- toJSPath = concatMap (\(key, idx) -> JSPKey key : maybeToList (JSPIdx <$> idx))
- period = char '.' "period (.)"
- pPath :: Parser (Text, Maybe Int)
- pPath = (,) <$> pJSPKey <*> optionMaybe pJSPIdx
-
-pJSPKey :: Parser Text
-pJSPKey = toS <$> many1 (alphaNum <|> oneOf "_$@") <|> pQuotedValue "attribute name [a..z0..9_$@])"
-
-pJSPIdx :: Parser Int
-pJSPIdx = char '[' *> (read <$> many1 digit) <* char ']' "array index [0..n]"
diff --git a/src/PostgREST/Request/Preferences.hs b/src/PostgREST/Request/Preferences.hs
new file mode 100644
index 000000000..a85e40420
--- /dev/null
+++ b/src/PostgREST/Request/Preferences.hs
@@ -0,0 +1,54 @@
+module PostgREST.Request.Preferences where
+
+import GHC.Show
+import Protolude
+
+
+data PreferResolution
+ = MergeDuplicates
+ | IgnoreDuplicates
+
+instance Show PreferResolution where
+ show MergeDuplicates = "resolution=merge-duplicates"
+ show IgnoreDuplicates = "resolution=ignore-duplicates"
+
+-- | How to return the mutated data. From https://tools.ietf.org/html/rfc7240#section-4.2
+data PreferRepresentation
+ = Full -- ^ Return the body plus the Location header(in case of POST).
+ | HeadersOnly -- ^ Return the Location header(in case of POST). This needs a SELECT privilege on the pk.
+ | None -- ^ Return nothing from the mutated data.
+ deriving Eq
+
+instance Show PreferRepresentation where
+ show Full = "return=representation"
+ show None = "return=minimal"
+ show HeadersOnly = mempty
+
+data PreferParameters
+ = SingleObject -- ^ Pass all parameters as a single json object to a stored procedure
+ | MultipleObjects -- ^ Pass an array of json objects as params to a stored procedure
+ deriving Eq
+
+instance Show PreferParameters where
+ show SingleObject = "params=single-object"
+ show MultipleObjects = "params=multiple-objects"
+
+data PreferCount
+ = ExactCount -- ^ exact count(slower)
+ | PlannedCount -- ^ PostgreSQL query planner rows count guess. Done by using EXPLAIN {query}.
+ | EstimatedCount -- ^ use the query planner rows if the count is superior to max-rows, otherwise get the exact count.
+ deriving Eq
+
+instance Show PreferCount where
+ show ExactCount = "count=exact"
+ show PlannedCount = "count=planned"
+ show EstimatedCount = "count=estimated"
+
+data PreferTransaction
+ = Commit -- Commit transaction - the default.
+ | Rollback -- Rollback transaction after sending the response - does not persist changes, e.g. for running tests.
+ deriving Eq
+
+instance Show PreferTransaction where
+ show Commit = "tx=commit"
+ show Rollback = "tx=rollback"
diff --git a/src/PostgREST/Request/Types.hs b/src/PostgREST/Request/Types.hs
new file mode 100644
index 000000000..9b957c866
--- /dev/null
+++ b/src/PostgREST/Request/Types.hs
@@ -0,0 +1,211 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module PostgREST.Request.Types
+ ( Alias
+ , Depth
+ , EmbedHint
+ , EmbedPath
+ , Field
+ , Filter(..)
+ , JoinCondition(..)
+ , JsonOperand(..)
+ , JsonOperation(..)
+ , JsonPath
+ , ListVal
+ , LogicOperator(..)
+ , LogicTree(..)
+ , MutateQuery(..)
+ , MutateRequest
+ , NodeName
+ , OpExpr(..)
+ , Operation (..)
+ , OrderDirection(..)
+ , OrderNulls(..)
+ , OrderTerm(..)
+ , ReadNode
+ , ReadQuery(..)
+ , ReadRequest
+ , SelectItem
+ , SingleVal
+ , fstFieldNames
+ ) where
+
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Set as S
+
+import Data.Tree (Tree (..))
+
+import qualified GHC.Show (show)
+
+import PostgREST.DbStructure.Identifiers (FieldName,
+ QualifiedIdentifier)
+import PostgREST.DbStructure.Relation (Relation)
+import PostgREST.RangeQuery (NonnegRange)
+import PostgREST.Request.Preferences (PreferResolution)
+
+import Protolude
+
+
+type ReadRequest = Tree ReadNode
+type MutateRequest = MutateQuery
+
+type ReadNode =
+ (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe EmbedHint, Depth))
+
+type NodeName = Text
+type Depth = Integer
+
+data ReadQuery = Select
+ { select :: [SelectItem]
+ , from :: QualifiedIdentifier
+ -- ^ A table alias is used in case of self joins
+ , fromAlias :: Maybe Alias
+ -- ^ Only used for Many to Many joins. Parent and Child joins use explicit joins.
+ , implicitJoins :: [QualifiedIdentifier]
+ , where_ :: [LogicTree]
+ , joinConditions :: [JoinCondition]
+ , order :: [OrderTerm]
+ , range_ :: NonnegRange
+ }
+ deriving (Eq)
+
+data JoinCondition =
+ JoinCondition
+ (QualifiedIdentifier, FieldName)
+ (QualifiedIdentifier, FieldName)
+ deriving (Eq)
+
+data OrderTerm = OrderTerm
+ { otTerm :: Field
+ , otDirection :: Maybe OrderDirection
+ , otNullOrder :: Maybe OrderNulls
+ }
+ deriving (Eq)
+
+data OrderDirection
+ = OrderAsc
+ | OrderDesc
+ deriving (Eq)
+
+instance Show OrderDirection where
+ show OrderAsc = "ASC"
+ show OrderDesc = "DESC"
+
+data OrderNulls
+ = OrderNullsFirst
+ | OrderNullsLast
+ deriving (Eq)
+
+instance Show OrderNulls where
+ show OrderNullsFirst = "NULLS FIRST"
+ show OrderNullsLast = "NULLS LAST"
+
+data MutateQuery
+ = Insert
+ { in_ :: QualifiedIdentifier
+ , insCols :: S.Set FieldName
+ , insBody :: Maybe BL.ByteString
+ , onConflict :: Maybe (PreferResolution, [FieldName])
+ , where_ :: [LogicTree]
+ , returning :: [FieldName]
+ }
+ | Update
+ { in_ :: QualifiedIdentifier
+ , updCols :: S.Set FieldName
+ , updBody :: Maybe BL.ByteString
+ , where_ :: [LogicTree]
+ , returning :: [FieldName]
+ }
+ | Delete
+ { in_ :: QualifiedIdentifier
+ , where_ :: [LogicTree]
+ , returning :: [FieldName]
+ }
+
+-- | This type will hold information about which particular 'Relation' between
+-- two tables to choose when there are multiple ones.
+-- Specifically, it will contain the name of the foreign key or the join table
+-- in many to many relations.
+type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe EmbedHint)
+
+type Field = (FieldName, JsonPath)
+type Cast = Text
+type Alias = Text
+
+-- | Disambiguates an embedding operation when there's multiple relationships
+-- between two tables. Can be the name of a foreign key constraint, column
+-- name or the junction in an m2m relationship.
+type EmbedHint = Text
+
+-- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path
+-- ["clients", "projects"]
+type EmbedPath = [Text]
+
+-- | Json path operations as specified in
+-- https://www.postgresql.org/docs/current/static/functions-json.html
+type JsonPath = [JsonOperation]
+
+-- | Represents the single arrow `->` or double arrow `->>` operators
+data JsonOperation
+ = JArrow { jOp :: JsonOperand }
+ | J2Arrow { jOp :: JsonOperand }
+ deriving (Eq)
+
+-- | Represents the key(`->'key'`) or index(`->'1`::int`), the index is Text
+-- because we reuse our escaping functons and let pg do the casting with
+-- '1'::int
+data JsonOperand
+ = JKey { jVal :: Text }
+ | JIdx { jVal :: Text }
+ deriving (Eq)
+
+-- First level FieldNames(e.g get a,b from /table?select=a,b,other(c,d))
+fstFieldNames :: ReadRequest -> [FieldName]
+fstFieldNames (Node (sel, _) _) =
+ fst . (\(f, _, _, _) -> f) <$> select sel
+
+
+-- | Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is:
+--
+-- And
+-- / \
+-- name.eq.N Or
+-- / \
+-- id.eq.1 id.eq.2
+data LogicTree
+ = Expr Bool LogicOperator [LogicTree]
+ | Stmnt Filter
+ deriving (Eq)
+
+data LogicOperator
+ = And
+ | Or
+ deriving Eq
+
+instance Show LogicOperator where
+ show And = "AND"
+ show Or = "OR"
+
+data Filter = Filter
+ { field :: Field
+ , opExpr :: OpExpr
+ }
+ deriving (Eq)
+
+data OpExpr =
+ OpExpr Bool Operation
+ deriving (Eq)
+
+data Operation
+ = Op Operator SingleVal
+ | In ListVal
+ | Fts Operator (Maybe Language) SingleVal
+ deriving (Eq)
+
+type Operator = Text
+type Language = Text
+
+-- | Represents a single value in a filter, e.g. id=eq.singleval
+type SingleVal = Text
+
+-- | Represents a list value in a filter, e.g. id=in.(val1,val2,val3)
+type ListVal = [Text]
diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs
deleted file mode 100644
index fb1d76e77..000000000
--- a/src/PostgREST/Types.hs
+++ /dev/null
@@ -1,580 +0,0 @@
-{-|
-Module : PostgREST.Types
-Description : PostgREST common types and functions used by the rest of the modules
--}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-
-module PostgREST.Types where
-
-import Control.Lens.Getter (view)
-import Control.Lens.Tuple (_1)
-
-import qualified Data.Aeson as JSON
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Internal as BS (c2w)
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.CaseInsensitive as CI
-import qualified Data.HashMap.Strict as M
-import qualified Data.Set as S
-import qualified GHC.Show
-
-import Network.HTTP.Types.Header (Header, hContentType)
-
-import Data.Tree
-
-import PostgREST.RangeQuery (NonnegRange)
-import Protolude hiding (toS)
-import Protolude.Conv (toS)
-
--- | Enumeration of currently supported response content types
-data ContentType = CTApplicationJSON | CTSingularJSON
- | CTTextCSV | CTTextPlain
- | CTOpenAPI | CTUrlEncoded | CTOctetStream
- | CTAny | CTOther ByteString deriving (Eq)
-
--- | Convert from ContentType to a full HTTP Header
-toHeader :: ContentType -> Header
-toHeader ct = (hContentType, toMime ct <> charset)
- where
- charset = case ct of
- CTOctetStream -> mempty
- CTOther _ -> mempty
- _ -> "; charset=utf-8"
-
--- | Convert from ContentType to a ByteString representing the mime type
-toMime :: ContentType -> ByteString
-toMime CTApplicationJSON = "application/json"
-toMime CTTextCSV = "text/csv"
-toMime CTTextPlain = "text/plain"
-toMime CTOpenAPI = "application/openapi+json"
-toMime CTSingularJSON = "application/vnd.pgrst.object+json"
-toMime CTUrlEncoded = "application/x-www-form-urlencoded"
-toMime CTOctetStream = "application/octet-stream"
-toMime CTAny = "*/*"
-toMime (CTOther ct) = ct
-
--- | Convert from ByteString to ContentType. Warning: discards MIME parameters
-decodeContentType :: BS.ByteString -> ContentType
-decodeContentType ct = case BS.takeWhile (/= BS.c2w ';') ct of
- "application/json" -> CTApplicationJSON
- "text/csv" -> CTTextCSV
- "text/plain" -> CTTextPlain
- "application/openapi+json" -> CTOpenAPI
- "application/vnd.pgrst.object+json" -> CTSingularJSON
- "application/vnd.pgrst.object" -> CTSingularJSON
- "application/x-www-form-urlencoded" -> CTUrlEncoded
- "application/octet-stream" -> CTOctetStream
- "*/*" -> CTAny
- ct' -> CTOther ct'
-
--- | A SQL query that can be executed independently
-type SqlQuery = ByteString
-
--- | A part of a SQL query that cannot be executed independently
-type SqlFragment = ByteString
-
-data PreferResolution = MergeDuplicates | IgnoreDuplicates
-instance Show PreferResolution where
- show MergeDuplicates = "resolution=merge-duplicates"
- show IgnoreDuplicates = "resolution=ignore-duplicates"
-
--- | How to return the mutated data. From https://tools.ietf.org/html/rfc7240#section-4.2
-data PreferRepresentation = Full -- ^ Return the body plus the Location header(in case of POST).
- | HeadersOnly -- ^ Return the Location header(in case of POST). This needs a SELECT privilege on the pk.
- | None -- ^ Return nothing from the mutated data.
- deriving Eq
-instance Show PreferRepresentation where
- show Full = "return=representation"
- show None = "return=minimal"
- show HeadersOnly = mempty
-
-data PreferParameters
- = SingleObject -- ^ Pass all parameters as a single json object to a stored procedure
- | MultipleObjects -- ^ Pass an array of json objects as params to a stored procedure
- deriving Eq
-
-instance Show PreferParameters where
- show SingleObject = "params=single-object"
- show MultipleObjects = "params=multiple-objects"
-
-data PreferCount
- = ExactCount -- ^ exact count(slower)
- | PlannedCount -- ^ PostgreSQL query planner rows count guess. Done by using EXPLAIN {query}.
- | EstimatedCount -- ^ use the query planner rows if the count is superior to max-rows, otherwise get the exact count.
- deriving Eq
-
-instance Show PreferCount where
- show ExactCount = "count=exact"
- show PlannedCount = "count=planned"
- show EstimatedCount = "count=estimated"
-
-data PreferTransaction
- = Commit -- Commit transaction - the default.
- | Rollback -- Rollback transaction after sending the response - does not persist changes, e.g. for running tests.
- deriving Eq
-
-instance Show PreferTransaction where
- show Commit = "tx=commit"
- show Rollback = "tx=rollback"
-
-data DbStructure = DbStructure {
- dbTables :: [Table]
-, dbColumns :: [Column]
-, dbRelations :: [Relation]
-, dbPrimaryKeys :: [PrimaryKey]
-, dbProcs :: ProcsMap
-, pgVersion :: PgVersion
-} deriving (Generic, JSON.ToJSON)
-
--- TODO Table could hold references to all its Columns
-tableCols :: DbStructure -> Schema -> TableName -> [Column]
-tableCols dbs tSchema tName = filter (\Column{colTable=Table{tableSchema=s, tableName=t}} -> s==tSchema && t==tName) $ dbColumns dbs
-
--- TODO Table could hold references to all its PrimaryKeys
-tablePKCols :: DbStructure -> Schema -> TableName -> [Text]
-tablePKCols dbs tSchema tName = pkName <$> filter (\pk -> tSchema == (tableSchema . pkTable) pk && tName == (tableName . pkTable) pk) (dbPrimaryKeys dbs)
-
-data PgArg = PgArg {
- pgaName :: Text
-, pgaType :: Text
-, pgaReq :: Bool
-, pgaVar :: Bool
-} deriving (Eq, Ord, Generic, JSON.ToJSON)
-
-data PgType = Scalar | Composite QualifiedIdentifier deriving (Eq, Ord, Generic, JSON.ToJSON)
-
-data RetType = Single PgType | SetOf PgType deriving (Eq, Ord, Generic, JSON.ToJSON)
-
-data ProcVolatility = Volatile | Stable | Immutable
- deriving (Eq, Ord, Generic, JSON.ToJSON)
-
-data ProcDescription = ProcDescription {
- pdSchema :: Schema
-, pdName :: Text
-, pdDescription :: Maybe Text
-, pdArgs :: [PgArg]
-, pdReturnType :: RetType
-, pdVolatility :: ProcVolatility
-, pdHasVariadic :: Bool
-} deriving (Eq, Generic, JSON.ToJSON)
-
--- Order by least number of args in the case of overloaded functions
-instance Ord ProcDescription where
- ProcDescription schema1 name1 des1 args1 rt1 vol1 hasVar1 `compare` ProcDescription schema2 name2 des2 args2 rt2 vol2 hasVar2
- | schema1 == schema2 && name1 == name2 && length args1 < length args2 = LT
- | schema2 == schema2 && name1 == name2 && length args1 > length args2 = GT
- | otherwise = (schema1, name1, des1, args1, rt1, vol1, hasVar1) `compare` (schema2, name2, des2, args2, rt2, vol2, hasVar2)
-
--- | A map of all procs, all of which can be overloaded(one entry will have more than one ProcDescription).
--- | It uses a HashMap for a faster lookup.
-type ProcsMap = M.HashMap QualifiedIdentifier [ProcDescription]
-
-{-|
- Search a pg procedure by its parameters. Since a function can be overloaded, the name is not enough to find it.
- An overloaded function can have a different volatility or even a different return type.
- Ideally, handling overloaded functions should be left to pg itself. But we need to know certain proc attributes in advance.
--}
-findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> ProcsMap -> ProcDescription
-findProc qi payloadKeys paramsAsSingleObject allProcs = fromMaybe fallback bestMatch
- where
- -- instead of passing Maybe ProcDescription around, we create a fallback description here when we can't find a matching function
- -- args is empty, but because "specifiedProcArgs" will fill the missing arguments with default type text, this is not a problem
- fallback = ProcDescription (qiSchema qi) (qiName qi) Nothing mempty (SetOf $ Composite $ QualifiedIdentifier mempty "record") Volatile False
- bestMatch =
- case M.lookup qi allProcs of
- Nothing -> Nothing
- Just [proc] -> Just proc -- if it's not an overloaded function then immediately get the ProcDescription
- Just procs -> find matches procs -- Handle overloaded functions case
- matches proc =
- if paramsAsSingleObject
- -- if the arg is not of json type let the db give the err
- then length (pdArgs proc) == 1
- else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs proc)
-
-{-|
- Search the procedure parameters by matching them with the specified keys.
- If the key doesn't match a parameter, a parameter with a default type "text" is assumed.
--}
-specifiedProcArgs :: S.Set FieldName -> ProcDescription -> [PgArg]
-specifiedProcArgs keys proc =
- (\k -> fromMaybe (PgArg k "text" True False) (find ((==) k . pgaName) (pdArgs proc))) <$> S.toList keys
-
-procReturnsScalar :: ProcDescription -> Bool
-procReturnsScalar proc = case proc of
- ProcDescription{pdReturnType = (Single Scalar)} -> True
- ProcDescription{pdReturnType = (SetOf Scalar)} -> True
- _ -> False
-
-procReturnsSingle :: ProcDescription -> Bool
-procReturnsSingle proc = case proc of
- ProcDescription{pdReturnType = (Single _)} -> True
- _ -> False
-
-procTableName :: ProcDescription -> Maybe TableName
-procTableName proc = case pdReturnType proc of
- SetOf (Composite qi) -> Just $ qiName qi
- Single (Composite qi) -> Just $ qiName qi
- _ -> Nothing
-
-type Schema = Text
-type TableName = Text
-
-data Table = Table {
- tableSchema :: Schema
-, tableName :: TableName
-, tableDescription :: Maybe Text
-, tableInsertable :: Bool
-} deriving (Show, Ord, Generic, JSON.ToJSON)
-
-instance Eq Table where
- Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2
-
-tableQi :: Table -> QualifiedIdentifier
-tableQi Table{tableSchema=s, tableName=n} = QualifiedIdentifier s n
-
-newtype ForeignKey = ForeignKey { fkCol :: Column } deriving (Eq, Ord, Generic, JSON.ToJSON)
-
-data Column =
- Column {
- colTable :: Table
- , colName :: FieldName
- , colDescription :: Maybe Text
- , colNullable :: Bool
- , colType :: Text
- , colMaxLen :: Maybe Int32
- , colDefault :: Maybe Text
- , colEnum :: [Text]
- , colFK :: Maybe ForeignKey
- } deriving (Ord, Generic, JSON.ToJSON)
-
-instance Eq Column where
- Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2
-
--- | The source table column a view column refers to
-type SourceColumn = (Column, ViewColumn)
-type ViewColumn = Column
-
-data PrimaryKey = PrimaryKey {
- pkTable :: Table
- , pkName :: Text
-} deriving (Generic, JSON.ToJSON)
-
-data OrderDirection = OrderAsc | OrderDesc deriving (Eq)
-instance Show OrderDirection where
- show OrderAsc = "ASC"
- show OrderDesc = "DESC"
-
-data OrderNulls = OrderNullsFirst | OrderNullsLast deriving (Eq)
-instance Show OrderNulls where
- show OrderNullsFirst = "NULLS FIRST"
- show OrderNullsLast = "NULLS LAST"
-
-data OrderTerm = OrderTerm {
- otTerm :: Field
-, otDirection :: Maybe OrderDirection
-, otNullOrder :: Maybe OrderNulls
-} deriving (Eq)
-
-{-|
- Represents a pg identifier with a prepended schema name "schema.table"
- When qiSchema is "", the schema is defined by the pg search_path
--}
-data QualifiedIdentifier = QualifiedIdentifier {
- qiSchema :: Schema
-, qiName :: TableName
-} deriving (Eq, Ord, Generic, JSON.ToJSON, JSON.ToJSONKey)
-instance Hashable QualifiedIdentifier
-
--- | The relationship [cardinality](https://en.wikipedia.org/wiki/Cardinality_(data_modeling)).
--- | TODO: missing one-to-one
-data Cardinality = O2M -- ^ one-to-many, previously known as Parent
- | M2O -- ^ many-to-one, previously known as Child
- | M2M -- ^ many-to-many, previously known as Many
- deriving (Eq, Generic, JSON.ToJSON)
-instance Show Cardinality where
- show O2M = "o2m"
- show M2O = "m2o"
- show M2M = "m2m"
-
-{-|
- "Relation"ship between two tables.
- The order of the relColumns and relFColumns should be maintained to get the join conditions right.
- TODO merge relColumns and relFColumns to a tuple or Data.Bimap
--}
-data Relation = Relation {
- relTable :: Table
-, relColumns :: [Column]
-, relFTable :: Table
-, relFColumns :: [Column]
-, relType :: Cardinality
-, relLink :: Link -- ^ Constraint on O2M/M2O, Junction for M2M Cardinality
-} deriving (Eq, Generic, JSON.ToJSON)
-
-type ConstraintName = Text
-
--- | Junction table on an M2M relationship
-data Link
- = Constraint { constName :: ConstraintName }
- | Junction {
- junTable :: Table
- , junLink1 :: Link
- , junCols1 :: [Column]
- , junLink2 :: Link
- , junCols2 :: [Column]
- }
- deriving (Eq, Generic, JSON.ToJSON)
-
-isSelfReference :: Relation -> Bool
-isSelfReference r = relTable r == relFTable r
-
-data PayloadJSON =
- -- | Cached attributes of a JSON payload
- ProcessedJSON {
- -- | This is the raw ByteString that comes from the request body.
- -- We cache this instead of an Aeson Value because it was detected that for large payloads the encoding
- -- had high memory usage, see https://github.com/PostgREST/postgrest/pull/1005 for more details
- pjRaw :: BL.ByteString
- -- | Keys of the object or if it's an array these keys are guaranteed to be the same across all its objects
- , pjKeys :: S.Set Text
- }|
- RawJSON {
- pjRaw :: BL.ByteString
- }
-
-data PJType = PJArray { pjaLength :: Int } | PJObject
-
-data Proxy = Proxy {
- proxyScheme :: Text
-, proxyHost :: Text
-, proxyPort :: Integer
-, proxyPath :: Text
-}
-
-type Operator = Text
-operators :: M.HashMap Operator SqlFragment
-operators = M.union (M.fromList [
- ("eq", "="),
- ("gte", ">="),
- ("gt", ">"),
- ("lte", "<="),
- ("lt", "<"),
- ("neq", "<>"),
- ("like", "LIKE"),
- ("ilike", "ILIKE"),
- ("in", "IN"),
- ("is", "IS"),
- ("cs", "@>"),
- ("cd", "<@"),
- ("ov", "&&"),
- ("sl", "<<"),
- ("sr", ">>"),
- ("nxr", "&<"),
- ("nxl", "&>"),
- ("adj", "-|-")]) ftsOperators
-
-ftsOperators :: M.HashMap Operator SqlFragment
-ftsOperators = M.fromList [
- ("fts", "@@ to_tsquery"),
- ("plfts", "@@ plainto_tsquery"),
- ("phfts", "@@ phraseto_tsquery"),
- ("wfts", "@@ websearch_to_tsquery")
- ]
-
-data OpExpr = OpExpr Bool Operation deriving (Eq)
-data Operation = Op Operator SingleVal |
- In ListVal |
- Fts Operator (Maybe Language) SingleVal deriving (Eq)
-type Language = Text
-
--- | Represents a single value in a filter, e.g. id=eq.singleval
-type SingleVal = Text
--- | Represents a list value in a filter, e.g. id=in.(val1,val2,val3)
-type ListVal = [Text]
-
-data LogicOperator = And | Or deriving Eq
-instance Show LogicOperator where
- show And = "AND"
- show Or = "OR"
-{-|
- Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is:
-
- And
- / \
- name.eq.N Or
- / \
- id.eq.1 id.eq.2
--}
-data LogicTree = Expr Bool LogicOperator [LogicTree] | Stmnt Filter deriving (Eq)
-
-type FieldName = Text
-{-|
- Json path operations as specified in https://www.postgresql.org/docs/current/static/functions-json.html
--}
-type JsonPath = [JsonOperation]
--- | Represents the single arrow `->` or double arrow `->>` operators
-data JsonOperation = JArrow{jOp :: JsonOperand} | J2Arrow{jOp :: JsonOperand} deriving (Eq)
--- | Represents the key(`->'key'`) or index(`->'1`::int`), the index is Text because we reuse our escaping functons and let pg do the casting with '1'::int
-data JsonOperand = JKey{jVal :: Text} | JIdx{jVal :: Text} deriving (Eq)
-
-type Field = (FieldName, JsonPath)
-type Alias = Text
-type Cast = Text
-type NodeName = Text
-
-
-{-|
- Custom guc header, it's obtained by parsing the json in a:
- `SET LOCAL "response.headers" = '[{"Set-Cookie": ".."}]'
--}
-newtype GucHeader = GucHeader (CI.CI ByteString, ByteString)
-
-instance JSON.FromJSON GucHeader where
- parseJSON (JSON.Object o) = case headMay (M.toList o) of
- Just (k, JSON.String s) | M.size o == 1 -> pure $ GucHeader (CI.mk $ toS k, toS s)
- | otherwise -> mzero
- _ -> mzero
- parseJSON _ = mzero
-
-unwrapGucHeader :: GucHeader -> Header
-unwrapGucHeader (GucHeader (k, v)) = (k, v)
-
--- | Add headers not already included to allow the user to override them instead of duplicating them
-addHeadersIfNotIncluded :: [Header] -> [Header] -> [Header]
-addHeadersIfNotIncluded newHeaders initialHeaders =
- filter (\(nk, _) -> isNothing $ find (\(ik, _) -> ik == nk) initialHeaders) newHeaders ++
- initialHeaders
-
-{-|
- This type will hold information about which particular 'Relation' between two tables to choose when there are multiple ones.
- Specifically, it will contain the name of the foreign key or the join table in many to many relations.
--}
-type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe EmbedHint)
--- | Disambiguates an embedding operation when there's multiple relationships between two tables.
--- | Can be the name of a foreign key constraint, column name or the junction in an m2m relationship.
-type EmbedHint = Text
--- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path ["clients", "projects"]
-type EmbedPath = [Text]
-data Filter = Filter { field::Field, opExpr::OpExpr } deriving (Eq)
-data JoinCondition = JoinCondition (QualifiedIdentifier, FieldName)
- (QualifiedIdentifier, FieldName) deriving (Eq)
-
-data ReadQuery = Select {
- select :: [SelectItem]
- , from :: QualifiedIdentifier
--- | A table alias is used in case of self joins
- , fromAlias :: Maybe Alias
--- | Only used for Many to Many joins. Parent and Child joins use explicit joins.
- , implicitJoins :: [QualifiedIdentifier]
- , where_ :: [LogicTree]
- , joinConditions :: [JoinCondition]
- , order :: [OrderTerm]
- , range_ :: NonnegRange
-} deriving (Eq)
-
-data MutateQuery =
- Insert {
- in_ :: QualifiedIdentifier
- , insCols :: S.Set FieldName
- , insBody :: Maybe BL.ByteString
- , onConflict :: Maybe (PreferResolution, [FieldName])
- , where_ :: [LogicTree]
- , returning :: [FieldName]
- }|
- Update {
- in_ :: QualifiedIdentifier
- , updCols :: S.Set FieldName
- , updBody :: Maybe BL.ByteString
- , where_ :: [LogicTree]
- , returning :: [FieldName]
- }|
- Delete {
- in_ :: QualifiedIdentifier
- , where_ :: [LogicTree]
- , returning :: [FieldName]
- }
-
-type ReadRequest = Tree ReadNode
-type MutateRequest = MutateQuery
-
-type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe EmbedHint, Depth))
-type Depth = Integer
-
--- First level FieldNames(e.g get a,b from /table?select=a,b,other(c,d))
-fstFieldNames :: ReadRequest -> [FieldName]
-fstFieldNames (Node (sel, _) _) =
- fst . view _1 <$> select sel
-
-data PgVersion = PgVersion {
- pgvNum :: Int32
-, pgvName :: Text
-} deriving (Eq, Generic, JSON.ToJSON)
-
-instance Ord PgVersion where
- (PgVersion v1 _) `compare` (PgVersion v2 _) = v1 `compare` v2
-
--- | Tells the minimum PostgreSQL version required by this version of PostgREST
-minimumPgVersion :: PgVersion
-minimumPgVersion = pgVersion95
-
-pgVersion95 :: PgVersion
-pgVersion95 = PgVersion 90500 "9.5"
-
-pgVersion96 :: PgVersion
-pgVersion96 = PgVersion 90600 "9.6"
-
-pgVersion100 :: PgVersion
-pgVersion100 = PgVersion 100000 "10"
-
-pgVersion109 :: PgVersion
-pgVersion109 = PgVersion 100009 "10.9"
-
-pgVersion110 :: PgVersion
-pgVersion110 = PgVersion 110000 "11.0"
-
-pgVersion112 :: PgVersion
-pgVersion112 = PgVersion 110002 "11.2"
-
-pgVersion114 :: PgVersion
-pgVersion114 = PgVersion 110004 "11.4"
-
-pgVersion121 :: PgVersion
-pgVersion121 = PgVersion 120001 "12.1"
-
-pgVersion130 :: PgVersion
-pgVersion130 = PgVersion 130000 "13.0"
-
-sourceCTEName :: SqlFragment
-sourceCTEName = "pgrst_source"
-
--- | full jspath, e.g. .property[0].attr.detail
-type JSPath = [JSPathExp]
--- | jspath expression, e.g. .property, .property[0] or ."property-dash"
-data JSPathExp = JSPKey Text | JSPIdx Int
-
-instance Show JSPathExp where
- -- TODO: this needs to be quoted properly for special chars
- show (JSPKey k) = "." <> show k
- show (JSPIdx i) = "[" <> show i <> "]"
-
--- | Current database connection status data ConnectionStatus
-data ConnectionStatus
- = NotConnected
- | Connected PgVersion
- | FatalConnectionError Text
- deriving (Eq)
-
--- | Schema cache status
-data SCacheStatus
- = SCLoaded
- | SCOnRetry
- | SCFatalFail
-
-data LogLevel = LogCrit | LogError | LogWarn | LogInfo
-
-instance Show LogLevel where
- show LogCrit = "crit"
- show LogError = "error"
- show LogWarn = "warn"
- show LogInfo = "info"
diff --git a/test/Feature/AndOrParamsSpec.hs b/test/Feature/AndOrParamsSpec.hs
index 83e33f78f..0e4abea34 100644
--- a/test/Feature/AndOrParamsSpec.hs
+++ b/test/Feature/AndOrParamsSpec.hs
@@ -7,8 +7,9 @@ import Test.Hspec
import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
-import PostgREST.Types (PgVersion, pgVersion112)
-import Protolude hiding (get)
+import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion112)
+
+import Protolude hiding (get)
import SpecHelper
spec :: PgVersion -> SpecWith ((), Application)
diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs
index 765bf54ba..e843ee10f 100644
--- a/test/Feature/AuthSpec.hs
+++ b/test/Feature/AuthSpec.hs
@@ -7,8 +7,9 @@ import Test.Hspec
import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
-import PostgREST.Types (PgVersion, pgVersion112)
-import Protolude hiding (get)
+import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion112)
+
+import Protolude hiding (get)
import SpecHelper
spec :: PgVersion -> SpecWith ((), Application)
diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs
index ff6765142..7f007d1bc 100644
--- a/test/Feature/InsertSpec.hs
+++ b/test/Feature/InsertSpec.hs
@@ -11,8 +11,10 @@ import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
import Text.Heredoc
-import PostgREST.Types (PgVersion, pgVersion112, pgVersion130)
-import Protolude hiding (get)
+import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion112,
+ pgVersion130)
+
+import Protolude hiding (get)
import SpecHelper
spec :: PgVersion -> SpecWith ((), Application)
diff --git a/test/Feature/JsonOperatorSpec.hs b/test/Feature/JsonOperatorSpec.hs
index ba7a0e63a..3a032a17e 100644
--- a/test/Feature/JsonOperatorSpec.hs
+++ b/test/Feature/JsonOperatorSpec.hs
@@ -7,9 +7,10 @@ import Test.Hspec
import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
-import PostgREST.Types (PgVersion, pgVersion112, pgVersion121,
- pgVersion95)
-import Protolude hiding (get)
+import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion112,
+ pgVersion121, pgVersion95)
+
+import Protolude hiding (get)
import SpecHelper
spec :: PgVersion -> SpecWith ((), Application)
diff --git a/test/Feature/MultipleSchemaSpec.hs b/test/Feature/MultipleSchemaSpec.hs
index 3355578b1..6c781fff8 100644
--- a/test/Feature/MultipleSchemaSpec.hs
+++ b/test/Feature/MultipleSchemaSpec.hs
@@ -15,7 +15,7 @@ import Test.Hspec.Wai.JSON
import Protolude
import SpecHelper
-import PostgREST.Types (PgVersion, pgVersion96)
+import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion96)
spec :: PgVersion -> SpecWith ((), Application)
spec actualPgVersion =
diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs
index e7098f70a..3733d3023 100644
--- a/test/Feature/QuerySpec.hs
+++ b/test/Feature/QuerySpec.hs
@@ -8,9 +8,9 @@ import Test.Hspec hiding (pendingWith)
import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
-import PostgREST.Types (PgVersion, pgVersion112, pgVersion121,
- pgVersion96)
-import Protolude hiding (get)
+import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion112,
+ pgVersion121, pgVersion96)
+import Protolude hiding (get)
import SpecHelper
spec :: PgVersion -> SpecWith ((), Application)
diff --git a/test/Feature/RpcSpec.hs b/test/Feature/RpcSpec.hs
index 052ca437a..893559c86 100644
--- a/test/Feature/RpcSpec.hs
+++ b/test/Feature/RpcSpec.hs
@@ -11,10 +11,12 @@ import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
import Text.Heredoc
-import PostgREST.Types (PgVersion, pgVersion100, pgVersion109,
- pgVersion110, pgVersion112, pgVersion114,
- pgVersion96)
-import Protolude hiding (get)
+import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion100,
+ pgVersion109, pgVersion110,
+ pgVersion112, pgVersion114,
+ pgVersion96)
+
+import Protolude hiding (get)
import SpecHelper
spec :: PgVersion -> SpecWith ((), Application)
diff --git a/test/Main.hs b/test/Main.hs
index 698ed9ace..6e498e786 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -12,12 +12,12 @@ import Data.Time.Clock (getCurrentTime)
import Data.IORef
import Test.Hspec
-import PostgREST.App (postgrest)
-import PostgREST.Config (AppConfig (..))
-import PostgREST.DbStructure (getDbStructure, getPgVersion)
-import PostgREST.Types (LogLevel (..), pgVersion96)
-import Protolude hiding (toList, toS)
-import Protolude.Conv (toS)
+import PostgREST.App (postgrest)
+import PostgREST.Config (AppConfig (..), LogLevel (..))
+import PostgREST.DbStructure (getDbStructure, getPgVersion)
+import PostgREST.DbStructure.PgVersion (pgVersion96)
+import Protolude hiding (toList, toS)
+import Protolude.Conv (toS)
import SpecHelper
import qualified Feature.AndOrParamsSpec
diff --git a/test/QueryCost.hs b/test/QueryCost.hs
index eb118111c..dc902499a 100644
--- a/test/QueryCost.hs
+++ b/test/QueryCost.hs
@@ -14,8 +14,12 @@ import Text.Heredoc
import Protolude hiding (get, toS)
import Protolude.Conv (toS)
-import PostgREST.QueryBuilder (requestToCallProcQuery)
-import PostgREST.Types
+import PostgREST.Query.QueryBuilder (requestToCallProcQuery)
+import PostgREST.Request.ApiRequest (PayloadJSON (..))
+
+import PostgREST.DbStructure.Identifiers
+import PostgREST.DbStructure.Proc
+import PostgREST.Request.Preferences
import SpecHelper (getEnvVarWithDefault)
diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs
index decd16f2d..b2bfec2bc 100644
--- a/test/SpecHelper.hs
+++ b/test/SpecHelper.hs
@@ -22,8 +22,8 @@ import Test.Hspec
import Test.Hspec.Wai
import Text.Heredoc
-import PostgREST.Config (AppConfig (..), parseSecret)
-import PostgREST.Types (JSPathExp (..), LogLevel (..))
+import PostgREST.Config (AppConfig (..), JSPathExp (..),
+ LogLevel (..), parseSecret)
import Protolude hiding (toS)
import Protolude.Conv (toS)