feat: get configuration parameters from the db

Allows configuring postgrest from the db by setting config parameters
on the connection role. For example:

ALTER ROLE postgrest_test_authenticator
SET pgrst.jwt-secret = "REALLYREALLYREALLYREALLYVERYSAFE"

The above wWill set the `jwt-secret` config option accordingly.

SUPERUSER privileges are required for ALTERing role settings,
so this might not work on some cloud-managed databases.

This feature is enabled by default, for disabling it you can add the
following to the config file:

db-load-guc-config = false

main/Main.hs

@@ -8,7 +8,7 @@ import qualified Data.ByteString.Lazy       as LBS
 import qualified Hasql.Connection           as C
 import qualified Hasql.Notifications        as N
 import qualified Hasql.Pool                 as P
-import qualified Hasql.Session              as S
+import qualified Hasql.Transaction          as HT
 import qualified Hasql.Transaction.Sessions as HT
 
 import Control.AutoUpdate       (defaultUpdateSettings, mkAutoUpdate,
@@ -28,15 +28,15 @@ import Data.Time.Clock          (getCurrentTime)
 import Network.Wai.Handler.Warp (defaultSettings, runSettings,
                                  setHost, setPort, setServerName)
 import System.CPUTime           (getCPUTime)
-import System.IO                (BufferMode (..), hPrint,
-                                 hSetBuffering)
+import System.IO                (BufferMode (..), hSetBuffering)
 import Text.Printf              (hPrintf)
 
 import PostgREST.App         (postgrest)
 import PostgREST.Config
 import PostgREST.DbStructure (getDbStructure, getPgVersion)
 import PostgREST.Error       (PgError (PgError), checkIsFatal,
                               errorPayload)
+import PostgREST.Statements  (dbSettingsStatement)
 import PostgREST.Types       (ConnectionStatus (..), DbStructure,
                               PgVersion (..), SCacheStatus (..),
                               minimumPgVersion)
@@ -68,7 +68,7 @@ main = do
   opts <- readCLIShowHelp env
 
   -- build the 'AppConfig' from the config file path
-  conf <- readValidateConfig env $ cliPath opts
+  conf <- readValidateConfig mempty env $ cliPath opts
 
   -- These are config values that can't be reloaded at runtime. Reloading some of them would imply restarting the web server.
   let
@@ -88,19 +88,7 @@ main = do
     poolSize = configDbPoolSize conf
     poolTimeout = configDbPoolTimeout' conf
     logLevel = configLogLevel conf
-
-  case cliCommand opts of
-    CmdDumpConfig ->
-      do
-        putStr $ dumpAppConfig conf
-        exitSuccess
-    CmdDumpSchema ->
-      do
-        dumpedSchema <- dumpSchema conf
-        putStrLn dumpedSchema
-        exitSuccess
-    CmdRun ->
-      pass
+    gucConfigEnabled = configDbLoadGucConfig conf
 
   -- create connection pool with the provided settings, returns either a 'Connection' or a 'ConnectionError'. Does not throw.
   pool <- P.acquire (poolSize, poolTimeout, dbUri)
@@ -117,6 +105,24 @@ main = do
   -- Config that can change at runtime
   refConf <- newIORef conf
 
+  -- re-read and override the config if db-load-guc-config is true
+  when gucConfigEnabled $
+    reReadConfig pool gucConfigEnabled env (cliPath opts) refConf
+
+  case cliCommand opts of
+    CmdDumpConfig ->
+      do
+        dumpedConfig <- dumpAppConfig <$> readIORef refConf
+        putStr dumpedConfig
+        exitSuccess
+    CmdDumpSchema ->
+      do
+        dumpedSchema <- dumpSchema pool =<< readIORef refConf
+        putStrLn dumpedSchema
+        exitSuccess
+    CmdRun ->
+      pass
+
   -- This is passed to the connectionWorker method so it can kill the main thread if the PostgreSQL's version is not supported.
   mainTid <- myThreadId
 
@@ -141,11 +147,10 @@ main = do
     Catch connWorker
     ) Nothing
 
