refactor: dry some timings calculation

PostgREST · Mar 27, 2024 · 745e786 · 745e786
1 parent 378c111
commit 745e786
Show file tree

Hide file tree

Showing 5 changed files with 231 additions and 273 deletions.
diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs
@@ -11,9 +11,7 @@ module PostgREST.ApiRequest
   , Mutation(..)
   , MediaType(..)
   , Action(..)
-  , ActionRelation(..)
-  , ActionRoutine(..)
-  , ActionSchema(..)
+  , DbAction(..)
   , Payload(..)
   , userApiRequest
   ) where
@@ -92,23 +90,17 @@ data Resource
   | ResourceRoutine Text
   | ResourceSchema
 
-data ActionRelation
-  = ActRead Bool
-  | ActMutate Mutation
-  | ActRelInfo
-
-data ActionRoutine
-  = ActInvoke InvokeMethod
-  | ActRoutInfo
-
-data ActionSchema
-  = ActSchemaRead Bool
-  | ActSchemaInfo
+data DbAction
+  = ActRelationRead {dbActQi :: QualifiedIdentifier, actHeadersOnly :: Bool}
+  | ActRelationMut  {dbActQi :: QualifiedIdentifier, actMutation :: Mutation}
+  | ActRoutine      {dbActQi :: QualifiedIdentifier, actInvMethod :: InvokeMethod}
 
 data Action
