refactor: use a data type instead of Map for Server Timing
This commit is contained in:
Laurence Isla
+18
-34
@@ -51,16 +51,14 @@ import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.Config.PgVersion (PgVersion (..))
|
||||
import PostgREST.Error (Error)
|
||||
import PostgREST.Query (DbHandler)
|
||||
import PostgREST.Response.Performance (ServerMetric (..),
|
||||
ServerTimingData,
|
||||
renderServerTimingHeader)
|
||||
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
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Map as Map (fromList)
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import qualified Network.Socket as NS
|
||||
import Protolude hiding (Handler)
|
||||
@@ -150,12 +148,8 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache pgVer authResult@
|
||||
liftEither . mapLeft Error.ApiRequestError $
|
||||
ApiRequest.userApiRequest conf req body sCache
|
||||
|
||||
let
|
||||
jwtAndParseTiming =
|
||||
[(SMJwt, if configServerTimingEnabled then Auth.getJwtDur req else Nothing)
|
||||
,(SMParse, parseTime)]
|
||||
|
||||
handleRequest authResult conf appState (Just authRole /= configDbAnonRole) configDbPreparedStatements pgVer apiRequest sCache jwtAndParseTiming
|
||||
let jwtTime = if configServerTimingEnabled then Auth.getJwtDur req else Nothing
|
||||
handleRequest authResult conf appState (Just authRole /= configDbAnonRole) configDbPreparedStatements pgVer apiRequest sCache jwtTime parseTime
|
||||
|
||||
runDbHandler :: AppState.AppState -> AppConfig -> SQL.IsolationLevel -> SQL.Mode -> Bool -> Bool -> DbHandler b -> Handler IO b
|
||||
runDbHandler appState config isoLvl mode authenticated prepared handler = do
|
||||
@@ -169,73 +163,63 @@ runDbHandler appState config isoLvl mode authenticated prepared handler = do
|
||||
|
||||
liftEither resp
|
||||
|
||||
handleRequest :: AuthResult -> AppConfig -> AppState.AppState -> Bool -> Bool -> PgVersion -> ApiRequest -> SchemaCache -> [(ServerMetric, Maybe Double)] -> Handler IO Wai.Response
|
||||
handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@ApiRequest{..} sCache jwtAndParseTime =
|
||||
handleRequest :: AuthResult -> AppConfig -> AppState.AppState -> Bool -> Bool -> PgVersion -> ApiRequest -> SchemaCache -> Maybe Double -> Maybe Double -> Handler IO Wai.Response
|
||||
handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@ApiRequest{..} sCache jwtTime parseTime =
|
||||
case (iAction, iTarget) of
|
||||
(ActionRead headersOnly, TargetIdent identifier) -> do
|
||||
(planTime', wrPlan) <- withTiming $ liftEither $ Plan.wrappedReadPlan identifier conf sCache apiReq
|
||||
(txTime', resultSet) <- withTiming $ runQuery roleIsoLvl Nothing (Plan.wrTxMode wrPlan) $ Query.readQuery wrPlan conf apiReq
|
||||
(respTime', pgrst) <- withTiming $ liftEither $ Response.readResponse wrPlan headersOnly identifier apiReq resultSet
|
||||
let metrics = Map.fromList $ [(SMPlan, planTime'), (SMTransaction, txTime'), (SMResp, respTime')] ++ jwtAndParseTime
|
||||
return $ pgrstResponse metrics pgrst
|
||||
return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
|
||||
|
||||
(ActionMutate MutationCreate, TargetIdent identifier) -> do
|
||||
(planTime', mrPlan) <- withTiming $ liftEither $ Plan.mutateReadPlan MutationCreate apiReq identifier conf sCache
|
||||
(txTime', resultSet) <- withTiming $ runQuery roleIsoLvl Nothing (Plan.mrTxMode mrPlan) $ Query.createQuery mrPlan apiReq conf
|
||||
(respTime', pgrst) <- withTiming $ liftEither $ Response.createResponse identifier mrPlan apiReq resultSet
|
||||
let metrics = Map.fromList $ [(SMPlan, planTime'), (SMTransaction, txTime'), (SMResp, respTime')] ++ jwtAndParseTime
|
||||
return $ pgrstResponse metrics pgrst
|
||||
return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
|
||||
|
||||
(ActionMutate MutationUpdate, TargetIdent identifier) -> do
|
||||
(planTime', mrPlan) <- withTiming $ liftEither $ Plan.mutateReadPlan MutationUpdate apiReq identifier conf sCache
|
||||
(txTime', resultSet) <- withTiming $ runQuery roleIsoLvl Nothing (Plan.mrTxMode mrPlan) $ Query.updateQuery mrPlan apiReq conf
|
||||
(respTime', pgrst) <- withTiming $ liftEither $ Response.updateResponse mrPlan apiReq resultSet
|
||||
let metrics = Map.fromList $ [(SMPlan, planTime'), (SMTransaction, txTime'), (SMResp, respTime')] ++ jwtAndParseTime
|
||||
return $ pgrstResponse metrics pgrst
|
||||
return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
|
||||
|
||||
(ActionMutate MutationSingleUpsert, TargetIdent identifier) -> do
|
||||
(planTime', mrPlan) <- withTiming $ liftEither $ Plan.mutateReadPlan MutationSingleUpsert apiReq identifier conf sCache
|
||||
(txTime', resultSet) <- withTiming $ runQuery roleIsoLvl Nothing (Plan.mrTxMode mrPlan) $ Query.singleUpsertQuery mrPlan apiReq conf
|
||||
(respTime', pgrst) <- withTiming $ liftEither $ Response.singleUpsertResponse mrPlan apiReq resultSet
|
||||
let metrics = Map.fromList $ [(SMPlan, planTime'), (SMTransaction, txTime'), (SMResp, respTime')] ++ jwtAndParseTime
|
||||
return $ pgrstResponse metrics pgrst
|
||||
return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
|
||||
|
||||
(ActionMutate MutationDelete, TargetIdent identifier) -> do
|
||||
(planTime', mrPlan) <- withTiming $ liftEither $ Plan.mutateReadPlan MutationDelete apiReq identifier conf sCache
|
||||
(txTime', resultSet) <- withTiming $ runQuery roleIsoLvl Nothing (Plan.mrTxMode mrPlan) $ Query.deleteQuery mrPlan apiReq conf
|
||||
(respTime', pgrst) <- withTiming $ liftEither $ Response.deleteResponse mrPlan apiReq resultSet
|
||||
let metrics = Map.fromList $ [(SMPlan, planTime'), (SMTransaction, txTime'), (SMResp, respTime')] ++ jwtAndParseTime
|
||||
return $ pgrstResponse metrics pgrst
|
||||
return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
|
||||
|
||||
(ActionInvoke invMethod, TargetProc identifier _) -> do
|
||||
(planTime', cPlan) <- withTiming $ liftEither $ Plan.callReadPlan identifier conf sCache apiReq invMethod
|
||||
(txTime', resultSet) <- withTiming $ runQuery (fromMaybe roleIsoLvl $ pdIsoLvl (Plan.crProc cPlan)) (pdTimeout $ 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
|
||||
let metrics = Map.fromList $ [(SMPlan, planTime'), (SMTransaction, txTime'), (SMResp, respTime')] ++ jwtAndParseTime
|
||||
return $ pgrstResponse metrics pgrst
|
||||
return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
|
||||
|
||||
(ActionInspect headersOnly, TargetDefaultSpec tSchema) -> do
|
||||
(planTime', iPlan) <- withTiming $ liftEither $ Plan.inspectPlan apiReq
|
||||
(txTime', oaiResult) <- withTiming $ runQuery roleIsoLvl Nothing (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
|
||||
let metrics = Map.fromList $ [(SMPlan, planTime'), (SMTransaction, txTime'), (SMResp, respTime')] ++ jwtAndParseTime
|
||||
return $ pgrstResponse metrics pgrst
|
||||
return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
|
||||
|
||||
(ActionInfo, TargetIdent identifier) -> do
|
||||
(respTime', pgrst) <- withTiming $ liftEither $ Response.infoIdentResponse identifier sCache
|
||||
let metrics = Map.fromList $ (SMResp, respTime'):jwtAndParseTime
|
||||
return $ pgrstResponse metrics pgrst
|
||||
return $ pgrstResponse (ServerTiming jwtTime parseTime Nothing Nothing respTime') pgrst
|
||||
|
||||
(ActionInfo, TargetProc identifier _) -> do
|
||||
(planTime', cPlan) <- withTiming $ liftEither $ Plan.callReadPlan identifier conf sCache apiReq ApiRequest.InvHead
|
||||
(respTime', pgrst) <- withTiming $ liftEither $ Response.infoProcResponse (Plan.crProc cPlan)
|
||||
let metrics = Map.fromList $ [(SMPlan, planTime'), (SMResp, respTime')] ++ jwtAndParseTime
|
||||
return $ pgrstResponse metrics pgrst
|
||||
return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' Nothing respTime') pgrst
|
||||
|
||||
(ActionInfo, TargetDefaultSpec _) -> do
|
||||
(respTime', pgrst) <- withTiming $ liftEither Response.infoRootResponse
|
||||
let metrics = Map.fromList $ (SMResp, respTime'):jwtAndParseTime
|
||||
return $ pgrstResponse metrics pgrst
|
||||
return $ pgrstResponse (ServerTiming jwtTime parseTime Nothing Nothing respTime') pgrst
|
||||
|
||||
_ ->
|
||||
-- This is unreachable as the ApiRequest.hs rejects it before
|
||||
@@ -250,8 +234,8 @@ handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@A
|
||||
Query.runPreReq conf
|
||||
query
|
||||
|
||||
pgrstResponse :: ServerTimingData -> Response.PgrstResponse -> Wai.Response
|
||||
pgrstResponse timings (Response.PgrstResponse st hdrs bod) = Wai.responseLBS st (hdrs ++ ([renderServerTimingHeader timings | configServerTimingEnabled conf])) bod
|
||||
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
|
||||
|
||||
|
||||
@@ -1,36 +1,36 @@
|
||||
module PostgREST.Response.Performance
|
||||
( ServerMetric(..)
|
||||
, ServerTimingData
|
||||
, renderServerTimingHeader
|
||||
( ServerTiming (..)
|
||||
, serverTimingHeader
|
||||
)
|
||||
where
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.Map as Map
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Numeric (showFFloat)
|
||||
import Protolude
|
||||
|
||||
data ServerMetric =
|
||||
SMJwt
|
||||
| SMParse
|
||||
| SMPlan
|
||||
| SMTransaction
|
||||
| SMResp
|
||||
deriving (Show, Eq, Ord)
|
||||
type ServerTimingData = Map ServerMetric (Maybe Double)
|
||||
data ServerTiming =
|
||||
ServerTiming
|
||||
{ jwt :: Maybe Double
|
||||
, parse :: Maybe Double
|
||||
, plan :: Maybe Double
|
||||
, transaction :: Maybe Double
|
||||
, response :: Maybe Double
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- | Render the Server-Timing header from a ServerTimingData
|
||||
--
|
||||
-- >>> renderServerTimingHeader $ Map.fromList [(SMPlan, Just 0.1), (SMTransaction, Just 0.2), (SMResp, Just 0.3), (SMJwt, Just 0.4), (SMParse, Just 0.5)]
|
||||
-- >>> serverTimingHeader ServerTiming { plan=Just 0.1, transaction=Just 0.2, response=Just 0.3, jwt=Just 0.4, parse=Just 0.5}
|
||||
-- ("Server-Timing","jwt;dur=400000.0, parse;dur=500000.0, plan;dur=100000.0, transaction;dur=200000.0, response;dur=300000.0")
|
||||
renderServerTimingHeader :: ServerTimingData -> HTTP.Header
|
||||
renderServerTimingHeader timingData =
|
||||
("Server-Timing", BS.intercalate ", " $ map renderTiming $ Map.toList timingData)
|
||||
renderTiming :: (ServerMetric, Maybe Double) -> BS.ByteString
|
||||
renderTiming (metric, time) = maybe "" (\x -> BS.concat [renderMetric metric, BS.pack $ ";dur=" <> showFFloat (Just 1) (x * 1000000) ""]) time
|
||||
serverTimingHeader :: ServerTiming -> HTTP.Header
|
||||
serverTimingHeader timing =
|
||||
("Server-Timing", renderTiming)
|
||||
where
|
||||
renderMetric SMJwt = "jwt"
|
||||
renderMetric SMParse = "parse"
|
||||
renderMetric SMPlan = "plan"
|
||||
renderMetric SMTransaction = "transaction"
|
||||
renderMetric SMResp = "response"
|
||||
renderMetric metric = maybe "" (\dur -> BS.concat [metric, BS.pack $ ";dur=" <> showFFloat (Just 1) (dur * 1000000) ""])
|
||||
renderTiming = BS.intercalate ", " $ (\(k, v) -> renderMetric k (v timing)) <$>
|
||||
[ ("jwt", jwt)
|
||||
, ("parse", parse)
|
||||
, ("plan", plan)
|
||||
, ("transaction", transaction)
|
||||
, ("response", response)
|
||||
]
|
||||
|
||||
Reference in New Issue
Block a user