refactor: Split up Types.hs and logically organize modules (#1793)

main/Main.hs

@@ -32,13 +32,14 @@ import Text.Printf              (hPrintf)
 
 import PostgREST.App                   (postgrest)
 import PostgREST.Config
-import PostgREST.DbStructure (getDbStructure, getPgVersion)
+import PostgREST.DbStructure           (DbStructure, getDbStructure,
-import PostgREST.Error       (PgError (PgError), checkIsFatal,
+                                        getPgVersion)
-                              errorPayload)
+import PostgREST.DbStructure.PgVersion (PgVersion (..),
-import PostgREST.Statements  (dbSettingsStatement)
-import PostgREST.Types       (ConnectionStatus (..), DbStructure,
-                              PgVersion (..), SCacheStatus (..),
                                         minimumPgVersion)
+import PostgREST.Error                 (PgError (PgError),
+                                        checkIsFatal, errorPayload)
+import PostgREST.Query.Statements      (dbSettingsStatement)
+
 import Protolude      hiding (hPutStrLn, head, toS)
 import Protolude.Conv (toS)
 
@@ -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

postgrest.cabal

@@ -34,24 +34,32 @@ library
   default-extensions: OverloadedStrings
                       NoImplicitPrelude
   hs-source-dirs:     src
-  exposed-modules:    PostgREST.ApiRequest
+  exposed-modules:    PostgREST.App
-                      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.Query.QueryBuilder
-                      PostgREST.QueryBuilder
+                      PostgREST.Query.SqlFragment
-                      PostgREST.Statements
+                      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

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.Query.QueryBuilder       as QueryBuilder
+import qualified PostgREST.Query.Statements         as Statements
 import qualified PostgREST.RangeQuery               as RangeQuery
-import qualified PostgREST.Statements       as Statements
+import qualified PostgREST.Request.ApiRequest       as ApiRequest
+import qualified PostgREST.Request.DbRequestBuilder as ReqBuilder
 
-import PostgREST.ApiRequest (Action (..), ApiRequest (..),
+import PostgREST.Config                  (AppConfig (..),
-                             InvokeMethod (..), Target (..))
+                                          LogLevel (..))
-import PostgREST.Config     (AppConfig (..))
+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{..} =

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
 

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,30 +65,24 @@ 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 Control.Applicative
-import Data.Monoid
-import Options.Applicative hiding (str)
 import Text.Heredoc            (str)
 
-import PostgREST.Parsers          (pRoleClaimKey)
+import PostgREST.Config.JSPath (JSPath, JSPathExp (..), pRoleClaimKey)
-import PostgREST.Private.ProxyUri (isMalformedProxyUri)
+import PostgREST.Config.Proxy  (Proxy (..), isMalformedProxyUri,
-import PostgREST.Types            (JSPath, JSPathExp (..),
+                                toURI)
-                                   LogLevel (..))
+
-import Protolude                  hiding (concat, filter, hPutStrLn,
+import Protolude      hiding (Proxy, toList, toS)
-                                   intercalate, null, replace, take,
-                                   toList, toLower, toS, toTitle,
-                                   (<>))
 import Protolude.Conv (toS)
 
 -- | Command line interface options
@@ -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-channel-enabled",            T.toLower . show . configDbChannelEnabled)
-      ,("db-extra-search-path",      q . intercalate "," . configDbExtraSearchPath)
+      ,("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-schemas",                q . T.intercalate "," . toList . configDbSchemas)
-      ,("db-config",                 q . toLower . show . configDbConfig)
+      ,("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",        q . maybe mempty T.pack . configServerUnixSocket)
-      ,("server-unix-socket-mode",   q . pack . showSocketMode)
+      ,("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)

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 '"')

src/PostgREST/Config/Proxy.hs

@@ -3,8 +3,9 @@
 Module      : PostgREST.Private.ProxyUri
 Description : Proxy Uri validator
 -}
-module PostgREST.Private.ProxyUri (
+module PostgREST.Config.Proxy
-  isMalformedProxyUri
+  ( Proxy(..)
+  , isMalformedProxyUri
   , toURI
   ) where
 
@@ -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,

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'

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 (
+module PostgREST.DbStructure
-  getDbStructure
+  ( 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 Text.InterpolatedString.Perl6 (q)
+
+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)
-import Text.InterpolatedString.Perl6 (q)
 
-import PostgREST.Private.Common
+
-import PostgREST.Types
+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

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

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"

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

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

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)

src/PostgREST/Error.hs

@@ -5,8 +5,8 @@ Description : PostgREST error HTTP responses
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE RecordWildCards #-}
 
-module PostgREST.Error (
+module PostgREST.Error
-  errorResponseFor
+  ( errorResponseFor
   , ApiRequestError(..)
   , PgError(..)
   , Error(..)
@@ -24,9 +24,14 @@ 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.ContentType (ContentType (..))
+import qualified PostgREST.ContentType as ContentType
+
+import PostgREST.DbStructure.Relation (Link (..), Relation (..))
+import PostgREST.DbStructure.Table    (Column (..), Table (..))
 
-import PostgREST.Types
 import Protolude      hiding (toS)
 import Protolude.Conv (toS, toSL)
 
@@ -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]
+       then [ContentType.toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header]
-       else [toHeader CTApplicationJSON]
+       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 (SingularityError _)     = [ContentType.toHeader CTSingularJSON]
-  headers (JwtTokenInvalid m)      = [toHeader CTApplicationJSON, invalidTokenHeader m]
+  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)]

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

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           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.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           Network.HTTP.Types.Status (Status, status400,
-                                            status500, statusCode)
 import qualified Network.Wai                          as Wai
-import           Network.Wai.Logger        (showSockAddr)
+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 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 PostgREST.Config             (AppConfig (..), LogLevel (..))
-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 qualified PostgREST.Types as Types
-
-import PostgREST.ApiRequest   (ApiRequest (..))
-import PostgREST.Config       (AppConfig (..))
 import PostgREST.Error              (Error, errorResponseFor)
-import PostgREST.QueryBuilder (setConfigLocal)
+import PostgREST.GucHeader          (addHeadersIfNotIncluded)
-import PostgREST.Types        (LogLevel (..))
+import PostgREST.Query.SqlFragment  (intercalateSnippet,
+                                     unknownLiteral)
+import PostgREST.Request.ApiRequest (ApiRequest (..))
+
+import PostgREST.Request.Preferences
+
 import Protolude      hiding (head, toS)
 import Protolude.Conv (toS)
-import System.IO.Unsafe       (unsafePerformIO)
 
 -- | 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 Wai.Response) ->