-  -- Re-read the config on SIGUSR2, but only if we have a config file
-  when (isJust $ cliPath opts) $
-    void $ installHandler sigUSR2 (
-      Catch $ reReadConfig env (cliPath opts) refConf
-      ) Nothing
+  -- Re-read the config on SIGUSR2
+  void $ installHandler sigUSR2 (
+    Catch $ reReadConfig pool gucConfigEnabled env (cliPath opts) refConf >> putStrLn ("Config reloaded" :: Text)
+    ) Nothing
 #endif
 
   -- reload schema cache on NOTIFY
@@ -267,6 +272,15 @@ connectionStatus pool =
         putStrLn $ "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..."
       return itShould
 
+loadDbSettings :: P.Pool -> IO [(Text, Text)]
+loadDbSettings pool = do
+  result <- P.use pool $ HT.transaction HT.ReadCommitted HT.Read $ HT.statement mempty dbSettingsStatement
+  case result of
+    Left  e -> do
+      hPutStrLn stderr ("An error ocurred when trying to query database settings for the config parameters:\n" <> show e :: Text)
+      pure []
+    Right x -> pure x
+
 -- | Load the DbStructure by using a connection from the pool.
 loadSchemaCache :: P.Pool -> PgVersion -> IORef AppConfig -> IORef (Maybe DbStructure) -> IO SCacheStatus
 loadSchemaCache pool actualPgVersion refConf refDbStructure = do
@@ -332,41 +346,33 @@ listener dbUri dbChannel pool refConf refDbStructure mvarConnectionStatus connWo
     errorMessage = "Could not listen for notifications on the " <> dbChannel <> " channel" :: Text
     retryMessage = "Retrying listening for notifications on the " <> dbChannel <> " channel.." :: Text
 
-#ifndef mingw32_HOST_OS
--- | Re-reads the config at runtime. Invoked on SIGUSR2.
+-- | Re-reads the config at runtime.
 -- | If it panics(config path was changed, invalid setting), it'll show an error but won't kill the main thread.
-reReadConfig :: Environment -> Maybe FilePath -> IORef AppConfig -> IO ()
-reReadConfig env path refConf = do
-  conf <- readValidateConfig env path
+reReadConfig :: P.Pool -> Bool -> Environment -> Maybe FilePath -> IORef AppConfig -> IO ()
+reReadConfig pool gucConfigEnabled env path refConf = do
+  dbSettings <- if gucConfigEnabled then loadDbSettings pool else pure []
+  conf <- readValidateConfig dbSettings env path
   atomicWriteIORef refConf conf
-  putStrLn ("Config file reloaded" :: Text)
-#endif
 
 -- | Dump DbStructure schema to JSON
-dumpSchema :: AppConfig -> IO LBS.ByteString
-dumpSchema conf =
-  do
-    eitherConn <- C.acquire . toS $ configDbUri conf
-    case eitherConn of
-      Left e -> hPrint stderr e >> exitFailure
-      Right conn -> do
-        result <-
-          timeToStderr "Loaded schema in %.3f seconds" $
-            flip S.run conn $ do
-              pgVersion <- getPgVersion
-              HT.transaction HT.ReadCommitted HT.Read $
-                getDbStructure
-                  (toList $ configDbSchemas conf)
-                  (configDbExtraSearchPath conf)
-                  pgVersion
-                  (configDbPreparedStatements conf)
-        C.release conn
-        case result of
-          Left e -> do
-            hPutStrLn stderr $ "An error ocurred when loading the schema cache:\n" <> show e
-            exitFailure
-          Right dbStructure -> return $ Aeson.encode dbStructure
-
+dumpSchema :: P.Pool -> AppConfig -> IO LBS.ByteString
+dumpSchema pool conf = do
+  result <-
+    timeToStderr "Loaded schema in %.3f seconds" $
+      P.use pool $ do
+        pgVersion <- getPgVersion
+        HT.transaction HT.ReadCommitted HT.Read $
+          getDbStructure
+            (toList $ configDbSchemas conf)
+            (configDbExtraSearchPath conf)
+            pgVersion
+            (configDbPreparedStatements conf)
+  P.release pool
+  case result of
+    Left e -> do
+      hPutStrLn stderr $ "An error ocurred when loading the schema cache:\n" <> show e
+      exitFailure
+    Right dbStructure -> return $ Aeson.encode dbStructure
 
 -- | Print the time taken to run an IO action to stderr with the given printf string
 timeToStderr :: [Char] -> IO (Either a b) -> IO (Either a b)

