feat: add Server-Timing header with JWT duration

CHANGELOG.md

@@ -9,6 +9,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 
  - #1614, Add `db-pool-automatic-recovery` configuration to disable connection retrying - @taimoorzaeem
  - #2492, Allow full response control when raising exceptions - @taimoorzaeem, @laurenceisla
+ - #2771, Add `Server-Timing` header with JWT duration - @taimoorzaeem
 
 ### Fixed
 

postgrest.cabal

@@ -114,6 +114,7 @@ library
                     , swagger2                  >= 2.4 && < 2.9
                     , text                      >= 1.2.2 && < 1.3
                     , time                      >= 1.6 && < 1.12
+                    , timeit                    >= 1.0.0 && < 1.1.0
                     , unordered-containers      >= 0.2.8 && < 0.3
                     , vault                     >= 0.3.1.5 && < 0.4
                     , vector                    >= 0.11 && < 0.14
@@ -203,22 +204,23 @@ test-suite spec
                       Feature.Query.DeleteSpec
                       Feature.Query.EmbedDisambiguationSpec
                       Feature.Query.EmbedInnerJoinSpec
-                      Feature.Query.PlanSpec
+                      Feature.Query.ErrorSpec
                       Feature.Query.HtmlRawOutputSpec
                       Feature.Query.InsertSpec
                       Feature.Query.JsonOperatorSpec
                       Feature.Query.MultipleSchemaSpec
-                      Feature.Query.ErrorSpec
+                      Feature.Query.NullsStrip
                       Feature.Query.PgSafeUpdateSpec
+                      Feature.Query.PlanSpec
                       Feature.Query.PostGISSpec
                       Feature.Query.QueryLimitedSpec
                       Feature.Query.QuerySpec
                       Feature.Query.RangeSpec
                       Feature.Query.RawOutputTypesSpec
                       Feature.Query.RelatedQueriesSpec
                       Feature.Query.RpcSpec
+                      Feature.Query.ServerTiming
                       Feature.Query.SingularSpec
-                      Feature.Query.NullsStrip
                       Feature.Query.SpreadQueriesSpec
                       Feature.Query.UnicodeSpec
                       Feature.Query.UpdateSpec

src/PostgREST/App.hs

@@ -52,6 +52,7 @@ import PostgREST.Config              (AppConfig (..))
 import PostgREST.Config.PgVersion    (PgVersion (..))
 import PostgREST.Error               (Error)
 import PostgREST.Query               (DbHandler)
+import PostgREST.Response            (ServerTimingParams (..))
 import PostgREST.SchemaCache         (SchemaCache (..))
 import PostgREST.SchemaCache.Routine (Routine (..))
 import PostgREST.Version             (docsVersion, prettyVersion)
@@ -150,8 +151,9 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache pgVer authResult@
     liftEither . mapLeft Error.ApiRequestError $
       ApiRequest.userApiRequest conf req body
 
+  let serverTimingParams = if configDbPlanEnabled then Just (ServerTimingParams { jwtDur = fromJust $ Auth.getJwtDur req }) else Nothing
   Response.optionalRollback conf apiRequest $
-    handleRequest authResult conf appState (Just authRole /= configDbAnonRole) configDbPreparedStatements pgVer apiRequest sCache
+    handleRequest authResult conf appState (Just authRole /= configDbAnonRole) configDbPreparedStatements pgVer apiRequest sCache serverTimingParams
 
 runDbHandler :: AppState.AppState -> SQL.IsolationLevel -> SQL.Mode -> Bool -> Bool -> DbHandler b -> Handler IO b
 runDbHandler appState isoLvl mode authenticated prepared handler = do
@@ -165,38 +167,38 @@ runDbHandler appState isoLvl mode authenticated prepared handler = do
 
   liftEither resp
 