-               ApiRequest  -> ExceptT Error H.Transaction 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
+  . Wai.gzip Wai.def
-  . cors corsPolicy
+  . Wai.cors corsPolicy
-  . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
+  . Wai.staticPolicy (Wai.only [("favicon.ico", "static/favicon.ico")])
   where
     logger = case logLevel of
       LogCrit  -> id
-      LogError -> unsafePerformIO $ mkRequestLogger def { outputFormat = CustomOutputFormat $ pgrstFormat status500}
+      LogError -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status500}
-      LogWarn  -> unsafePerformIO $ mkRequestLogger def { outputFormat = CustomOutputFormat $ pgrstFormat status400}
+      LogWarn  -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status400}
-      LogInfo  -> logStdout
+      LogInfo  -> Wai.logStdout
 
-defaultCorsPolicy :: CorsResourcePolicy
+defaultCorsPolicy :: Wai.CorsResourcePolicy
-defaultCorsPolicy =  CorsResourcePolicy Nothing
+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)
+      Wai.corsOrigins = Just ([origin], True)
-    , corsRequestHeaders = "Authentication":accHeaders
+    , Wai.corsRequestHeaders = "Authentication" : accHeaders
-    , corsExposedHeaders = Just [
+    , 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
+          addHeadersIfNotIncluded
-            [(HTTP.hPreferenceApplied, BS.pack (show Types.Commit))]
+            [(HTTP.hPreferenceApplied, BS.pack (show Commit))]
       | shouldRollback =
-          Types.addHeadersIfNotIncluded
+          addHeadersIfNotIncluded
-            [(HTTP.hPreferenceApplied, BS.pack (show Types.Rollback))]
+            [(HTTP.hPreferenceApplied, BS.pack (show Rollback))]
       | otherwise =
           identity

src/PostgREST/OpenAPI.hs

@@ -9,31 +9,33 @@ 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 (..), Proxy (..),
-import PostgREST.Config           (AppConfig (..), docsVersion,
+                                       docsVersion,
-                                   prettyVersion)
+                                       isMalformedProxyUri,
-import PostgREST.Private.ProxyUri (isMalformedProxyUri, toURI)
+                                       prettyVersion, toURI)
-import PostgREST.Types            (Column (..), DbStructure (..),
+import PostgREST.DbStructure          (DbStructure (..), tableCols,
-                                   ForeignKey (..), PgArg (..),
+                                       tablePKCols)
-                                   PrimaryKey (..),
+import PostgREST.DbStructure.Proc     (PgArg (..),
-                                   ProcDescription (..), Proxy (..),
+                                       ProcDescription (..))
-                                   Table (..), tableCols, tableName,
+import PostgREST.DbStructure.Relation (PrimaryKey (..))
-                                   tablePKCols, tableSchema, toMime)
+import PostgREST.DbStructure.Table    (Column (..), ForeignKey (..),
-import Protolude                  hiding (Proxy, dropWhile, get,
+                                       Table (..))
-                                   intercalate, toLower, toS, (&))
+
+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
@@ -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)
+        & properties .~ fromList (fmap (makeProperty pks) cs)
-        & required .~ map colName (filter (not . colNullable) 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, "`.<fk table='", a, "' column='", b, "'/>"]
+      T.intercalate "" ["This is a Foreign Key to `", a, ".", b, "`.<fk table='", a, "' column='", 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))
+  & properties .~ fromList (fmap makeProcProperty (pdArgs pd))
-  & required .~ map pgaName (filter pgaReq (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) $
+    (tSum, tDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $
-                    breakOn "\n" <$> tableDescription t
+                    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) $
+    (pSum, pDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $
-                    breakOn "\n" <$> pdDescription pd
+                    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{..} =

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 (
+module PostgREST.Query.QueryBuilder
-    readRequestToQuery
+  ( 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.DbStructure.Identifiers (FieldName,
-import PostgREST.Private.Common
+                                          QualifiedIdentifier (..))
-import PostgREST.Private.QueryFragment
+import PostgREST.DbStructure.Proc        (PgArg (..))
-import PostgREST.Types
+import PostgREST.DbStructure.Relation    (Cardinality (..),
-import Protolude                       hiding (cast, intercalate,
+                                          Relation (..))
-                                        replace)
+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)"

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,
+import qualified Data.ByteString.Char8           as BS
-                                                        pack, unwords)
 import qualified Data.ByteString.Lazy            as BL
 import qualified Data.HashMap.Strict             as HM
-import           Data.Maybe
+import qualified Data.Text                       as T
-import qualified Data.Text                       as T (intercalate,
-                                                       isInfixOf, map,
-                                                       null, replace,
-                                                       takeWhile,
-                                                       toLower)
 import qualified Hasql.DynamicStatements.Snippet as H
-import           PostgREST.RangeQuery            (NonnegRange,
+import qualified Hasql.Encoders                  as HE
-                                                  allRange,
+
-                                                  rangeLimit,
+import Data.Foldable                 (foldr1)
-                                                  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 PostgREST.DbStructure.Identifiers (FieldName,
-import           PostgREST.Private.Common
+                                          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

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 (
+module PostgREST.Query.Statements
-    createWriteStatement
+  ( createWriteStatement
   , createReadStatement
   , callProcStatement
   , createExplainStatement
   , dbSettingsStatement
   ) where
 
-
+import qualified Data.Aeson                        as JSON
-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)
-
 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

src/PostgREST/Request/ApiRequest.hs

@@ -1,17 +1,18 @@
 {-|
-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 (
+module PostgREST.Request.ApiRequest
-  ApiRequest(..)
+  ( ApiRequest(..)
   , InvokeMethod(..)
   , ContentType(..)
   , Action(..)
   , Target(..)
+  , PayloadJSON(..)
   , mutuallyAgreeable
   , userApiRequest
   ) where
@@ -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 Data.Ranged.Boundaries
+import PostgREST.DbStructure             (DbStructure (..))
-
+import PostgREST.DbStructure.Identifiers (FieldName,
+                                          QualifiedIdentifier (..),
+                                          Schema)
+import PostgREST.DbStructure.Proc        (PgArg (..),
+                                          ProcDescription (..),
+                                          findProc)
 import PostgREST.Error                   (ApiRequestError (..))
-import PostgREST.Parsers    (pRequestColumns)
+import PostgREST.Query.SqlFragment       (ftsOperators, operators)
-import PostgREST.RangeQuery (NonnegRange, allRange, rangeGeq,
+import PostgREST.RangeQuery              (NonnegRange, allRange,
-                             rangeLimit, rangeOffset, rangeRequested,
+                                          rangeGeq, rangeLimit,
+                                          rangeOffset, rangeRequested,
                                           restrictRange)
-import PostgREST.Types
+import PostgREST.Request.Parsers         (pRequestColumns)
+import PostgREST.Request.Preferences     (PreferCount (..),
+                                          PreferParameters (..),
+                                          PreferRepresentation (..),
+                                          PreferResolution (..),
+                                          PreferTransaction (..))
+
+import qualified PostgREST.ContentType as ContentType
+
 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

src/PostgREST/Request/DbRequestBuilder.hs

@@ -1,18 +1,22 @@
 {-|
-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 (
+module PostgREST.Request.DbRequestBuilder
-  readRequest
+  ( readRequest
   , mutateRequest
   , returningCols
   ) where
@@ -24,15 +28,30 @@ import Control.Arrow           ((***))
 import Data.Either.Combinators (mapLeft)
 import Data.List               (delete)
 import Data.Text               (isInfixOf)
+import Data.Tree               (Tree (..))
 
-import Control.Applicative
+import PostgREST.DbStructure.Identifiers (FieldName,
-import Data.Tree
+                                          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.Request.Parsers
+import PostgREST.Request.Preferences
+import PostgREST.Request.Types
+
+import qualified PostgREST.DbStructure.Relation as Relation
 
-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)
 
 -- | Builds the ReadRequest tree on a number of stages.
@@ -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).
+-- This is done because of the shape of the final SQL Query. The mutation cases
--- So we need a FROM {sourceCTEName} instead of FROM {tableName}.
+-- 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
+    -- To enable embedding in the sourceCTEName cases we need to replace the
-    -- with {sourceCTEName}. This way findRel can find relationships with sourceCTEName.
+    -- 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
+-- Build the initial tree with a Depth attribute so when a self join occurs we
--- an alias like "table_depth", this is related to http://github.com/PostgREST/postgrest/issues/987.
+-- 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(*)
+-- Finds a relationship between an origin and a target in the request:
--- If more than one relationship is found then the request is ambiguous and we return an error.
+-- /origin?select=target(*) If more than one relationship is found then the
--- In that case the request can be disambiguated by adding precision to the target or by using a hint: /origin?select=target!hint(*)
+-- request is ambiguous and we return an error.  In that case the request can
--- The elements will be matched according to these rules:
+-- 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:
+      -- Here we handle a self reference relationship to not cause a breaking
-      -- In a self reference we get two relationships with the same foreign key and relTable/relFtable but with different cardinalities(m2o/o2m)
+      -- change: In a self reference we get two relationships with the same
-      -- We output the O2M rel, the M2O rel can be obtained by using the origin column as an embed hint.
+      -- 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}
+    -- On mutation and calling proc cases we wrap the target table in a WITH
-    -- if this happens remove the schema `FROM "schema"."{sourceCTEName}"` and use only the
+    -- {sourceCTEName} if this happens remove the schema `FROM
-    -- `FROM "{sourceCTEName}"`. If the schema remains the FROM would be invalid.
+    -- "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
+    -- Without fkCols, when a mutateRequest to
-    -- `RETURNING name`(see QueryBuilder).
+    -- /projects?select=name,clients(name) occurs, the RETURNING SQL part would
-    -- This would make the embedding fail because the following JOIN would need the "client_id" column from projects.
+    -- be `RETURNING name`(see QueryBuilder).  This would make the embedding
-    -- So this adds the foreign key columns to ensure the embedding succeeds, result would be `RETURNING name, client_id`.
+    -- fail because the following JOIN would need the "client_id" column from
-    -- This also works for the other relType's.
+    -- 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)
+    -- However if the "client_id" is present, e.g. mutateRequest to
-    -- we would get `RETURNING client_id, name, client_id` and then we would produce the "column reference \"client_id\" is ambiguous"
+    -- /projects?select=client_id,name,clients(name) we would get `RETURNING
-    -- error from PostgreSQL. So we deduplicate with Set:
+    -- client_id, name, client_id` and then we would produce the "column
-    -- We are adding the primary key columns as well to make sure, that a proper location header can always be built for INSERT/POST
+    -- 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

src/PostgREST/Request/Parsers.hs

@@ -1,10 +1,26 @@
 {-|
-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
@@ -13,17 +29,25 @@ 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.Tree                     (Tree (..))
-
+import Text.Parsec.Error             (errorMessages,
-import Data.Tree
+                                      showErrorMessages)
-import Text.Parsec.Error
+import Text.ParserCombinators.Parsec (GenParser, ParseError, Parser,
-import Text.ParserCombinators.Parsec hiding (many, (<|>))
+                                      anyChar, between, char, digit,
+                                      eof, errorPos, letter,
+                                      lookAhead, many1, noneOf,
+                                      notFollowedBy, oneOf, option,
+                                      optionMaybe, parse, sepBy1,
+                                      string, try, (<?>))
 
+import PostgREST.DbStructure.Identifiers (FieldName)
 import PostgREST.Error                   (ApiRequestError (ParseRequestError))
+import PostgREST.Query.SqlFragment       (ftsOperators, operators)
 import PostgREST.RangeQuery              (NonnegRange)
-import PostgREST.Types
+
-import Protolude            hiding (intercalate, option, replace, toS,
+import PostgREST.Request.Types
-                             try)
+
+import Protolude      hiding (intercalate, option, replace, toS, try)
 import Protolude.Conv (toS)
 
 pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem]
@@ -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]"

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"

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]

src/PostgREST/Types.hs

@@ -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"

test/Feature/AndOrParamsSpec.hs

@@ -7,7 +7,8 @@ import Test.Hspec
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 
-import PostgREST.Types (PgVersion, pgVersion112)
+import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion112)
+
 import Protolude  hiding (get)
 import SpecHelper
 

test/Feature/AuthSpec.hs

@@ -7,7 +7,8 @@ import Test.Hspec
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 
-import PostgREST.Types (PgVersion, pgVersion112)
+import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion112)
+
 import Protolude  hiding (get)
 import SpecHelper
 

test/Feature/InsertSpec.hs

@@ -11,7 +11,9 @@ import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 import Text.Heredoc
 
-import PostgREST.Types (PgVersion, pgVersion112, pgVersion130)
+import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion112,
+                                        pgVersion130)
+
 import Protolude  hiding (get)
 import SpecHelper
 

test/Feature/JsonOperatorSpec.hs

@@ -7,8 +7,9 @@ import Test.Hspec
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 
-import PostgREST.Types (PgVersion, pgVersion112, pgVersion121,
+import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion112,
-                        pgVersion95)
+                                        pgVersion121, pgVersion95)
+
 import Protolude  hiding (get)
 import SpecHelper
 

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 =

test/Feature/QuerySpec.hs

@@ -8,8 +8,8 @@ import Test.Hspec          hiding (pendingWith)
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 
-import PostgREST.Types (PgVersion, pgVersion112, pgVersion121,
+import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion112,
-                        pgVersion96)
+                                        pgVersion121, pgVersion96)
 import Protolude                       hiding (get)
 import SpecHelper
 

test/Feature/RpcSpec.hs

@@ -11,9 +11,11 @@ import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 import Text.Heredoc
 
-import PostgREST.Types (PgVersion, pgVersion100, pgVersion109,
+import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion100,
-                        pgVersion110, pgVersion112, pgVersion114,
+                                        pgVersion109, pgVersion110,
+                                        pgVersion112, pgVersion114,
                                         pgVersion96)
+
 import Protolude  hiding (get)
 import SpecHelper
 

test/Main.hs

@@ -13,9 +13,9 @@ import Data.IORef
 import Test.Hspec
 
 import PostgREST.App                   (postgrest)
-import PostgREST.Config      (AppConfig (..))
+import PostgREST.Config                (AppConfig (..), LogLevel (..))
 import PostgREST.DbStructure           (getDbStructure, getPgVersion)
-import PostgREST.Types       (LogLevel (..), pgVersion96)
+import PostgREST.DbStructure.PgVersion (pgVersion96)
 import Protolude                       hiding (toList, toS)
 import Protolude.Conv                  (toS)
 import SpecHelper

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.Query.QueryBuilder (requestToCallProcQuery)
-import PostgREST.Types
+import PostgREST.Request.ApiRequest (PayloadJSON (..))
+
+import PostgREST.DbStructure.Identifiers
+import PostgREST.DbStructure.Proc
+import PostgREST.Request.Preferences
 
 import SpecHelper (getEnvVarWithDefault)
 

test/SpecHelper.hs

@@ -22,8 +22,8 @@ import Test.Hspec
 import Test.Hspec.Wai
 import Text.Heredoc
 
-import PostgREST.Config (AppConfig (..), parseSecret)
+import PostgREST.Config (AppConfig (..), JSPathExp (..),
-import PostgREST.Types  (JSPathExp (..), LogLevel (..))
+                         LogLevel (..), parseSecret)
 import Protolude        hiding (toS)
 import Protolude.Conv   (toS)