fix: inaccurate Server-Timing durations

The transaction duration was notably off, doing:

```
curl localhost:3000/rpc/sleep?seconds=5 -i
```

Shows `46.1` for the `transaction;dur`, with this fix we obtain
`5007.3`.

Fixes https://github.com/PostgREST/postgrest/issues/4522

This also fixes inaccurate "schema cache queried" logs,
see https://github.com/PostgREST/postgrest/issues/4551.

src/PostgREST/App.hs

@@ -51,13 +51,13 @@ import PostgREST.Observation          (Observation (..))
 import PostgREST.Response.Performance (ServerTiming (..),
                                        serverTimingHeader)
 import PostgREST.SchemaCache          (SchemaCache (..))
+import PostgREST.TimeIt               (timeItT)
 import PostgREST.Version              (docsVersion, prettyVersion)
 
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.List             as L
 import qualified Network.HTTP.Types    as HTTP
 import           Protolude             hiding (Handler)
-import           System.TimeIt         (timeItT)
 
 type Handler = ExceptT Error
 

src/PostgREST/AppState.hs

@@ -44,8 +44,8 @@ import qualified PostgREST.Error            as Error
 import qualified PostgREST.Logger           as Logger
 import qualified PostgREST.Metrics          as Metrics
 import           PostgREST.Observation
+import           PostgREST.TimeIt           (timeItT)
 import           PostgREST.Version          (prettyVersion)
-import           System.TimeIt              (timeItT)
 
 import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate,
                            updateAction)

src/PostgREST/Auth.hs

@@ -25,8 +25,8 @@ import qualified Network.Wai                     as Wai
 import qualified Network.Wai.Middleware.HttpAuth as Wai
 
 import Data.List        (lookup)
+import PostgREST.TimeIt (timeItT)
 import System.IO.Unsafe (unsafePerformIO)
-import System.TimeIt    (timeItT)
 
 import PostgREST.AppState      (AppState, getConfig, getJwtCacheState,
                                 getTime)

src/PostgREST/Observation.hs

@@ -156,7 +156,7 @@ observationMessage = \case
     "Evicted entry from JWT cache"
   where
     showMillis :: Double -> Text
-    showMillis x = toS $ showFFloat (Just 1) (x * 1000) ""
+    showMillis x = toS $ showFFloat (Just 1) x ""
 
     jsonMessage err = T.decodeUtf8 . LBS.toStrict . Error.errorPayload $ Error.PgError False err
 

src/PostgREST/Response/Performance.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE NumericUnderscores #-}
 module PostgREST.Response.Performance
   ( ServerTiming (..)
   , serverTimingHeader
@@ -24,12 +23,12 @@ data ServerTiming =
 -- The duration precision is milliseconds, per the docs
 --
 -- >>> 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=400.0, parse;dur=500.0, plan;dur=100.0, transaction;dur=200.0, response;dur=300.0")
+-- ("Server-Timing","jwt;dur=0.4, parse;dur=0.5, plan;dur=0.1, transaction;dur=0.2, response;dur=0.3")
 serverTimingHeader :: ServerTiming -> HTTP.Header
 serverTimingHeader timing =
   ("Server-Timing", renderTiming)
   where
-    renderMetric metric = maybe "" (\dur -> BS.concat [metric, BS.pack $ ";dur=" <> showFFloat (Just 1) (dur * 1_000) ""])
+    renderMetric metric = maybe "" (\dur -> BS.concat [metric, BS.pack $ ";dur=" <> showFFloat (Just 1) dur ""])
     renderTiming = BS.intercalate ", " $ (\(k, v) -> renderMetric k (v timing)) <$>
       [ ("jwt", jwt)
       , ("parse", parse)

src/PostgREST/TimeIt.hs

@@ -0,0 +1,20 @@
+module PostgREST.TimeIt
+  ( timeItT
+  ) where
+
+import GHC.Clock
+import Protolude
+
+{-
+ - The signature is the same as https://hackage.haskell.org/package/timeit-2.0/docs/src/System-TimeIt.html#timeIt,
+ - we vendor this functionality because it gave errors as shown on https://github.com/PostgREST/postgrest/issues/4522 plus
+ - the function is small enough. This vendored function is different in that the result is in milliseconds.
+ -}
+timeItT :: MonadIO m => m a -> m (Double, a)
+timeItT p = do
+  s <- liftIO getMonotonicTime
+  x <- p
+  e <- liftIO getMonotonicTime
+  let time = (e - s) * 1000
+  return (time, x)
+