feat: add Server-Timing header with JWT duration

test/spec/Feature/Query/ServerTimingSpec.hs

@@ -0,0 +1,79 @@
+module Feature.Query.ServerTimingSpec where
+
+import Network.Wai (Application)
+
+import Network.HTTP.Types
+import Test.Hspec
+import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
+
+import Protolude  hiding (get)
+import SpecHelper
+
+spec :: SpecWith ((), Application)
+spec =
+  describe "Show Duration on Server-Timing header" $ do
+
+    context "responds with Server-Timing header" $ do
+      it "works with get request" $ do
+        request methodGet  "/organizations?id=eq.6"
+          []
+          ""
+          `shouldRespondWith`
+          [json|[{"id":6,"name":"Oscorp","referee":3,"auditor":4,"manager_id":6}]|]
+          { matchStatus  = 200
+          , matchHeaders = [ matchContentTypeJson
+                           , matchHeaderPresent "Server-Timing"]
+          }
+
+      it "works with post request" $
+        request methodPost  "/organizations?select=*"
+          [("Prefer","return=representation")]
+          [json|{"id":7,"name":"John","referee":null,"auditor":null,"manager_id":6}|]
+          `shouldRespondWith`
+          [json|[{"id":7,"name":"John","referee":null,"auditor":null,"manager_id":6}]|]
+          { matchStatus  = 201
+          , matchHeaders = [ matchContentTypeJson
+                           , matchHeaderPresent "Server-Timing"]
+          }
+
+      it "works with patch request" $
+        request methodPatch "/no_pk?b=eq.0" mempty
+            [json| { b: "1" } |]
+          `shouldRespondWith`
+            ""
+            { matchStatus  = 204
+            , matchHeaders = [ matchHeaderAbsent hContentType
+                             , matchHeaderPresent "Server-Timing" ]
+            }
+
+      it "works with put request" $
+        request methodPut "/tiobe_pls?name=eq.Go"
+            [("Prefer", "return=representation")]
+            [json| [ { "name": "Go", "rank": 19 } ]|]
+          `shouldRespondWith`
+            [json| [ { "name": "Go", "rank": 19 } ]|]
+            { matchStatus  = 200
+            , matchHeaders = [ matchHeaderPresent "Server-Timing" ]
+            }
+
+      it "works with delete request" $
+        request methodDelete "/items?id=eq.1"
+            []
+            ""
+          `shouldRespondWith`
+            ""
+            { matchStatus  = 204
+            , matchHeaders = [ matchHeaderAbsent hContentType
+                             , matchHeaderPresent "Server-Timing" ]
+            }
+
+      it "works with rpc call" $
+        request methodPost "/rpc/ret_point_overloaded"
+          []
+          [json|{"x": 1, "y": 2}|]
+          `shouldRespondWith`
+          [json|{"x": 1, "y": 2}|]
+          { matchStatus  = 200
+          , matchHeaders = [ matchHeaderPresent "Server-Timing" ]
+          }

test/spec/Main.hs

@@ -55,6 +55,7 @@ import qualified Feature.Query.RangeSpec
 import qualified Feature.Query.RawOutputTypesSpec
 import qualified Feature.Query.RelatedQueriesSpec
 import qualified Feature.Query.RpcSpec
+import qualified Feature.Query.ServerTimingSpec
 import qualified Feature.Query.SingularSpec
 import qualified Feature.Query.SpreadQueriesSpec
 import qualified Feature.Query.UnicodeSpec
@@ -109,6 +110,7 @@ main = do
       planEnabledApp       = app testPlanEnabledCfg
       pgSafeUpdateApp      = app testPgSafeUpdateEnabledCfg
       obsApp               = app testObservabilityCfg
+      serverTiming         = app testCfgServerTiming
 
       extraSearchPathApp   = appDbs testCfgExtraSearchPath
       unicodeApp           = appDbs testUnicodeCfg
@@ -245,6 +247,9 @@ main = do
     parallel $ before obsApp $
       describe "Feature.ObservabilitySpec.spec" Feature.ObservabilitySpec.spec
 
+    parallel $ before serverTiming $
+      describe "Feature.Query.ServerTimingSpec.spec" Feature.Query.ServerTimingSpec.spec
+
     -- Note: the rollback tests can not run in parallel, because they test persistance and
     -- this results in race conditions
 

test/spec/SpecHelper.hs

@@ -58,6 +58,12 @@ matchHeaderAbsent name = MatchHeader $ \headers _body ->
     Just _  -> Just $ "unexpected header: " <> toS (original name) <> "\n"
     Nothing -> Nothing
 
+matchHeaderPresent :: HeaderName -> MatchHeader
+matchHeaderPresent name = MatchHeader $ \headers _body ->
+  case lookup name headers of
+    Just _  -> Nothing
+    Nothing -> Just $ "missing header: " <> toS (original name) <> "\n"
+
 validateOpenApiResponse :: [Header] -> WaiSession () ()
 validateOpenApiResponse headers = do
   r <- request methodGet "/" headers ""
@@ -226,6 +232,9 @@ testPgSafeUpdateEnabledCfg = baseCfg { configDbPreRequest = Just $ QualifiedIden
 testObservabilityCfg :: AppConfig
 testObservabilityCfg = baseCfg { configServerTraceHeader = Just $ mk "X-Request-Id" }
 
+testCfgServerTiming :: AppConfig
+testCfgServerTiming = baseCfg { configDbPlanEnabled = True }
+
 analyzeTable :: Text -> IO ()
 analyzeTable tableName =
   void $ readProcess "psql" ["-U", "postgres", "--set", "ON_ERROR_STOP=1", "-a", "-c", toS $ "ANALYZE test.\"" <> tableName <> "\""] []