-handleRequest :: AuthResult -> AppConfig -> AppState.AppState -> Bool -> Bool -> PgVersion -> ApiRequest -> SchemaCache -> Handler IO Wai.Response
-handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@ApiRequest{..} sCache =
+handleRequest :: AuthResult -> AppConfig -> AppState.AppState -> Bool -> Bool -> PgVersion -> ApiRequest -> SchemaCache -> Maybe ServerTimingParams -> Handler IO Wai.Response
+handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@ApiRequest{..} sCache serverTimingParams =
   case (iAction, iTarget) of
     (ActionRead headersOnly, TargetIdent identifier) -> do
       wrPlan <- liftEither $ Plan.wrappedReadPlan identifier conf sCache apiReq
       resultSet <- runQuery roleIsoLvl (Plan.wrTxMode wrPlan) $ Query.readQuery wrPlan conf apiReq
-      return $ Response.readResponse headersOnly identifier apiReq resultSet
+      return $ Response.readResponse headersOnly identifier apiReq resultSet serverTimingParams
 
     (ActionMutate MutationCreate, TargetIdent identifier) -> do
       mrPlan <- liftEither $ Plan.mutateReadPlan MutationCreate apiReq identifier conf sCache
       resultSet <- runQuery roleIsoLvl (Plan.mrTxMode mrPlan) $ Query.createQuery mrPlan apiReq conf
-      return $ Response.createResponse identifier mrPlan apiReq resultSet
+      return $ Response.createResponse identifier mrPlan apiReq resultSet serverTimingParams
 
     (ActionMutate MutationUpdate, TargetIdent identifier) -> do
       mrPlan <- liftEither $ Plan.mutateReadPlan MutationUpdate apiReq identifier conf sCache
       resultSet <- runQuery roleIsoLvl (Plan.mrTxMode mrPlan) $ Query.updateQuery mrPlan apiReq conf
-      return $ Response.updateResponse apiReq resultSet
+      return $ Response.updateResponse apiReq resultSet serverTimingParams
 
     (ActionMutate MutationSingleUpsert, TargetIdent identifier) -> do
       mrPlan <- liftEither $ Plan.mutateReadPlan MutationSingleUpsert apiReq identifier conf sCache
       resultSet <- runQuery roleIsoLvl (Plan.mrTxMode mrPlan) $ Query.singleUpsertQuery mrPlan apiReq conf
-      return $ Response.singleUpsertResponse apiReq resultSet
+      return $ Response.singleUpsertResponse apiReq resultSet serverTimingParams
 
     (ActionMutate MutationDelete, TargetIdent identifier) -> do
       mrPlan <- liftEither $ Plan.mutateReadPlan MutationDelete apiReq identifier conf sCache
       resultSet <- runQuery roleIsoLvl (Plan.mrTxMode mrPlan) $ Query.deleteQuery mrPlan apiReq conf
-      return $ Response.deleteResponse apiReq resultSet
+      return $ Response.deleteResponse apiReq resultSet serverTimingParams
 
     (ActionInvoke invMethod, TargetProc identifier _) -> do
       cPlan <- liftEither $ Plan.callReadPlan identifier conf sCache apiReq invMethod
       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
+      return $ Response.invokeResponse invMethod (Plan.crProc cPlan) apiReq resultSet serverTimingParams
 
     (ActionInspect headersOnly, TargetDefaultSpec tSchema) -> do
       oaiResult <- runQuery roleIsoLvl Plan.inspectPlanTxMode $ Query.openApiQuery sCache pgVer conf tSchema

src/PostgREST/Auth.hs

@@ -14,6 +14,7 @@ very simple authentication system inside the PostgreSQL database.
 module PostgREST.Auth
   ( AuthResult (..)
   , getResult
+  , getJwtDur
   , getRole
   , middleware
   ) where
@@ -37,6 +38,7 @@ import Data.Either.Combinators (mapLeft)
 import Data.List               (lookup)
 import Data.Time.Clock         (UTCTime)
 import System.IO.Unsafe        (unsafePerformIO)