src/PostgREST/Config.hs

@@ -45,6 +45,7 @@ import Control.Monad           (fail)
 import Crypto.JWT              (JWKSet, StringOrURI, stringOrUri)
 import Data.Aeson              (encode, toJSON)
 import Data.Either.Combinators (fromRight', whenLeft)
+import Data.List               (lookup)
 import Data.List.NonEmpty      (fromList, toList)
 import Data.Maybe              (fromJust)
 import Data.Scientific         (floatingOrInteger)
@@ -101,6 +102,7 @@ data AppConfig = AppConfig {
   , configDbPreparedStatements  :: Bool
   , configDbRootSpec            :: Maybe Text
   , configDbSchemas             :: NonEmpty Text
+  , configDbLoadGucConfig       :: Bool
   , configDbTxAllowOverride     :: Bool
   , configDbTxRollbackAll       :: Bool
   , configDbUri                 :: Text
@@ -215,6 +217,9 @@ readCLIShowHelp env = customExecParser parserPrefs opts
           |## Enable or disable the notification channel
           |db-channel-enabled = false
           |
+          |## Enable loading config parameters from the database by changing the connection role settings
+          |db-load-guc-config = true
+          |
           |## how to terminate database transactions
           |## possible values are:
           |## commit (default)
@@ -280,6 +285,7 @@ dumpAppConfig conf =
       ,("db-prepared-statements",        toLower . show . configDbPreparedStatements)
       ,("db-root-spec",              q . fromMaybe mempty . configDbRootSpec)
       ,("db-schemas",                q . intercalate "," . toList . configDbSchemas)
+      ,("db-load-guc-config",        q . toLower . show . configDbLoadGucConfig)
       ,("db-tx-end",                 q . showTxEnd)
       ,("db-uri",                    q . configDbUri)
       ,("jwt-aud",                       toS . encode . maybe "" toJSON . configJwtAudience)
@@ -313,7 +319,7 @@ dumpAppConfig conf =
         secret = fromMaybe mempty $ configJwtSecret c
     showSocketMode c = showOct (fromRight' $ configServerUnixSocketMode c) ""
 
--- This class is needed for the polymorphism of overrideFromEnvironment
+-- This class is needed for the polymorphism of overrideFromDbOrEnvironment
 -- because C.required and C.optional have different signatures
 class JustIfMaybe a b where
   justIfMaybe :: a -> b
@@ -325,8 +331,8 @@ instance JustIfMaybe a (Maybe a) where
   justIfMaybe a = Just a
 
 -- | Parse the config file
-readAppConfig :: Environment -> Maybe FilePath -> IO AppConfig
-readAppConfig env optPath = do
+readAppConfig :: [(Text, Text)] -> Environment -> Maybe FilePath -> IO AppConfig
+readAppConfig dbSettings env optPath = do
   -- Now read the actual config file
   conf <- case optPath of
     Just cfgPath -> catches (C.load cfgPath)
@@ -356,12 +362,13 @@ readAppConfig env optPath = do
         <*> (fromMaybe 10 <$> optInt "db-pool-timeout")
         <*> optWithAlias (optString "db-pre-request")
                          (optString "pre-request")
-        <*> (fromMaybe True <$>  optBool "db-prepared-statements")
+        <*> (fromMaybe True <$> optBool "db-prepared-statements")
         <*> optWithAlias (optString "db-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")
+        <*> (fromMaybe True <$> optBool "db-load-guc-config")
         <*> parseTxEnd "db-tx-end" snd
         <*> parseTxEnd "db-tx-end" fst
         <*> reqString "db-uri"
@@ -387,21 +394,27 @@ readAppConfig env optPath = do
         fromEnv = M.mapKeys fromJust $ M.filterWithKey (\k _ -> isJust k) $ M.mapKeys normalize env
         normalize k = ("app.settings." <>) <$> stripPrefix "PGRST_APP_SETTINGS_" (toS k)
 
-    overrideFromEnvironment :: JustIfMaybe a b =>
+    overrideFromDbOrEnvironment :: JustIfMaybe a b =>
                                (C.Key -> C.Parser C.Value a -> C.Parser C.Config b) ->
                                C.Key -> (C.Value -> a) -> C.Parser C.Config b
-    overrideFromEnvironment necessity key coercion =
-      case M.lookup name env of
-        Just envVal -> pure $ justIfMaybe $ coercion $ C.String envVal
-        Nothing     -> necessity key (coercion <$> C.value)
+    overrideFromDbOrEnvironment necessity key coercion =
+      case reloadableDbSetting <|> M.lookup name env of
+        Just dbOrEnvVal -> pure $ justIfMaybe $ coercion $ C.String dbOrEnvVal
+        Nothing  -> necessity key (coercion <$> C.value)
       where
         name = "PGRST_" <> map capitalize (toS key)
         capitalize '-' = '_'
         capitalize c   = toUpper c
+        reloadableDbSetting =
+          if key `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-load-guc-config"]
+          then lookup key dbSettings
+          else Nothing
 
     parseSocketFileMode :: C.Key -> C.Parser C.Config (Either Text FileMode)
     parseSocketFileMode k =
-      overrideFromEnvironment C.optional k coerceText >>= \case
+      overrideFromDbOrEnvironment C.optional k coerceText >>= \case
         Nothing -> pure $ Right 432 -- return default 660 mode if no value was provided
         Just fileModeText ->
           case (readOct . unpack) fileModeText of
@@ -414,7 +427,7 @@ readAppConfig env optPath = do
 
     parseJwtAudience :: C.Key -> C.Parser C.Config (Maybe StringOrURI)
     parseJwtAudience k =
-      overrideFromEnvironment C.optional k coerceText >>= \case
+      overrideFromDbOrEnvironment C.optional k coerceText >>= \case
         Nothing -> pure Nothing -- no audience in config file
         Just aud -> case preview stringOrUri (unpack aud) of
           Nothing -> fail "Invalid Jwt audience. Check your configuration."
@@ -423,7 +436,7 @@ readAppConfig env optPath = do
 
     parseLogLevel :: C.Key -> C.Parser C.Config LogLevel
     parseLogLevel k =
-      overrideFromEnvironment C.optional k coerceText >>= \case
+      overrideFromDbOrEnvironment C.optional k coerceText >>= \case
         Nothing      -> pure LogError
         Just ""      -> pure LogError
         Just "crit"  -> pure LogCrit
@@ -434,7 +447,7 @@ readAppConfig env optPath = do
 
     parseTxEnd :: C.Key -> ((Bool, Bool) -> Bool) -> C.Parser C.Config Bool
     parseTxEnd k f =
-      overrideFromEnvironment C.optional k coerceText >>= \case
+      overrideFromDbOrEnvironment C.optional k coerceText >>= \case
         --                                          RollbackAll AllowOverride
         Nothing                        -> pure $ f (False,      False)
         Just ""                        -> pure $ f (False,      False)
@@ -460,19 +473,19 @@ readAppConfig env optPath = do
         Nothing -> alias
 
     reqString :: C.Key -> C.Parser C.Config Text
-    reqString k = overrideFromEnvironment C.required k coerceText
+    reqString k = overrideFromDbOrEnvironment C.required k coerceText
 
     optString :: C.Key -> C.Parser C.Config (Maybe Text)
-    optString k = mfilter (/= "") <$> overrideFromEnvironment C.optional k coerceText
+    optString k = mfilter (/= "") <$> overrideFromDbOrEnvironment C.optional k coerceText
 
     optValue :: C.Key -> C.Parser C.Config (Maybe C.Value)
-    optValue k = overrideFromEnvironment C.optional k identity
+    optValue k = overrideFromDbOrEnvironment C.optional k identity
 
     optInt :: (Read i, Integral i) => C.Key -> C.Parser C.Config (Maybe i)
-    optInt k = join <$> overrideFromEnvironment C.optional k coerceInt
+    optInt k = join <$> overrideFromDbOrEnvironment C.optional k coerceInt
 
     optBool :: C.Key -> C.Parser C.Config (Maybe Bool)
-    optBool k = join <$> overrideFromEnvironment C.optional k coerceBool
+    optBool k = join <$> overrideFromDbOrEnvironment C.optional k coerceBool
 
     coerceText :: C.Value -> Text
     coerceText (C.String s) = s
@@ -506,10 +519,10 @@ readAppConfig env optPath = do
       hPutStrLn stderr err
       exitFailure
 
--- | Parse the AppConfig and validate it. Panic on invalid config options.
-readValidateConfig :: Environment -> Maybe FilePath -> IO AppConfig
-readValidateConfig env path = do
-  conf <- loadDbUriFile =<< loadSecretFile =<< readAppConfig env path
+-- | Parse the AppConfig and validate it. Overrides the config options from env vars or db settings. Panics on invalid config options.
+readValidateConfig :: [(Text, Text)] -> Environment -> Maybe FilePath -> IO AppConfig
+readValidateConfig dbSettings env path = do
+  conf <- loadDbUriFile =<< loadSecretFile =<< readAppConfig dbSettings env path
   -- Checks that the provided proxy uri is formated correctly
   when (isMalformedProxyUri $ toS <$> configOpenApiServerProxyUri conf) $
     panic

src/PostgREST/Statements.hs

@@ -14,6 +14,7 @@ module PostgREST.Statements (
   , createReadStatement
   , callProcStatement
   , createExplainStatement
+  , dbSettingsStatement
 ) where
 
 
@@ -24,6 +25,7 @@ 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
@@ -37,6 +39,8 @@ import           Protolude.Conv                  (toS)
 import qualified Hasql.DynamicStatements.Snippet   as H
 import qualified Hasql.DynamicStatements.Statement as H
 
+import Text.InterpolatedString.Perl6 (q)
+
 {-| 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.
@@ -190,3 +194,19 @@ decodeGucHeaders = first (const GucHeadersError) . JSON.eitherDecode . toS <$> H
 
 decodeGucStatus :: HD.Value (Either SimpleError (Maybe Status))
 decodeGucStatus = first (const GucStatusError) . fmap (Just . toEnum . fst) . decimal <$> HD.text
+
+-- | Get db settings from the connection role. Only used for configuration.
+dbSettingsStatement :: H.Statement () [(Text, Text)]
+dbSettingsStatement = H.Statement sql HE.noParams decodeSettings False
+  where
+    sql = [q|
+      with
+      role_setting as (
+        select unnest(setconfig) as setting from pg_catalog.pg_db_role_setting where setrole = 'postgrest_test_authenticator'::regrole::oid
+      ),
+      kv_settings as (
+        select split_part(setting, '=', 1) as key, split_part(setting, '=', 2) as value from role_setting
+      )
+      select replace(key, 'pgrst.', '') as key, value from kv_settings where key like 'pgrst.%';
+    |]
+    decodeSettings = HD.rowList $ (,) <$> column HD.text <*> column HD.text