feat: request.spec GUC for db-root-spec

The request.spec GUC contains the schema cache structure in json.

It's only available when the root endpoint(/) is requested and when
db-root-spec is not empty.

Also correct db-root-spec to accept a schema.

src/PostgREST/App.hs

@@ -141,11 +141,12 @@ postgrest logLev appState connWorker =
       conf <- AppState.getConfig appState
       maybeDbStructure <- AppState.getDbStructure appState
       pgVer <- AppState.getPgVersion appState
+      jsonDbS <- AppState.getJsonDbS appState
 
       let
         eitherResponse :: IO (Either Error Wai.Response)
         eitherResponse =
-          runExceptT $ postgrestResponse conf maybeDbStructure pgVer (AppState.getPool appState) time req
+          runExceptT $ postgrestResponse conf maybeDbStructure jsonDbS pgVer (AppState.getPool appState) time req
 
       response <- either Error.errorResponseFor identity <$> eitherResponse
 
@@ -159,12 +160,13 @@ postgrest logLev appState connWorker =
 postgrestResponse
   :: AppConfig
   -> Maybe DbStructure
+  -> ByteString
   -> PgVersion
   -> SQL.Pool
   -> UTCTime
   -> Wai.Request
   -> Handler IO Wai.Response
-postgrestResponse conf maybeDbStructure pgVer pool time req = do
+postgrestResponse conf maybeDbStructure jsonDbS pgVer pool time req = do
   body <- lift $ Wai.strictRequestBody req
 
   dbStructure <-
@@ -187,7 +189,7 @@ postgrestResponse conf maybeDbStructure pgVer pool time req = do
 
   runDbHandler pool (txMode apiRequest) jwtClaims .
     Middleware.optionalRollback conf apiRequest $
-      Middleware.runPgLocals conf jwtClaims handleReq apiRequest
+      Middleware.runPgLocals conf jwtClaims handleReq apiRequest jsonDbS
 
 runDbHandler :: SQL.Pool -> SQL.Mode -> Auth.JWTClaims -> DbHandler a -> Handler IO a
 runDbHandler pool mode jwtClaims handler = do

src/PostgREST/AppState.hs

@@ -5,6 +5,7 @@ module PostgREST.AppState
   , getConfig
   , getDbStructure
   , getIsWorkerOn
+  , getJsonDbS
   , getMainThreadId
   , getPgVersion
   , getPool
@@ -14,6 +15,7 @@ module PostgREST.AppState
   , putConfig
   , putDbStructure
   , putIsWorkerOn
+  , putJsonDbS
   , putPgVersion
   , releasePool
   , signalListener
@@ -41,6 +43,8 @@ data AppState = AppState
   , statePgVersion    :: IORef PgVersion
   -- | No schema cache at the start. Will be filled in by the connectionWorker
   , stateDbStructure  :: IORef (Maybe DbStructure)
+  -- | Cached DbStructure in json
+  , stateJsonDbS      :: IORef ByteString
   -- | Helper ref to make sure just one connectionWorker can run at a time
   , stateIsWorkerOn   :: IORef Bool
   -- | Binary semaphore used to sync the listener(NOTIFY reload) with the connectionWorker.
@@ -62,6 +66,7 @@ initWithPool newPool conf =
     -- assume we're in a supported version when starting, this will be corrected on a later step
     <$> newIORef minimumPgVersion
     <*> newIORef Nothing
+    <*> newIORef mempty
     <*> newIORef False
     <*> newEmptyMVar
     <*> newIORef conf
@@ -91,6 +96,12 @@ putDbStructure :: AppState -> DbStructure -> IO ()
 putDbStructure appState structure =
   atomicWriteIORef (stateDbStructure appState) $ Just structure
 
+getJsonDbS :: AppState -> IO ByteString
+getJsonDbS = readIORef . stateJsonDbS
+
+putJsonDbS :: AppState -> ByteString -> IO ()
+putJsonDbS appState = atomicWriteIORef (stateJsonDbS appState)
+
 getIsWorkerOn :: AppState -> IO Bool
 getIsWorkerOn = readIORef . stateIsWorkerOn
 

src/PostgREST/Config.hs

@@ -72,7 +72,7 @@ data AppConfig = AppConfig
   , configDbPoolTimeout         :: NominalDiffTime
   , configDbPreRequest          :: Maybe QualifiedIdentifier
   , configDbPreparedStatements  :: Bool
-  , configDbRootSpec            :: Maybe Text
+  , configDbRootSpec            :: Maybe QualifiedIdentifier
   , configDbSchemas             :: NonEmpty Text
   , configDbConfig              :: Bool
   , configDbTxAllowOverride     :: Bool