+import System.TimeIt           (timeItT)
 
 import PostgREST.AppState (AppState, getConfig, getTime)
 import PostgREST.Config   (AppConfig (..), JSPath, JSPathExp (..))
@@ -102,12 +104,12 @@ middleware appState app req respond = do
   conf <- getConfig appState
   time <- getTime appState
 
-  let token = fromMaybe "" $ Wai.extractBearerAuth =<< lookup HTTP.hAuthorization (Wai.requestHeaders req)
-  authResult <- runExceptT $
-    parseToken conf (LBS.fromStrict token) time >>=
-    parseClaims conf
+  let token  = fromMaybe "" $ Wai.extractBearerAuth =<< lookup HTTP.hAuthorization (Wai.requestHeaders req)
+      parseJwt = runExceptT $ parseToken conf (LBS.fromStrict token) time >>= parseClaims conf
 
-  let req' = req { Wai.vault = Wai.vault req & Vault.insert authResultKey authResult }
+  (dur,authResult) <- timeItT parseJwt
+
+  let req' = req { Wai.vault = Wai.vault req & Vault.insert authResultKey authResult & Vault.insert jwtDurKey dur }
   app req' respond
 
 authResultKey :: Vault.Key (Either Error AuthResult)
@@ -117,5 +119,12 @@ authResultKey = unsafePerformIO Vault.newKey
 getResult :: Wai.Request -> Maybe (Either Error AuthResult)
 getResult = Vault.lookup authResultKey . Wai.vault
 
+jwtDurKey :: Vault.Key Double
+jwtDurKey = unsafePerformIO Vault.newKey
+{-# NOINLINE jwtDurKey #-}
+
+getJwtDur :: Wai.Request -> Maybe Double
+getJwtDur =  Vault.lookup jwtDurKey . Wai.vault
+
 getRole :: Wai.Request -> Maybe BS.ByteString
 getRole req = authRole <$> (rightToMaybe =<< getResult req)

src/PostgREST/Response.hs

@@ -21,6 +21,7 @@ module PostgREST.Response
   , concatPrefAppsHeaders
   , addPrefToHeaders
   , traceHeaderMiddleware
+  , ServerTimingParams(..)
   ) where
 
 import qualified Data.Aeson                as JSON
@@ -33,6 +34,7 @@ import qualified Network.HTTP.Types.Header as HTTP
 import qualified Network.HTTP.Types.Status as HTTP
 import qualified Network.HTTP.Types.URI    as HTTP
 import qualified Network.Wai               as Wai
+import           Numeric                   (showFFloat)
 
 import qualified PostgREST.Error            as Error
 import qualified PostgREST.MediaType        as MediaType
@@ -66,9 +68,15 @@ import qualified PostgREST.SchemaCache.Routine as Routine
 import Protolude      hiding (Handler, toS)
 import Protolude.Conv (toS)
 
+-- Parameters for server-timing header
+-- e.g "Server-Timing: jwt;dur=23.2"
+-- Add other durations like app, db, render later
+newtype ServerTimingParams = ServerTimingParams {
+  jwtDur :: Double
+}
 
-readResponse :: Bool -> QualifiedIdentifier -> ApiRequest -> ResultSet -> Wai.Response
-readResponse headersOnly identifier ctxApiRequest@ApiRequest{..} resultSet = case resultSet of
+readResponse :: Bool -> QualifiedIdentifier -> ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Wai.Response
+readResponse headersOnly identifier ctxApiRequest@ApiRequest{..} resultSet serverTimingParams = case resultSet of
   RSStandard{..} -> do
     let
       (status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal rsTableTotal
@@ -80,7 +88,7 @@ readResponse headersOnly identifier ctxApiRequest@ApiRequest{..} resultSet = cas
               <> toUtf8 (qiName identifier)
               <> if BS.null (qsCanonical iQueryParams) then mempty else "?" <> qsCanonical iQueryParams
           )
-        ]
+        ] ++ serverTimingHeader serverTimingParams
         ++ contentTypeHeaders ctxApiRequest
       rsOrErrBody = if status == HTTP.status416
         then Error.errorPayload $ Error.ApiRequestError $ ApiRequestTypes.InvalidRange
