refactor: cache the isolation level

src/PostgREST/App.hs

@@ -9,7 +9,6 @@ Some of its functionality includes:
 - Producing HTTP Headers according to RFCs.
 - Content Negotiation
 -}
-{-# LANGUAGE LambdaCase      #-}
 {-# LANGUAGE RecordWildCards #-}
 module PostgREST.App
   ( SignalHandlerInstaller
@@ -153,23 +152,17 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache pgVer authResult@
   Response.optionalRollback conf apiRequest $
     handleRequest authResult conf appState (Just authRole /= configDbAnonRole) configDbPreparedStatements pgVer apiRequest sCache
 
-runDbHandler :: AppState.AppState -> Maybe Text -> SQL.Mode -> Bool -> Bool -> DbHandler b -> Handler IO b
+runDbHandler :: AppState.AppState -> SQL.IsolationLevel -> SQL.Mode -> Bool -> Bool -> DbHandler b -> Handler IO b
 runDbHandler appState isoLvl mode authenticated prepared handler = do
   dbResp <- lift $ do
     let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction
-    AppState.usePool appState . transaction (toIsolationLevel isoLvl) mode $ runExceptT handler
+    AppState.usePool appState . transaction isoLvl mode $ runExceptT handler
 
   resp <-
     liftEither . mapLeft Error.PgErr $
       mapLeft (Error.PgError authenticated) dbResp
 
   liftEither resp
-  where
-    toIsolationLevel = \case
-      Nothing                -> SQL.ReadCommitted
-      Just "repeatable read" -> SQL.RepeatableRead
-      Just "serializable"    -> SQL.Serializable
-      _                      -> SQL.ReadCommitted
 
 handleRequest :: AuthResult -> AppConfig -> AppState.AppState -> Bool -> Bool -> PgVersion -> ApiRequest -> SchemaCache -> Handler IO Wai.Response
 handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@ApiRequest{..} sCache =
@@ -201,7 +194,7 @@ handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@A
 
     (ActionInvoke invMethod, TargetProc identifier _) -> do
       cPlan <- liftEither $ Plan.callReadPlan identifier conf sCache apiReq invMethod
-      resultSet <- runQuery (roleIsoLvl <|> pdIsoLvl (Plan.crProc cPlan))(Plan.crTxMode cPlan) $ Query.invokeQuery (Plan.crProc cPlan) cPlan apiReq conf pgVer
+      resultSet <- runQuery (fromMaybe roleIsoLvl $ pdIsoLvl (Plan.crProc cPlan))(Plan.crTxMode cPlan) $ Query.invokeQuery (Plan.crProc cPlan) cPlan apiReq conf pgVer
       return $ Response.invokeResponse invMethod (Plan.crProc cPlan) apiReq resultSet
 
     (ActionInspect headersOnly, TargetDefaultSpec tSchema) -> do
@@ -224,7 +217,7 @@ handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@A
       throwError $ Error.ApiRequestError ApiRequestTypes.NotFound
   where
     roleSettings = fromMaybe mempty (HM.lookup authRole $ configRoleSettings conf)
-    roleIsoLvl = decodeUtf8 <$> HM.lookup "default_transaction_isolation" roleSettings
+    roleIsoLvl = HM.findWithDefault SQL.ReadCommitted authRole $ configRoleIsoLvl conf
     runQuery isoLvl mode query =
       runDbHandler appState isoLvl mode authenticated prepared $ do
         Query.setPgLocals conf authClaims authRole (HM.toList roleSettings) apiReq pgVer

src/PostgREST/AppState.hs

@@ -373,18 +373,18 @@ reReadConfig startingUp appState = do
         Right x -> pure x
     else
       pure mempty
-  roleSettings <-
+  (roleSettings, roleIsolationLvl) <-
     if configDbConfig then do
       rSettings <- usePool appState $ queryRoleSettings configDbPreparedStatements
       case rSettings of
         Left e -> do
           logWithZTime appState "An error ocurred when trying to query the role settings"
           logPgrstError appState e
-          pure mempty
+          pure (mempty, mempty)
         Right x -> pure x
     else
       pure mempty
-  readAppConfig dbSettings configFilePath (Just configDbUri) roleSettings >>= \case
+  readAppConfig dbSettings configFilePath (Just configDbUri) roleSettings roleIsolationLvl >>= \case
     Left err   ->
       if startingUp then
         panic err -- die on invalid config if the program is starting up

src/PostgREST/CLI.hs

@@ -32,7 +32,7 @@ import Protolude hiding (hPutStrLn)
 main :: App.SignalHandlerInstaller -> Maybe App.SocketRunner -> CLI -> IO ()
 main installSignalHandlers runAppWithSocket CLI{cliCommand, cliPath} = do
   conf@AppConfig{..} <-
-    either panic identity <$> Config.readAppConfig mempty cliPath Nothing mempty
+    either panic identity <$> Config.readAppConfig mempty cliPath Nothing mempty mempty
 
   -- Per https://github.com/PostgREST/postgrest/issues/268, we want to
   -- explicitly close the connections to PostgreSQL on shutdown.

src/PostgREST/Config.hs

@@ -51,7 +51,8 @@ import Numeric                 (readOct, showOct)
 import System.Environment      (getEnvironment)
 import System.Posix.Types      (FileMode)
 
-import PostgREST.Config.Database         (RoleSettings)
+import PostgREST.Config.Database         (RoleIsolationLvl,
+                                          RoleSettings)
 import PostgREST.Config.JSPath           (JSPath, JSPathExp (..),
                                           dumpJSPath, pRoleClaimKey)
 import PostgREST.Config.Proxy            (Proxy (..),
@@ -103,6 +104,7 @@ data AppConfig = AppConfig
   , configServerUnixSocketMode     :: FileMode
   , configAdminServerPort          :: Maybe Int
   , configRoleSettings             :: RoleSettings
+  , configRoleIsoLvl               :: RoleIsolationLvl
   , configInternalSCSleep          :: Maybe Int32
   }
 
@@ -198,13 +200,13 @@ instance JustIfMaybe a (Maybe a) where
 
 -- | Reads and parses the config and overrides its parameters from env vars,
 -- files or db settings.
-readAppConfig :: [(Text, Text)] -> Maybe FilePath -> Maybe Text -> RoleSettings -> IO (Either Text AppConfig)
+readAppConfig :: [(Text, Text)] -> Maybe FilePath -> Maybe Text -> RoleSettings -> RoleIsolationLvl -> IO (Either Text AppConfig)
-readAppConfig dbSettings optPath prevDbUri roleSettings = do
+readAppConfig dbSettings optPath prevDbUri roleSettings roleIsolationLvl = do
   env <- readPGRSTEnvironment
   -- if no filename provided, start with an empty map to read config from environment
   conf <- maybe (return $ Right M.empty) loadConfig optPath
 
-  case C.runParser (parser optPath env dbSettings roleSettings) =<< mapLeft show conf of
+  case C.runParser (parser optPath env dbSettings roleSettings roleIsolationLvl) =<< mapLeft show conf of
     Left err ->
       return . Left $ "Error in config " <> err
     Right parsedConfig ->
@@ -219,8 +221,8 @@ readAppConfig dbSettings optPath prevDbUri roleSettings = do
       decodeJWKS <$>
         (decodeSecret =<< readSecretFile =<< readDbUriFile prevDbUri parsedConfig)
 
-parser :: Maybe FilePath -> Environment -> [(Text, Text)] -> RoleSettings -> C.Parser C.Config AppConfig
+parser :: Maybe FilePath -> Environment -> [(Text, Text)] -> RoleSettings -> RoleIsolationLvl -> C.Parser C.Config AppConfig
-parser optPath env dbSettings roleSettings =
+parser optPath env dbSettings roleSettings roleIsolationLvl =
   AppConfig
     <$> parseAppSettings "app.settings"
     <*> (fmap encodeUtf8 <$> optString "db-anon-role")
@@ -268,6 +270,7 @@ parser optPath env dbSettings roleSettings =
     <*> parseSocketFileMode "server-unix-socket-mode"
     <*> optInt "admin-server-port"
     <*> pure roleSettings
+    <*> pure roleIsolationLvl
     <*> optInt "internal-schema-cache-sleep"
   where
     parseAppSettings :: C.Key -> C.Parser C.Config [(Text, Text)]

src/PostgREST/Config/Database.hs

@@ -6,6 +6,8 @@ module PostgREST.Config.Database
   , queryRoleSettings
   , queryPgVersion
   , RoleSettings
+  , RoleIsolationLvl
+  , toIsolationLevel
   ) where
 
 import Control.Arrow ((***))
@@ -26,6 +28,13 @@ import Text.InterpolatedString.Perl6 (q, qc)
 import Protolude
 
 type RoleSettings     = (HM.HashMap ByteString (HM.HashMap ByteString ByteString))
+type RoleIsolationLvl = HM.HashMap ByteString SQL.IsolationLevel
+
+toIsolationLevel :: (Eq a, IsString a) => a -> SQL.IsolationLevel
+toIsolationLevel a = case a of
+  "repeatable read" -> SQL.RepeatableRead
+  "serializable"    -> SQL.Serializable
+  _                 -> SQL.ReadCommitted
 
 prefix :: Text
 prefix = "pgrst."
@@ -117,13 +126,10 @@ queryDbSettings preConfFunc prepared =
       |]::Text
     decodeSettings = HD.rowList $ (,) <$> column HD.text <*> column HD.text
 
-queryRoleSettings :: Bool -> Session RoleSettings
+queryRoleSettings :: Bool -> Session (RoleSettings, RoleIsolationLvl)
 queryRoleSettings prepared =
   let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction in
-  transaction SQL.ReadCommitted SQL.Read $ SQL.statement mempty $ roleSettingsStatement prepared
+  transaction SQL.ReadCommitted SQL.Read $ SQL.statement mempty $ SQL.Statement sql HE.noParams (processRows <$> rows) prepared
-
-roleSettingsStatement :: Bool -> SQL.Statement () RoleSettings
-roleSettingsStatement = SQL.Statement sql HE.noParams decodeRoleSettings
   where
     sql = [q|
       with
@@ -139,18 +145,40 @@ roleSettingsStatement = SQL.Statement sql HE.noParams decodeRoleSettings
           substr(setting, 1, strpos(setting, '=') - 1) as key,
           lower(substr(setting, strpos(setting, '=') + 1)) as value
         FROM role_setting
+      ),
+      iso_setting AS (
+        SELECT rolname, value
+        FROM kv_settings
+        WHERE key = 'default_transaction_isolation'
       )
-      select rolname, array_agg(row(key, value))
+      select
-      from kv_settings
+        kv.rolname,
-      group by rolname;
+        i.value as iso_lvl,
+        array_agg(row(kv.key, kv.value)) filter (where key <> 'default_transation_isolation') as role_settings
+      from kv_settings kv
+      left join iso_setting i on i.rolname = kv.rolname
+      group by kv.rolname, i.value;
     |]
