Log service time

app/Main.hs

@@ -17,10 +17,10 @@ import Control.Monad.Trans.Except (ExceptT (..), catchE, runExceptT)
 import Data.Bifunctor (Bifunctor (..))
 import Data.Proxy (Proxy (..))
 import Data.Text (Text)
-import Data.Time (Day, LocalTime (..), TimeOfDay (..), ZonedTime (..), addDays, toGregorian)
+import Data.Time (Day, LocalTime (..), TimeOfDay (..), ZonedTime (..), addDays, nominalDiffTimeToSeconds, toGregorian)
 import GHC.Generics (Generic)
 import Network.HTTP.Types (Status (..))
-import Network.Wai (Request (..))
+import Network.Wai (Middleware, Request (..), responseStatus)
 import Servant
   ( Capture
   , Get
@@ -60,6 +60,8 @@ import Yore.Scrape (Issue (..), getIssuesByDay)
 import Yore.Servant (GetSendfile, HTML, Sendfile (..))
 import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight)
 
+import Data.Fixed (Pico)
+import Data.Time.Clock.POSIX (getPOSIXTime)
 import qualified Envy
 import qualified Yore.DB as DB
 import qualified Yore.Log as Log
@@ -112,24 +114,29 @@ doIndex cfg db =
 
 runServer :: Config -> DB -> IO ()
 runServer cfg db =
-  Warp.runSettings settings $ serve (Proxy @API) $ hoistServer (Proxy @API) nt $ server cfg db
+  Warp.runSettings settings $ loggerMiddleware $ serve (Proxy @API) $ hoistServer (Proxy @API) nt $ server cfg db
   where
     settings =
       foldr
         ($)
         Warp.defaultSettings
-        [ Warp.setLogger logger
-        , Warp.setPort cfg.yorePort
+        [ Warp.setPort cfg.yorePort
         , Warp.setBeforeMainLoop $ Log.info $ printf "listening on port %d" cfg.yorePort
         , Warp.setOnException onException
         ]
 
-    logger req status _ = do
-      Log.info $
-        printf
-          "%d %s"
-          (statusCode status)
-          (requestLine req)
+    logger :: Request -> Status -> Pico -> IO ()
+    logger req status s = do
+      Log.info $ printf "%d %s %ss" (statusCode status) (requestLine req) (formatMetric s)
+
+    loggerMiddleware :: Middleware
+    loggerMiddleware app req respond = do
+      begin <- getPOSIXTime
+      app req $ \res -> do
+        rr <- respond res
+        end <- getPOSIXTime
+        logger req (responseStatus res) (nominalDiffTimeToSeconds (end - begin))
+        pure rr
 
     onException mbReq ex = do
       Log.error $ printf "unhandled exception%s: %s%s" (maybe "" ((" in " ++) . requestLine) mbReq) (show ex)
@@ -141,6 +148,18 @@ runServer cfg db =
         (BS8.unpack $ requestMethod req)
         (BS8.unpack $ rawPathInfo req <> rawQueryString req)
 
+formatMetric :: Pico -> String
+formatMetric x = go (-9) prefixes
+  where
+    prefixes = ["p", "n", "u", "m", "", "k", "M", "G"]
+
+    go :: Int -> [String] -> String
+    go _ [] = show x
+    go e (p : ps)
+      | x < 10 ^^ e =
+          show @Int (floor $ x * 10 ^^ (-e + 3)) ++ p
+      | otherwise = go (e + 3) ps
+
 nt :: ExceptT Error IO a -> Handler a
 nt action = MkHandler $ do
   res <- runExceptT action