@@ -92,8 +100,8 @@ readResponse headersOnly identifier ctxApiRequest@ApiRequest{..} resultSet = cas
   RSPlan plan ->
     Wai.responseLBS HTTP.status200 (contentTypeHeaders ctxApiRequest) $ LBS.fromStrict plan
 
-createResponse :: QualifiedIdentifier -> MutateReadPlan -> ApiRequest -> ResultSet -> Wai.Response
-createResponse QualifiedIdentifier{..} MutateReadPlan{mrMutatePlan} ctxApiRequest@ApiRequest{iPreferences=Preferences{..}, ..} resultSet = case resultSet of
+createResponse :: QualifiedIdentifier -> MutateReadPlan -> ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Wai.Response
+createResponse QualifiedIdentifier{..} MutateReadPlan{mrMutatePlan} ctxApiRequest@ApiRequest{iPreferences=Preferences{..}, ..} resultSet serverTimingParams = case resultSet of
   RSStandard{..} -> do
     let
       pkCols = case mrMutatePlan of { Insert{insPkCols} -> insPkCols; _ -> mempty;}
@@ -116,7 +124,7 @@ createResponse QualifiedIdentifier{..} MutateReadPlan{mrMutatePlan} ctxApiReques
             else
               toAppliedHeader <$> preferResolution
           , toAppliedHeader <$> preferMissing
-          ]
+          ] ++ serverTimingHeader serverTimingParams
 
     case preferRepresentation of
       Just Full -> response HTTP.status201 (addPrefToHeaders headers Full ++ contentTypeHeaders ctxApiRequest) (LBS.fromStrict rsBody)
@@ -129,15 +137,15 @@ createResponse QualifiedIdentifier{..} MutateReadPlan{mrMutatePlan} ctxApiReques
     Wai.responseLBS HTTP.status200 (contentTypeHeaders ctxApiRequest) $ LBS.fromStrict plan
 
 
-updateResponse :: ApiRequest -> ResultSet -> Wai.Response
-updateResponse ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} resultSet = case resultSet of
+updateResponse :: ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Wai.Response
+updateResponse ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} resultSet serverTimingParams = case resultSet of
   RSStandard{..} -> do
     let
       response = gucResponse rsGucStatus rsGucHeaders
       contentRangeHeader =
         Just . RangeQuery.contentRangeH 0 (rsQueryTotal - 1) $
           if shouldCount preferCount then Just rsQueryTotal else Nothing
-      headers = catMaybes [contentRangeHeader, toAppliedHeader <$> preferMissing]
+      headers = catMaybes [contentRangeHeader, toAppliedHeader <$> preferMissing] ++ serverTimingHeader serverTimingParams
 
     case preferRepresentation of
         Just Full -> response HTTP.status200 (addPrefToHeaders headers Full ++ contentTypeHeaders ctxApiRequest)
@@ -148,29 +156,30 @@ updateResponse ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} resultSet
   RSPlan plan ->
     Wai.responseLBS HTTP.status200 (contentTypeHeaders ctxApiRequest) $ LBS.fromStrict plan
 
-singleUpsertResponse :: ApiRequest -> ResultSet -> Wai.Response
-singleUpsertResponse ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} resultSet = case resultSet of
+singleUpsertResponse :: ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Wai.Response
+singleUpsertResponse ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} resultSet serverTimingParams = case resultSet of
   RSStandard {..} -> do
     let
       response = gucResponse rsGucStatus rsGucHeaders
+      headers = serverTimingHeader serverTimingParams
 
     case preferRepresentation of