@@ -117,7 +117,7 @@ toText conf =
       ,("db-pool-timeout",               show . floor . configDbPoolTimeout)
       ,("db-pre-request",            q . maybe mempty show . configDbPreRequest)
       ,("db-prepared-statements",        T.toLower . show . configDbPreparedStatements)
-      ,("db-root-spec",              q . fromMaybe mempty . configDbRootSpec)
+      ,("db-root-spec",              q . maybe mempty show . configDbRootSpec)
       ,("db-schemas",                q . T.intercalate "," . toList . configDbSchemas)
       ,("db-config",                 q . T.toLower . show . configDbConfig)
       ,("db-tx-end",                 q . showTxEnd)
@@ -202,8 +202,8 @@ parser optPath env dbSettings =
     <*> (fmap toQi <$> optWithAlias (optString "db-pre-request")
                                     (optString "pre-request"))
     <*> (fromMaybe True <$> optBool "db-prepared-statements")
-    <*> optWithAlias (optString "db-root-spec")
+    <*> (fmap toQi <$> optWithAlias (optString "db-root-spec")
-                     (optString "root-spec")
+                                    (optString "root-spec"))
     <*> (fromList . splitOnCommas <$> reqWithAlias (optValue "db-schemas")
                                                    (optValue "db-schema")
                                                    "missing key: either db-schemas or db-schema must be set")

src/PostgREST/Middleware.hs

@@ -43,8 +43,8 @@ import PostgREST.Config             (AppConfig (..), LogLevel (..))
 import PostgREST.Error              (Error, errorResponseFor)
 import PostgREST.GucHeader          (addHeadersIfNotIncluded)
 import PostgREST.Query.SqlFragment  (fromQi, intercalateSnippet,
-                                     unknownLiteral)
+                                     unknownEncoder)
-import PostgREST.Request.ApiRequest (ApiRequest (..))
+import PostgREST.Request.ApiRequest (ApiRequest (..), Target (..))
 
 import PostgREST.Request.Preferences
 
@@ -54,33 +54,35 @@ import Protolude.Conv (toS)
 -- | Runs local(transaction scoped) GUCs for every request, plus the pre-request function
 runPgLocals :: AppConfig   -> M.HashMap Text JSON.Value ->
                (ApiRequest -> ExceptT Error H.Transaction Wai.Response) ->
-               ApiRequest  -> ExceptT Error H.Transaction Wai.Response
+               ApiRequest  -> ByteString -> ExceptT Error H.Transaction Wai.Response
-runPgLocals conf claims app req = do
+runPgLocals conf claims app req jsonDbS = do
   lift $ H.statement mempty $ H.dynamicallyParameterized
-    ("select " <> intercalateSnippet ", " (searchPathSql : roleSql ++ claimsSql ++ [methodSql, pathSql] ++ headersSql ++ cookiesSql ++ appSettingsSql))
+    ("select " <> intercalateSnippet ", " (searchPathSql : roleSql ++ claimsSql ++ [methodSql, pathSql] ++ headersSql ++ cookiesSql ++ appSettingsSql ++ specSql))
     HD.noResult (configDbPreparedStatements conf)
   lift $ traverse_ H.sql preReqSql
   app req
   where
-    methodSql = setConfigLocal mempty ("request.method", toS $ iMethod req)
+    methodSql = setConfigLocal mempty ("request.method", iMethod req)
-    pathSql = setConfigLocal mempty ("request.path", toS $ iPath req)
+    pathSql = setConfigLocal mempty ("request.path", iPath req)
     headersSql = setConfigLocal "request.header." <$> iHeaders req
     cookiesSql = setConfigLocal "request.cookie." <$> iCookies req
     claimsWithRole =
       let anon = JSON.String . toS $ configDbAnonRole conf in -- role claim defaults to anon if not specified in jwt
       M.union claims (M.singleton "role" anon)
-    claimsSql = setConfigLocal "request.jwt.claim." <$> [(c,unquoted v) | (c,v) <- M.toList claimsWithRole]
+    claimsSql = setConfigLocal "request.jwt.claim." <$> [(toS c, toS $ unquoted v) | (c,v) <- M.toList claimsWithRole]
-    roleSql = maybeToList $ (\x -> setConfigLocal mempty ("role", unquoted x)) <$> M.lookup "role" claimsWithRole
+    roleSql = maybeToList $ (\x -> setConfigLocal mempty ("role", toS $ unquoted x)) <$> M.lookup "role" claimsWithRole
-    appSettingsSql = setConfigLocal mempty <$> configAppSettings conf
+    appSettingsSql = setConfigLocal mempty <$> (join bimap toS <$> configAppSettings conf)
     searchPathSql =
       let schemas = T.intercalate ", " (iSchema req : configDbExtraSearchPath conf) in