-    decodeRoleSettings = HM.fromList . map (bimap encodeUtf8 (HM.fromList . ((encodeUtf8 *** encodeUtf8) <$>))) <$> HD.rowList aRow
+
-    aRow :: HD.Row (Text, [(Text, Text)])
+    processRows :: [(Text, Maybe Text, [(Text, Text)])] -> (RoleSettings, RoleIsolationLvl)
-    aRow = (,) <$> column HD.text <*> compositeArrayColumn ((,) <$> compositeField HD.text <*> compositeField HD.text)
+    processRows rs =
+      let
+        rowsWRoleSettings = [ (x, z) | (x, _, z) <- rs ]
+        rowsWIsolation    = [ (x, y) | (x, Just y, _) <- rs ]
+      in
+      ( HM.fromList $ bimap encodeUtf8 (HM.fromList . ((encodeUtf8 *** encodeUtf8) <$>)) <$> rowsWRoleSettings
+      , HM.fromList $ (encodeUtf8 *** toIsolationLevel) <$> rowsWIsolation
+      )
+
+    rows :: HD.Result [(Text, Maybe Text, [(Text, Text)])]
+    rows = HD.rowList $ (,,) <$> column HD.text <*> nullableColumn HD.text <*> compositeArrayColumn ((,) <$> compositeField HD.text <*> compositeField 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
+
 compositeField :: HD.Value a -> HD.Composite a
 compositeField = HD.field . HD.nonNullable
 

src/PostgREST/SchemaCache.hs

@@ -41,7 +41,8 @@ import Contravariant.Extras          (contrazip2)
 import Text.InterpolatedString.Perl6 (q)
 
 import PostgREST.Config                   (AppConfig (..))
-import PostgREST.Config.Database          (pgVersionStatement)
+import PostgREST.Config.Database          (pgVersionStatement,
+                                           toIsolationLevel)
 import PostgREST.Config.PgVersion         (PgVersion, pgVersion100,
                                            pgVersion110, pgVersion120)
 import PostgREST.SchemaCache.Identifiers  (AccessSet, FieldName,
@@ -259,7 +260,7 @@ decodeFuncs =
                   <*> column HD.bool)
               <*> (parseVolatility <$> column HD.char)
               <*> column HD.bool
-              <*> nullableColumn HD.text
+              <*> nullableColumn (toIsolationLevel <$> HD.text)
 
     addKey :: Routine -> (QualifiedIdentifier, Routine)
     addKey pd = (QualifiedIdentifier (pdSchema pd) (pdName pd), pd)

src/PostgREST/SchemaCache/Routine.hs

@@ -16,8 +16,10 @@ module PostgREST.SchemaCache.Routine
   , funcReturnsCompositeAlias
   ) where
 