-      Just Full -> response HTTP.status200 (contentTypeHeaders ctxApiRequest ++ [toAppliedHeader Full]) (LBS.fromStrict rsBody)
-      Just None -> response HTTP.status204 [toAppliedHeader None] mempty
-      _ -> response HTTP.status204 [] mempty
+      Just Full -> response HTTP.status200 (headers ++ contentTypeHeaders ctxApiRequest ++ [toAppliedHeader Full]) (LBS.fromStrict rsBody)
+      Just None -> response HTTP.status204 (headers ++ [toAppliedHeader None]) mempty
+      _ -> response HTTP.status204 headers mempty
 
   RSPlan plan ->
     Wai.responseLBS HTTP.status200 (contentTypeHeaders ctxApiRequest) $ LBS.fromStrict plan
 
-deleteResponse :: ApiRequest -> ResultSet -> Wai.Response
-deleteResponse ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} resultSet = case resultSet of
+deleteResponse :: ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Wai.Response
+deleteResponse ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} resultSet serverTimingParams = case resultSet of
   RSStandard {..} -> do
     let
       response = gucResponse rsGucStatus rsGucHeaders
       contentRangeHeader =
         RangeQuery.contentRangeH 1 0 $
           if shouldCount preferCount then Just rsQueryTotal else Nothing
-      headers = [contentRangeHeader]
+      headers = contentRangeHeader : serverTimingHeader serverTimingParams
 
     case preferRepresentation of
         Just Full -> response HTTP.status200 (addPrefToHeaders headers Full ++ contentTypeHeaders ctxApiRequest)
@@ -208,8 +217,8 @@ respondInfo allowHeader =
   let allOrigins = ("Access-Control-Allow-Origin", "*") in
   Wai.responseLBS HTTP.status200 [allOrigins, (HTTP.hAllow, allowHeader)] mempty
 
-invokeResponse :: InvokeMethod -> Routine -> ApiRequest -> ResultSet -> Wai.Response
-invokeResponse invMethod proc ctxApiRequest@ApiRequest{..} resultSet = case resultSet of
+invokeResponse :: InvokeMethod -> Routine -> ApiRequest -> ResultSet -> Maybe ServerTimingParams -> Wai.Response
+invokeResponse invMethod proc ctxApiRequest@ApiRequest{..} resultSet serverTimingParams = case resultSet of
   RSStandard {..} -> do
     let
       response = gucResponse rsGucStatus rsGucHeaders
@@ -219,7 +228,7 @@ invokeResponse invMethod proc ctxApiRequest@ApiRequest{..} resultSet = case resu
         then Error.errorPayload $ Error.ApiRequestError $ ApiRequestTypes.InvalidRange
           $ ApiRequestTypes.OutOfBounds (show $ RangeQuery.rangeOffset iTopLevelRange) (maybe "0" show rsTableTotal)
         else LBS.fromStrict rsBody
-      headers = [contentRange]
+      headers = contentRange : serverTimingHeader serverTimingParams
 
     if Routine.funcReturnsVoid proc then
         response HTTP.status204 headers mempty
@@ -359,6 +368,18 @@ concatPrefAppsHeaders headers = otherHeaders ++ [(HTTP.hPreferenceApplied, combi
 addPrefToHeaders :: [HTTP.Header] -> PreferRepresentation -> [HTTP.Header]
 addPrefToHeaders headers pref = concatPrefAppsHeaders (headers ++ [toAppliedHeader pref])
 
+-- | Adds the server-timing parameters to Server-Timing Header
+--
+-- >>> :{
+--  serverTimingHeader $
+--      Just ServerTimingParams { jwtDur = 0.0000134 }
+-- :}
+-- [("Server-Timing","jwt;dur=13.4")]
+
+serverTimingHeader :: Maybe ServerTimingParams -> [HTTP.Header]
+serverTimingHeader (Just ServerTimingParams{..}) = [("Server-Timing", "jwt;dur=" <> BS.pack (showFFloat (Just 1) (jwtDur*1000000) ""))]
+serverTimingHeader Nothing = []
+
 traceHeaderMiddleware :: AppConfig -> Wai.Middleware
 traceHeaderMiddleware AppConfig{configServerTraceHeader} app req respond =
   case configServerTraceHeader of