refactor: one entrypoint for Plan/Response/Query

- deduplicates timing calculation for the different steps
- enabling query logging later on will be simpler

src/PostgREST/ApiRequest.hs

@@ -99,7 +99,7 @@ data DbAction
 data Action
   = ActDb           DbAction
   | ActRelationInfo QualifiedIdentifier
-  | ActRoutineInfo  QualifiedIdentifier
+  | ActRoutineInfo  QualifiedIdentifier InvokeMethod
   | ActSchemaInfo
 
 {-|
@@ -178,7 +178,7 @@ getAction resource schema method =
     (ResourceRoutine rout, "HEAD")    -> Right . ActDb $ ActRoutine (qi rout) $ InvRead True
     (ResourceRoutine rout, "GET")     -> Right . ActDb $ ActRoutine (qi rout) $ InvRead False
     (ResourceRoutine rout, "POST")    -> Right . ActDb $ ActRoutine (qi rout) Inv
-    (ResourceRoutine rout, "OPTIONS") -> Right $ ActRoutineInfo (qi rout)
+    (ResourceRoutine rout, "OPTIONS") -> Right $ ActRoutineInfo (qi rout) $ InvRead True
     (ResourceRoutine _, _)            -> Left $ InvalidRpcMethod method
 
     (ResourceRelation rel, "HEAD")    -> Right . ActDb $ ActRelationRead (qi rel) True

src/PostgREST/App.hs

@@ -23,10 +23,9 @@ import Data.String              (IsString (..))
 import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort,
                                  setServerName)
 
-import qualified Data.Text.Encoding         as T
-import qualified Hasql.Transaction.Sessions as SQL
-import qualified Network.Wai                as Wai
-import qualified Network.Wai.Handler.Warp   as Warp
+import qualified Data.Text.Encoding       as T
+import qualified Network.Wai              as Wai
+import qualified Network.Wai.Handler.Warp as Warp
 
 import qualified PostgREST.Admin      as Admin
 import qualified PostgREST.ApiRequest as ApiRequest
@@ -40,15 +39,13 @@ import qualified PostgREST.Query      as Query
 import qualified PostgREST.Response   as Response
 import qualified PostgREST.Unix       as Unix (installSignalHandlers)
 
-import PostgREST.ApiRequest           (Action (..), ApiRequest (..),
-                                       DbAction (..))
+import PostgREST.ApiRequest           (ApiRequest (..))
 import PostgREST.AppState             (AppState)
 import PostgREST.Auth                 (AuthResult (..))
 import PostgREST.Config               (AppConfig (..), LogLevel (..))
 import PostgREST.Config.PgVersion     (PgVersion (..))
 import PostgREST.Error                (Error)
 import PostgREST.Observation          (Observation (..))
-import PostgREST.Query                (DbHandler)
 import PostgREST.Response.Performance (ServerTiming (..),
                                        serverTimingHeader)
 import PostgREST.SchemaCache          (SchemaCache (..))
@@ -143,66 +140,27 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache pgVer authResult@
 
   body <- lift $ Wai.strictRequestBody req
 
-  (parseTime, apiRequest) <-
-    calcTiming configServerTimingEnabled $
-      liftEither . mapLeft Error.ApiRequestError $
-        ApiRequest.userApiRequest conf req body sCache
-
   let jwtTime = if configServerTimingEnabled then Auth.getJwtDur req else Nothing