-      setConfigLocal mempty ("search_path", schemas)
+      setConfigLocal mempty ("search_path", toS schemas)
     preReqSql = (\f -> "select " <> fromQi f <> "();") <$> configDbPreRequest conf
-
+    specSql = case iTarget req of
+      TargetProc{tpIsRootSpec=True} -> [setConfigLocal mempty ("request.spec", jsonDbS)]
+      _                             -> mempty
     -- | Do a pg set_config(setting, value, true) call. This is equivalent to a SET LOCAL.
-    setConfigLocal :: Text -> (Text, Text) -> H.Snippet
+    setConfigLocal :: ByteString -> (ByteString, ByteString) -> H.Snippet
     setConfigLocal prefix (k, v) =
-      "set_config(" <> unknownLiteral (prefix <> k) <> ", " <> unknownLiteral v <> ", true)"
+      "set_config(" <> unknownEncoder (prefix <> k) <> ", " <> unknownEncoder 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.

src/PostgREST/Query/SqlFragment.hs

@@ -32,7 +32,7 @@ module PostgREST.Query.SqlFragment
   , returningF
   , selectBody
   , sourceCTEName
-  , unknownLiteral
+  , unknownEncoder
   , intercalateSnippet
   ) where
 

src/PostgREST/Request/ApiRequest.hs

@@ -42,7 +42,7 @@ import Network.HTTP.Types.URI    (parseQueryReplacePlus,
                                   parseSimpleQuery)
 import Network.Wai               (Request (..))
 import Network.Wai.Parse         (parseHttpAccept)
-import Web.Cookie                (parseCookiesText)
+import Web.Cookie                (parseCookies)
 
 import PostgREST.Config                  (AppConfig (..))
 import PostgREST.ContentType             (ContentType (..))
@@ -152,8 +152,8 @@ data ApiRequest = ApiRequest {
   , iOrder                :: [(Text, Text)]                   -- ^ &order parameters for each level
   , iCanonicalQS          :: ByteString                       -- ^ Alphabetized (canonical) request query string for response URLs
   , iJWT                  :: Text                             -- ^ JSON Web Token
-  , iHeaders              :: [(Text, Text)]                   -- ^ HTTP request headers
+  , iHeaders              :: [(ByteString, ByteString)]       -- ^ HTTP request headers
-  , iCookies              :: [(Text, Text)]                   -- ^ Request Cookies
+  , iCookies              :: [(ByteString, ByteString)]       -- ^ Request Cookies
   , iPath                 :: ByteString                       -- ^ Raw request path
   , iMethod               :: ByteString                       -- ^ Raw request method
   , iProfile              :: Maybe Schema                     -- ^ The request profile for enabling use of multiple schemas. Follows the spec in hhttps://www.w3.org/TR/dx-prof-conneg/ttps://www.w3.org/TR/dx-prof-conneg/.
@@ -202,8 +202,8 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody
         . map (join (***) toS . second (fromMaybe BS.empty))
         $ qString
       , iJWT = tokenStr
-      , iHeaders = [ (toS $ CI.foldedCase k, toS v) | (k,v) <- hdrs, k /= hCookie]
+      , iHeaders = [ (CI.foldedCase k, v) | (k,v) <- hdrs, k /= hCookie]
-      , iCookies = maybe [] parseCookiesText $ lookupHeader "Cookie"
+      , iCookies = maybe [] parseCookies $ lookupHeader "Cookie"
       , iPath = rawPathInfo req
       , iMethod = method
       , iProfile = profile
@@ -309,14 +309,14 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody
   schema = fromMaybe defaultSchema profile
   target =
     let
-      callFindProc proc = findProc (QualifiedIdentifier schema proc) payloadColumns (hasPrefer (show SingleObject)) $ dbProcs dbStructure
+      callFindProc procSch procNam = findProc (QualifiedIdentifier procSch procNam) payloadColumns (hasPrefer (show SingleObject)) $ dbProcs dbStructure
     in
     case path of
       []             -> case configDbRootSpec of
-                        Just pName -> TargetProc (callFindProc pName) True
+                          Just (QualifiedIdentifier pSch pName) -> TargetProc (callFindProc (if pSch == mempty then schema else pSch) pName) True
                           Nothing                               -> TargetDefaultSpec schema
       [table]        -> TargetIdent $ QualifiedIdentifier schema table
-      ["rpc", pName] -> TargetProc (callFindProc pName) False
+      ["rpc", pName] -> TargetProc (callFindProc schema pName) False
       _              -> TargetUnknown
 
   shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionSingleUpsert, ActionInvoke InvPost]