-  = ActRelation QualifiedIdentifier ActionRelation
-  | ActRoutine QualifiedIdentifier ActionRoutine
-  | ActSchema Schema ActionSchema
+  = ActDb           DbAction
+  | ActSchemaRead   Schema Bool
+  | ActRelationInfo QualifiedIdentifier
+  | ActRoutineInfo  QualifiedIdentifier
+  | ActSchemaInfo   Schema
 
 {-|
   Describes what the user wants to do. This data type is a
@@ -168,7 +160,7 @@ userApiRequest conf req reqBody sCache = do
     iHdrs = [ (CI.foldedCase k, v) | (k,v) <- hdrs, k /= hCookie]
     iCkies = maybe [] parseCookies $ lookupHeader "Cookie"
     contentMediaType = maybe MTApplicationJSON MediaType.decodeMediaType $ lookupHeader "content-type"
-    actIsInvokeSafe x = case x of {ActRoutine _  (ActInvoke (InvRead _)) -> True; _ -> False}
+    actIsInvokeSafe x = case x of {ActDb (ActRoutine _  (InvRead _)) -> True; _ -> False}
 
 getResource :: AppConfig -> [Text] -> Either ApiRequestError Resource
 getResource AppConfig{configOpenApiMode, configDbRootSpec} = \case
@@ -183,23 +175,23 @@ getResource AppConfig{configOpenApiMode, configDbRootSpec} = \case
 getAction :: Resource -> Schema -> ByteString -> Either ApiRequestError Action
 getAction resource schema method =
   case (resource, method) of
-    (ResourceRoutine rout, "HEAD")    -> Right $ ActRoutine (qi rout) $ ActInvoke $ InvRead True
-    (ResourceRoutine rout, "GET")     -> Right $ ActRoutine (qi rout) $ ActInvoke $ InvRead False
-    (ResourceRoutine rout, "POST")    -> Right $ ActRoutine (qi rout) $ ActInvoke Inv
-    (ResourceRoutine rout, "OPTIONS") -> Right $ ActRoutine (qi rout) ActRoutInfo
+    (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 _, _)            -> Left $ InvalidRpcMethod method
 
-    (ResourceRelation rel, "HEAD")    -> Right $ ActRelation (qi rel) $ ActRead True
-    (ResourceRelation rel, "GET")     -> Right $ ActRelation (qi rel) $ ActRead False
-    (ResourceRelation rel, "POST")    -> Right $ ActRelation (qi rel) $ ActMutate MutationCreate
-    (ResourceRelation rel, "PUT")     -> Right $ ActRelation (qi rel) $ ActMutate MutationSingleUpsert
-    (ResourceRelation rel, "PATCH")   -> Right $ ActRelation (qi rel) $ ActMutate MutationUpdate
-    (ResourceRelation rel, "DELETE")  -> Right $ ActRelation (qi rel) $ ActMutate MutationDelete
-    (ResourceRelation rel, "OPTIONS") -> Right $ ActRelation (qi rel) ActRelInfo
+    (ResourceRelation rel, "HEAD")    -> Right . ActDb $ ActRelationRead (qi rel) True
+    (ResourceRelation rel, "GET")     -> Right . ActDb $ ActRelationRead (qi rel) False
+    (ResourceRelation rel, "POST")    -> Right . ActDb $ ActRelationMut  (qi rel) MutationCreate
+    (ResourceRelation rel, "PUT")     -> Right . ActDb $ ActRelationMut  (qi rel) MutationSingleUpsert
+    (ResourceRelation rel, "PATCH")   -> Right . ActDb $ ActRelationMut  (qi rel) MutationUpdate
+    (ResourceRelation rel, "DELETE")  -> Right . ActDb $ ActRelationMut  (qi rel) MutationDelete
+    (ResourceRelation rel, "OPTIONS") -> Right $ ActRelationInfo (qi rel)
 
-    (ResourceSchema, "HEAD")          -> Right $ ActSchema schema $ ActSchemaRead True
-    (ResourceSchema, "GET")           -> Right $ ActSchema schema $ ActSchemaRead False
-    (ResourceSchema, "OPTIONS")       -> Right $ ActSchema schema ActSchemaInfo
+    (ResourceSchema, "HEAD")          -> Right $ ActSchemaRead schema True
+    (ResourceSchema, "GET")           -> Right $ ActSchemaRead schema False
+    (ResourceSchema, "OPTIONS")       -> Right $ ActSchemaInfo schema
 
     _                                 -> Left $ UnsupportedMethod method
   where
@@ -279,20 +271,20 @@ getPayload reqBody contentMediaType QueryParams{qsColumns} action = do
       (ct, _) -> Left $ "Content-Type not acceptable: " <> MediaType.toMime ct
 
     shouldParsePayload = case action of
-      ActRelation _ (ActMutate MutationDelete) -> False
-      ActRelation _ (ActMutate _)              -> True
-      ActRoutine _  (ActInvoke Inv)            -> True
-      _                                        -> False
+      ActDb (ActRelationMut _ MutationDelete) -> False
+      ActDb (ActRelationMut _ _)              -> True
+      ActDb (ActRoutine _  Inv)               -> True
+      _                                       -> False
 
     columns = case action of
-      ActRelation _ (ActMutate MutationCreate) -> qsColumns
-      ActRelation _ (ActMutate MutationUpdate) -> qsColumns
-      ActRoutine  _ (ActInvoke Inv)            -> qsColumns
-      _                                        -> Nothing
+      ActDb (ActRelationMut _ MutationCreate) -> qsColumns
+      ActDb (ActRelationMut _ MutationUpdate) -> qsColumns
+      ActDb (ActRoutine     _ Inv)            -> qsColumns
+      _                                       -> Nothing
 
     isProc = case action of
-      ActRoutine _ _ -> True
-      _              -> False
+      ActDb (ActRoutine _ _) -> True
+      _                      -> False
     params = (T.decodeUtf8 *** T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody)
 
 type CsvData = V.Vector (M.Map Text LBS.ByteString)

diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs
@@ -41,11 +41,8 @@ import qualified PostgREST.Query      as Query
 import qualified PostgREST.Response   as Response
 import qualified PostgREST.Unix       as Unix (installSignalHandlers)
 
-import PostgREST.ApiRequest           (Action (..),
-                                       ActionRelation (..),
-                                       ActionRoutine (..),
-                                       ActionSchema (..),
-                                       ApiRequest (..), Mutation (..))
+import PostgREST.ApiRequest           (Action (..), ApiRequest (..),
+                                       DbAction (..))
 import PostgREST.AppState             (AppState)
 import PostgREST.Auth                 (AuthResult (..))
 import PostgREST.Config               (AppConfig (..), LogLevel (..))
@@ -172,58 +169,28 @@ handleRequest :: AuthResult -> AppConfig -> AppState.AppState -> Bool -> Bool ->
                 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
-    ActRelation identifier (ActRead headersOnly) -> do
-      (planTime', wrPlan) <- withTiming $ liftEither $ Plan.wrappedReadPlan identifier conf sCache apiReq
-      (txTime', resultSet) <- withTiming $ runQuery roleIsoLvl mempty (Plan.wrTxMode wrPlan) $ Query.readQuery wrPlan conf apiReq
-      (respTime', pgrst) <- withTiming $ liftEither $ Response.readResponse wrPlan headersOnly identifier apiReq resultSet
+    ActDb dbAct -> do
+      (planTime', plan) <- withTiming $ liftEither $ Plan.actionPlan dbAct conf apiReq sCache
+      (txTime', resultSet) <- withTiming $ runQuery (planIsoLvl plan) (planFunSettings plan) (Plan.pTxMode plan) $ Query.actionQuery plan conf apiReq pgVer
+      (respTime', pgrst) <- withTiming $ liftEither $ Response.actionResponse plan (dbActQi dbAct) apiReq resultSet
       return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
 
-    ActRelation identifier (ActMutate MutationCreate) -> do
-      (planTime', mrPlan) <- withTiming $ liftEither $ Plan.mutateReadPlan MutationCreate apiReq identifier conf sCache
-      (txTime', resultSet) <- withTiming $ runQuery roleIsoLvl mempty (Plan.mrTxMode mrPlan) $ Query.createQuery mrPlan apiReq conf
-      (respTime', pgrst) <- withTiming $ liftEither $ Response.createResponse identifier mrPlan apiReq resultSet
+    ActSchemaRead tSchema headersOnly -> do
+      (planTime', iPlan) <- withTiming $ liftEither $ Plan.inspectPlan apiReq headersOnly tSchema
+      (txTime', oaiResult) <- withTiming $ runQuery roleIsoLvl mempty (Plan.ipTxmode iPlan) $ Query.openApiQuery iPlan conf sCache pgVer
+      (respTime', pgrst) <- withTiming $ liftEither $ Response.openApiResponse iPlan (T.decodeUtf8 prettyVersion, docsVersion) oaiResult conf sCache iSchema iNegotiatedByProfile
       return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
 
-    ActRelation identifier (ActMutate MutationUpdate) -> do
-      (planTime', mrPlan) <- withTiming $ liftEither $ Plan.mutateReadPlan MutationUpdate apiReq identifier conf sCache
-      (txTime', resultSet) <- withTiming $ runQuery roleIsoLvl mempty (Plan.mrTxMode mrPlan) $ Query.updateQuery mrPlan apiReq conf
-      (respTime', pgrst) <- withTiming $ liftEither $ Response.updateResponse mrPlan apiReq resultSet
-      return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
-
-    ActRelation identifier (ActMutate MutationSingleUpsert) -> do
-      (planTime', mrPlan) <- withTiming $ liftEither $ Plan.mutateReadPlan MutationSingleUpsert apiReq identifier conf sCache
-      (txTime', resultSet) <- withTiming $ runQuery roleIsoLvl mempty (Plan.mrTxMode mrPlan) $ Query.singleUpsertQuery mrPlan apiReq conf
-      (respTime', pgrst) <- withTiming $ liftEither $ Response.singleUpsertResponse mrPlan apiReq resultSet
-      return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
-
-    ActRelation identifier (ActMutate MutationDelete) -> do
-      (planTime', mrPlan) <- withTiming $ liftEither $ Plan.mutateReadPlan MutationDelete apiReq identifier conf sCache
-      (txTime', resultSet) <- withTiming $ runQuery roleIsoLvl mempty (Plan.mrTxMode mrPlan) $ Query.deleteQuery mrPlan apiReq conf
-      (respTime', pgrst) <- withTiming $ liftEither $ Response.deleteResponse mrPlan apiReq resultSet
-      return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
-
-    ActRoutine identifier (ActInvoke invMethod) -> do
-      (planTime', cPlan) <- withTiming $ liftEither $ Plan.callReadPlan identifier conf sCache apiReq invMethod
-      (txTime', resultSet) <- withTiming $ runQuery (fromMaybe roleIsoLvl $ pdIsoLvl (Plan.crProc cPlan)) (pdFuncSettings $ Plan.crProc cPlan) (Plan.crTxMode cPlan) $ Query.invokeQuery (Plan.crProc cPlan) cPlan apiReq conf pgVer
-      (respTime', pgrst) <- withTiming $ liftEither $ Response.invokeResponse cPlan invMethod (Plan.crProc cPlan) apiReq resultSet
-      return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
-
-    ActSchema tSchema (ActSchemaRead headersOnly) -> do
-      (planTime', iPlan) <- withTiming $ liftEither $ Plan.inspectPlan apiReq
-      (txTime', oaiResult) <- withTiming $ runQuery roleIsoLvl mempty (Plan.ipTxmode iPlan) $ Query.openApiQuery sCache pgVer conf tSchema
-      (respTime', pgrst) <- withTiming $ liftEither $ Response.openApiResponse (T.decodeUtf8 prettyVersion, docsVersion) headersOnly oaiResult conf sCache iSchema iNegotiatedByProfile
-      return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
-
-    ActRelation identifier ActRelInfo -> do
+    ActRelationInfo identifier -> do
       (respTime', pgrst) <- withTiming $ liftEither $ Response.infoIdentResponse identifier sCache
       return $ pgrstResponse (ServerTiming jwtTime parseTime Nothing Nothing respTime') pgrst
 
-    ActRoutine identifier ActRoutInfo -> do
+    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
 
-    ActSchema _ ActSchemaInfo -> do
+    ActSchemaInfo _ -> do
       (respTime', pgrst) <- withTiming $ liftEither Response.infoRootResponse
       return $ pgrstResponse (ServerTiming jwtTime parseTime Nothing Nothing respTime') pgrst
 
@@ -236,6 +203,12 @@ handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@A
         Query.runPreReq conf
         query
 
+    planIsoLvl (Plan.CallReadPlan{crProc}) = fromMaybe roleIsoLvl $ pdIsoLvl crProc
+    planIsoLvl _ = roleIsoLvl
+
+    planFunSettings (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