+import           Data.Aeson                 ((.=))
 import qualified Data.Aeson                 as JSON
 import qualified Data.HashMap.Strict        as HM
+import qualified Hasql.Transaction.Sessions as SQL
 
 import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..),
                                           Schema, TableName)
@@ -48,9 +50,21 @@ data Routine = Function
   , pdReturnType  :: RetType
   , pdVolatility  :: FuncVolatility
   , pdHasVariadic :: Bool
-  , pdIsoLvl      :: Maybe Text
+  , pdIsoLvl      :: Maybe SQL.IsolationLevel
   }
-  deriving (Eq, Generic, JSON.ToJSON)
+  deriving (Eq, Generic)
+-- need to define JSON manually bc SQL.IsolationLevel doesn't have a JSON instance(and we can't define one for that type without getting a compiler error)
+instance JSON.ToJSON Routine where
+  toJSON (Function sch nam desc params ret vol hasVar _) = JSON.object
+    [
+      "pdSchema"      .= sch
+    , "pdName"        .= nam
+    , "pdDescription" .= desc
+    , "pdParams"      .= JSON.toJSON params
+    , "pdReturnType"  .= JSON.toJSON ret
+    , "pdVolatility"  .= JSON.toJSON vol
+    , "pdHasVariadic" .= JSON.toJSON hasVar
+    ]
 
 data RoutineParam = RoutineParam
   { ppName :: Text

test/spec/SpecHelper.hs

@@ -113,6 +113,7 @@ baseCfg = let secret = Just $ encodeUtf8 "reallyreallyreallyreallyverysafe" in
   , configDbTxRollbackAll       = True
   , configAdminServerPort       = Nothing
   , configRoleSettings          = mempty
+  , configRoleIsoLvl            = mempty
   , configInternalSCSleep       = Nothing
   }