src/PostgREST/Workers.hs

@@ -7,6 +7,7 @@ module PostgREST.Workers
   , listener
   ) where
 
+import qualified Data.Aeson                 as JSON
 import qualified Data.ByteString            as BS
 import qualified Hasql.Connection           as C
 import qualified Hasql.Notifications        as N
@@ -172,6 +173,8 @@ loadSchemaCache appState = do
 
     Right dbStructure -> do
       AppState.putDbStructure appState dbStructure
+      when (isJust configDbRootSpec) $
+        AppState.putJsonDbS appState $ toS $ JSON.encode dbStructure
       putStrLn ("Schema cache loaded" :: Text)
       return SCLoaded
 

test/Feature/RootSpec.hs

@@ -26,5 +26,9 @@ spec =
     it "accepts application/json" $
       request methodGet "/"
         [("Accept", "application/json")] "" `shouldRespondWith`
-        [json| [{"table": "items"}, {"table": "subitems"}] |]
+        [json| {
+            "tableName": "orders_view", "tableSchema": "test",
+            "tableDeletable": true, "tableUpdatable": true,
+            "tableInsertable": true, "tableDescription": null
+          } |]
         { matchHeaders = [matchContentTypeJson] }

test/Main.hs

@@ -1,5 +1,6 @@
 module Main where
 
+import qualified Data.Aeson                 as JSON
 import qualified Hasql.Pool                 as P
 import qualified Hasql.Transaction.Sessions as HT
 
@@ -68,19 +69,25 @@ main = do
   let
     -- For tests that run with the same refDbStructure
     app cfg = do
-      appState <- AppState.initWithPool pool $ cfg testDbConn
+      let config = cfg testDbConn
+      appState <- AppState.initWithPool pool config
       AppState.putPgVersion appState actualPgVersion
       AppState.putDbStructure appState baseDbStructure
+      when (isJust $ configDbRootSpec config) $
+        AppState.putJsonDbS appState $ toS $ JSON.encode baseDbStructure
       return ((), postgrest LogCrit appState $ pure ())
 
     -- For tests that run with a different DbStructure(depends on configSchemas)
     appDbs cfg = do
+      let config = cfg testDbConn
       customDbStructure <-
         loadDbStructure pool
-          (configDbSchemas $ cfg testDbConn)
+          (configDbSchemas config)
-          (configDbExtraSearchPath $ cfg testDbConn)
+          (configDbExtraSearchPath config)
-      appState <- AppState.initWithPool pool $ cfg testDbConn
+      appState <- AppState.initWithPool pool config
       AppState.putDbStructure appState customDbStructure
+      when (isJust $ configDbRootSpec config) $
+        AppState.putJsonDbS appState $ toS $ JSON.encode baseDbStructure
       return ((), postgrest LogCrit appState $ pure ())
 
   let withApp              = app testCfg

test/SpecHelper.hs

@@ -165,7 +165,7 @@ testCfgExtraSearchPath :: Text -> AppConfig
 testCfgExtraSearchPath testDbConn = (testCfg testDbConn) { configDbExtraSearchPath = ["public", "extensions"] }
 
 testCfgRootSpec :: Text -> AppConfig
-testCfgRootSpec testDbConn = (testCfg testDbConn) { configDbRootSpec = Just "root"}
+testCfgRootSpec testDbConn = (testCfg testDbConn) { configDbRootSpec = Just $ QualifiedIdentifier mempty "root"}
 
 testCfgHtmlRawOutput :: Text -> AppConfig
 testCfgHtmlRawOutput testDbConn = (testCfg testDbConn) { configRawMediaTypes = ["text/html"] }

test/fixtures/schema.sql

@@ -1713,9 +1713,9 @@ returns integer as $$
   select a + b;
 $$ language sql;
 
-create function root() returns jsonb as $_$
+create or replace function root() returns json as $_$
 declare
-openapi jsonb = $$
+openapi json = $$
   {
     "swagger": "2.0",
     "info":{
@@ -1724,22 +1724,12 @@ openapi jsonb = $$
     }
   }
 $$;
-simple jsonb = $$
-  [
-    {
-      "table":"items"
-    },
-    {
-      "table":"subitems"
-    }
-  ]
-$$;
 begin
 case current_setting('request.header.accept', true)
   when 'application/openapi+json' then
     return openapi;
   when 'application/json' then
-    return simple;
+    return (current_setting('request.spec', true)::json)->'dbRelationships'->0->'relTable';
   else
     return openapi;
   end case;