-  handleRequest authResult conf appState (Just authRole /= configDbAnonRole) configDbPreparedStatements pgVer apiRequest sCache jwtTime parseTime observer
-
-runDbHandler :: AppState.AppState -> AppConfig -> SQL.IsolationLevel -> SQL.Mode -> Bool -> Bool -> (Observation -> IO ()) -> DbHandler b -> Handler IO b
-runDbHandler appState config isoLvl mode authenticated prepared observer handler = do
-  dbResp <- lift $ do
-    let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction
-    AppState.usePool appState config (transaction isoLvl mode $ runExceptT handler) observer
-
-  resp <-
-    liftEither . mapLeft Error.PgErr $
-      mapLeft (Error.PgError authenticated) dbResp
-
-  liftEither resp
-
-handleRequest :: AuthResult -> AppConfig -> AppState.AppState -> Bool -> Bool -> PgVersion -> ApiRequest -> SchemaCache ->
-                Maybe Double -> Maybe Double -> (Observation -> IO ()) -> Handler IO Wai.Response
-handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@ApiRequest{..} sCache jwtTime parseTime observer =
-  case iAction of
-    ActDb dbAct -> do
-      (planTime', plan) <- withTiming $ liftEither $ Plan.actionPlan dbAct conf apiReq 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
-
-    ActRelationInfo identifier -> do
-      (respTime', pgrst) <- withTiming $ liftEither $ Response.infoIdentResponse identifier sCache
-      return $ pgrstResponse (ServerTiming jwtTime parseTime Nothing Nothing respTime') pgrst
-
-    ActRoutineInfo identifier -> do
-      (planTime', cPlan) <- withTiming $ liftEither $ Plan.callReadPlan identifier conf sCache apiReq $ ApiRequest.InvRead True
-      (respTime', pgrst) <- withTiming $ liftEither $ Response.infoProcResponse (Plan.crProc cPlan)
-      return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' Nothing respTime') pgrst
-
-    ActSchemaInfo -> do
-      (respTime', pgrst) <- withTiming $ liftEither Response.infoRootResponse
-      return $ pgrstResponse (ServerTiming jwtTime parseTime Nothing Nothing respTime') pgrst
+
+  (parseTime, apiReq@ApiRequest{..}) <- withTiming $ liftEither . mapLeft Error.ApiRequestError $ ApiRequest.userApiRequest conf req body sCache
+  (planTime, plan)                   <- withTiming $ liftEither $ Plan.actionPlan iAction conf apiReq sCache
+  (queryTime, queryResult)           <- withTiming $ Query.runQuery appState conf authResult apiReq plan sCache pgVer (Just authRole /= configDbAnonRole) observer
+  (respTime, resp)                   <- withTiming $ liftEither $ Response.actionResponse queryResult apiReq (T.decodeUtf8 prettyVersion, docsVersion) conf sCache iSchema iNegotiatedByProfile
+
+  return $ toWaiResponse (ServerTiming jwtTime parseTime planTime queryTime respTime) resp
 
   where
-    pgrstResponse :: ServerTiming -> Response.PgrstResponse -> Wai.Response
-    pgrstResponse timing (Response.PgrstResponse st hdrs bod) = Wai.responseLBS st (hdrs ++ ([serverTimingHeader timing | configServerTimingEnabled conf])) bod
-
-    withTiming = calcTiming $ configServerTimingEnabled conf
-
-calcTiming :: Bool -> Handler IO a -> Handler IO (Maybe Double, a)
-calcTiming timingEnabled f = if timingEnabled
-    then do
-      (t, r) <- timeItT f
-      pure (Just t, r)
-    else do
-      r <- f
-      pure (Nothing, r)
+    toWaiResponse :: ServerTiming -> Response.PgrstResponse -> Wai.Response
+    toWaiResponse timing (Response.PgrstResponse st hdrs bod) = Wai.responseLBS st (hdrs ++ ([serverTimingHeader timing | configServerTimingEnabled])) bod
+
+    withTiming :: Handler IO a -> Handler IO (Maybe Double, a)
+    withTiming f = if configServerTimingEnabled
+        then do
+          (t, r) <- timeItT f
+          pure (Just t, r)
+        else do
+          r <- f
+          pure (Nothing, r)
 
 traceHeaderMiddleware :: AppState -> Wai.Middleware
 traceHeaderMiddleware appState app req respond = do

src/PostgREST/Plan.hs

@@ -20,10 +20,9 @@ module PostgREST.Plan
   , ActionPlan(..)
   , DbActionPlan(..)
   , InspectPlan(..)
-  , inspectPlan
-  , callReadPlan
-  , planTxMode
-  , planIsoLvl
+  , InfoPlan(..)
+  , CrudPlan(..)
+  , CallReadPlan(..)
   ) where
 
 import qualified Data.ByteString.Lazy          as LBS
@@ -93,13 +92,14 @@ import Protolude hiding (from)
 -- Setup for doctests
 -- >>> import Data.Ranged.Ranges (fullRange)
 
-data DbActionPlan
+data CrudPlan
   = WrappedReadPlan
   { wrReadPlan :: ReadPlanTree
   , pTxMode    :: SQL.Mode
   , wrHandler  :: MediaHandler
   , wrMedia    :: MediaType
   , wrHdrsOnly :: Bool
+  , crudQi     :: QualifiedIdentifier
   }
   | MutateReadPlan {
     mrReadPlan   :: ReadPlanTree
@@ -108,15 +108,18 @@ data DbActionPlan
   , mrHandler    :: MediaHandler
   , mrMedia      :: MediaType
   , mrMutation   :: Mutation
+  , crudQi       :: QualifiedIdentifier
   }
-  | CallReadPlan {
+
+data CallReadPlan = CallReadPlan {
     crReadPlan :: ReadPlanTree
   , crCallPlan :: CallPlan
-  , pTxMode    :: SQL.Mode
+  , crTxMode   :: SQL.Mode
   , crProc     :: Routine
   , crHandler  :: MediaHandler
   , crMedia    :: MediaType
   , crInvMthd  :: InvokeMethod
+  , crQi       :: QualifiedIdentifier
   }
 
 data InspectPlan = InspectPlan {
@@ -126,46 +129,44 @@ data InspectPlan = InspectPlan {
   , ipSchema   :: Schema
   }
 
-data ActionPlan = Db DbActionPlan | MaybeDb InspectPlan
+data DbActionPlan = DbCrud CrudPlan | DbCall CallReadPlan | MaybeDb InspectPlan
+data InfoPlan     = RelInfoPlan QualifiedIdentifier | RoutineInfoPlan CallReadPlan | SchemaInfoPlan
+data ActionPlan   = Db DbActionPlan | NoDb InfoPlan
 
-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 :: Action -> AppConfig -> ApiRequest -> SchemaCache -> Either Error ActionPlan
+actionPlan act conf apiReq sCache = case act of
+    ActDb dbAct              -> Db <$> dbActionPlan dbAct conf apiReq sCache
+    ActRelationInfo ident    -> pure . NoDb $ RelInfoPlan ident
+    ActRoutineInfo ident inv -> NoDb . RoutineInfoPlan <$> callReadPlan ident conf sCache apiReq inv
+    ActSchemaInfo            -> pure $ NoDb SchemaInfoPlan
 
-actionPlan :: DbAction -> AppConfig -> ApiRequest -> SchemaCache -> Either Error ActionPlan
-actionPlan dbAct conf apiReq sCache = case dbAct of
+dbActionPlan :: DbAction -> AppConfig -> ApiRequest -> SchemaCache -> Either Error DbActionPlan
+dbActionPlan dbAct conf apiReq sCache = case dbAct of
   ActRelationRead identifier headersOnly ->
-    Db <$> wrappedReadPlan identifier conf sCache apiReq headersOnly
+    DbCrud <$> wrappedReadPlan identifier conf sCache apiReq headersOnly
   ActRelationMut identifier mut ->
-    Db <$> mutateReadPlan mut apiReq identifier conf sCache
+    DbCrud <$> mutateReadPlan mut apiReq identifier conf sCache
   ActRoutine identifier invMethod ->
-    Db <$> callReadPlan identifier conf sCache apiReq invMethod
+    DbCall <$> callReadPlan identifier conf sCache apiReq invMethod
   ActSchemaRead tSchema headersOnly ->
     MaybeDb <$> inspectPlan apiReq headersOnly tSchema
 
-wrappedReadPlan :: QualifiedIdentifier -> AppConfig -> SchemaCache -> ApiRequest -> Bool -> Either Error DbActionPlan
+wrappedReadPlan :: QualifiedIdentifier -> AppConfig -> SchemaCache -> ApiRequest -> Bool -> Either Error CrudPlan
 wrappedReadPlan  identifier conf sCache apiRequest@ApiRequest{iPreferences=Preferences{..},..} headersOnly = do
   rPlan <- readPlan identifier conf sCache apiRequest
   (handler, mediaType)  <- mapLeft ApiRequestError $ negotiateContent conf apiRequest identifier iAcceptMediaType (dbMediaHandlers sCache) (hasDefaultSelect rPlan)
   if not (null invalidPrefs) && preferHandling == Just Strict then Left $ ApiRequestError $ InvalidPreferences invalidPrefs else Right ()
-  return $ WrappedReadPlan rPlan SQL.Read handler mediaType headersOnly
+  return $ WrappedReadPlan rPlan SQL.Read handler mediaType headersOnly identifier
 
-mutateReadPlan :: Mutation -> ApiRequest -> QualifiedIdentifier -> AppConfig -> SchemaCache -> Either Error DbActionPlan
+mutateReadPlan :: Mutation -> ApiRequest -> QualifiedIdentifier -> AppConfig -> SchemaCache -> Either Error CrudPlan
 mutateReadPlan  mutation apiRequest@ApiRequest{iPreferences=Preferences{..},..} identifier conf sCache = do
   rPlan <- readPlan identifier conf sCache apiRequest
   mPlan <- mutatePlan mutation identifier apiRequest sCache rPlan
   if not (null invalidPrefs) && preferHandling == Just Strict then Left $ ApiRequestError $ InvalidPreferences invalidPrefs else Right ()
   (handler, mediaType)  <- mapLeft ApiRequestError $ negotiateContent conf apiRequest identifier iAcceptMediaType (dbMediaHandlers sCache) (hasDefaultSelect rPlan)
-  return $ MutateReadPlan rPlan mPlan SQL.Write handler mediaType mutation
+  return $ MutateReadPlan rPlan mPlan SQL.Write handler mediaType mutation identifier
 
-callReadPlan :: QualifiedIdentifier -> AppConfig -> SchemaCache -> ApiRequest -> InvokeMethod -> Either Error DbActionPlan
+callReadPlan :: QualifiedIdentifier -> AppConfig -> SchemaCache -> ApiRequest -> InvokeMethod -> Either Error CallReadPlan
 callReadPlan identifier conf sCache apiRequest@ApiRequest{iPreferences=Preferences{..},..} invMethod = do
   let paramKeys = case invMethod of
         InvRead _ -> S.fromList $ fst <$> qsParams'
@@ -186,7 +187,7 @@ callReadPlan identifier conf sCache apiRequest@ApiRequest{iPreferences=Preferenc
       cPlan = callPlan proc apiRequest paramKeys args rPlan
   (handler, mediaType)  <- mapLeft ApiRequestError $ negotiateContent conf apiRequest relIdentifier iAcceptMediaType (dbMediaHandlers sCache) (hasDefaultSelect rPlan)
   if not (null invalidPrefs) && preferHandling == Just Strict then Left $ ApiRequestError $ InvalidPreferences invalidPrefs else Right ()
-  return $ CallReadPlan rPlan cPlan txMode proc handler mediaType invMethod
+  return $ CallReadPlan rPlan cPlan txMode proc handler mediaType invMethod identifier
   where
     qsParams' = QueryParams.qsParams iQueryParams