refactor: move isolation/settings logic to Plan.hs

src/PostgREST/App.hs

@@ -9,7 +9,6 @@ Some of its functionality includes:
 - Producing HTTP Headers according to RFCs.
 - Content Negotiation
 -}
-{-# LANGUAGE NamedFieldPuns  #-}
 {-# LANGUAGE RecordWildCards #-}
 module PostgREST.App
   ( postgrest
@@ -24,7 +23,6 @@ import Data.String              (IsString (..))
 import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort,
                                  setServerName)
 
-import qualified Data.HashMap.Strict        as HM
 import qualified Data.Text.Encoding         as T
 import qualified Hasql.Transaction.Sessions as SQL
 import qualified Network.Wai                as Wai
@@ -54,7 +52,6 @@ import PostgREST.Query                (DbHandler)
 import PostgREST.Response.Performance (ServerTiming (..),
                                        serverTimingHeader)
 import PostgREST.SchemaCache          (SchemaCache (..))
-import PostgREST.SchemaCache.Routine  (Routine (..))
 import PostgREST.Version              (docsVersion, prettyVersion)
 
 import qualified Data.ByteString.Char8 as BS
@@ -172,7 +169,10 @@ handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@A
   case iAction of
     ActDb dbAct -> do
       (planTime', plan) <- withTiming $ liftEither $ Plan.actionPlan dbAct conf apiReq sCache
-      (txTime', queryResult) <- withTiming $ runQuery (planIsoLvl plan) (planFunSettings plan) (Plan.actionPlanTxMode plan) $ Query.actionQuery plan conf apiReq pgVer sCache
+      (txTime', queryResult) <- withTiming $ runDbHandler appState conf (Plan.planIsoLvl conf authRole plan) (Plan.planTxMode plan) authenticated prepared observer $ do
+        Query.setPgLocals plan conf authClaims authRole apiReq
+        Query.runPreReq conf
+        Query.actionQuery plan conf apiReq pgVer sCache
       (respTime', pgrst) <- withTiming $ liftEither $ Response.actionResponse queryResult (dbActQi dbAct) apiReq (T.decodeUtf8 prettyVersion, docsVersion) conf sCache iSchema iNegotiatedByProfile
       return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
 
@@ -190,20 +190,6 @@ handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@A
       return $ pgrstResponse (ServerTiming jwtTime parseTime Nothing Nothing respTime') pgrst
 
   where
-    roleSettings = fromMaybe mempty (HM.lookup authRole $ configRoleSettings conf)
-    roleIsoLvl = HM.findWithDefault SQL.ReadCommitted authRole $ configRoleIsoLvl conf
-    runQuery isoLvl funcSets mode query =
-      runDbHandler appState conf isoLvl mode authenticated prepared observer $ do
-        Query.setPgLocals conf authClaims authRole (HM.toList roleSettings) funcSets apiReq
-        Query.runPreReq conf
-        query
-
-    planIsoLvl (Plan.Db Plan.CallReadPlan{crProc}) = fromMaybe roleIsoLvl $ pdIsoLvl crProc
-    planIsoLvl _ = roleIsoLvl
-
-    planFunSettings (Plan.Db Plan.CallReadPlan{crProc}) = pdFuncSettings crProc
-    planFunSettings _ = mempty
-
     pgrstResponse :: ServerTiming -> Response.PgrstResponse -> Wai.Response
     pgrstResponse timing (Response.PgrstResponse st hdrs bod) = Wai.responseLBS st (hdrs ++ ([serverTimingHeader timing | configServerTimingEnabled conf])) bod
 

src/PostgREST/Plan.hs

@@ -22,7 +22,8 @@ module PostgREST.Plan
   , InspectPlan(..)
   , inspectPlan
   , callReadPlan
-  , actionPlanTxMode
+  , planTxMode
+  , planIsoLvl
   ) where
 
 import qualified Data.ByteString.Lazy          as LBS
@@ -127,9 +128,16 @@ data InspectPlan = InspectPlan {
 
 data ActionPlan = Db DbActionPlan | MaybeDb InspectPlan
 
-actionPlanTxMode :: ActionPlan -> SQL.Mode
-actionPlanTxMode (Db x)      = pTxMode x
-actionPlanTxMode (MaybeDb x) = ipTxmode x
+planTxMode :: ActionPlan -> SQL.Mode
+planTxMode (Db x)      = pTxMode x
+planTxMode (MaybeDb x) = ipTxmode x
+
+planIsoLvl :: AppConfig -> ByteString -> ActionPlan -> SQL.IsolationLevel
+planIsoLvl AppConfig{configRoleIsoLvl} role actPlan = case actPlan of
+  Db CallReadPlan{crProc} -> fromMaybe roleIsoLvl $ pdIsoLvl crProc
+  _                       -> roleIsoLvl
+  where
+    roleIsoLvl = HM.findWithDefault SQL.ReadCommitted role configRoleIsoLvl
 
 actionPlan :: DbAction -> AppConfig -> ApiRequest -> SchemaCache -> Either Error ActionPlan
 actionPlan dbAct conf apiReq sCache = case dbAct of

src/PostgREST/Query.hs

@@ -53,7 +53,8 @@ import PostgREST.Query.SqlFragment       (escapeIdentList, fromQi,
 import PostgREST.Query.Statements        (ResultSet (..))
 import PostgREST.SchemaCache             (SchemaCache (..))
 import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..))
-import PostgREST.SchemaCache.Routine     (MediaHandler, RoutineMap)
+import PostgREST.SchemaCache.Routine     (MediaHandler, Routine (..),
+                                          RoutineMap)
 import PostgREST.SchemaCache.Table       (TablesMap)
 
 import Protolude hiding (Handler)
@@ -238,9 +239,8 @@ optionalRollback AppConfig{..} ApiRequest{iPreferences=Preferences{..}} = do
       preferTransaction == Just Rollback
 
 -- | Set transaction scoped settings
-setPgLocals :: AppConfig  -> KM.KeyMap JSON.Value -> BS.ByteString -> [(ByteString, ByteString)] ->
-               [(Text,Text)] -> ApiRequest -> DbHandler ()
-setPgLocals AppConfig{..} claims role roleSettings funcSettings ApiRequest{..} = lift $
+setPgLocals :: ActionPlan -> AppConfig -> KM.KeyMap JSON.Value -> BS.ByteString -> ApiRequest -> DbHandler ()
+setPgLocals actPlan AppConfig{..} claims role ApiRequest{..} = lift $
   SQL.statement mempty $ SQL.dynamicallyParameterized
     -- To ensure `GRANT SET ON PARAMETER <superuser_setting> TO authenticator` works, the role settings must be set before the impersonated role.
     -- Otherwise the GRANT SET would have to be applied to the impersonated role. See https://github.com/PostgREST/postgrest/issues/3045
@@ -253,13 +253,16 @@ setPgLocals AppConfig{..} claims role roleSettings funcSettings ApiRequest{..} =
     cookiesSql = setConfigWithConstantNameJSON "request.cookies" iCookies
     claimsSql = [setConfigWithConstantName ("request.jwt.claims", LBS.toStrict $ JSON.encode claims)]
     roleSql = [setConfigWithConstantName ("role", role)]
-    roleSettingsSql = setConfigWithDynamicName <$> roleSettings
+    roleSettingsSql = setConfigWithDynamicName <$> HM.toList (fromMaybe mempty $ HM.lookup role configRoleSettings)
     appSettingsSql = setConfigWithDynamicName <$> (join bimap toUtf8 <$> configAppSettings)
     timezoneSql = maybe mempty (\(PreferTimezone tz) -> [setConfigWithConstantName ("timezone", tz)]) $ preferTimezone iPreferences
     funcSettingsSql = setConfigWithDynamicName <$> (join bimap toUtf8 <$> funcSettings)
     searchPathSql =
       let schemas = escapeIdentList (iSchema : configDbExtraSearchPath) in
       setConfigWithConstantName ("search_path", schemas)
+    funcSettings = case actPlan of
+      Db CallReadPlan{crProc} -> pdFuncSettings crProc
+      _                       -> mempty
 
 -- | Runs the pre-request function.
 runPreReq :: AppConfig -> DbHandler ()