From d6f785662b0b8ba41a42fae48162a856f1194fc1 Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Fri, 25 Sep 2026 12:10:24 +0300
Subject: [PATCH] Logging in http

---
 src/HomeAssistant/Runtime.hs |  2 +-
 src/HttpServer.hs            | 35 ++++++++++++++++++++++-------------
 2 files changed, 23 insertions(+), 14 deletions(-)

diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs
index 6cfd44f..3058ab0 100644
--- a/src/HomeAssistant/Runtime.hs
+++ b/src/HomeAssistant/Runtime.hs
@@ -115,7 +115,7 @@ defaultMain = withSocketsDo $ do
           [ ("reader", readerAction host 8123 token ents bus)
           , ("writer", writerAction writerLimiter bus)
           , ("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool)
-          , ("metrics-http", HttpServer.runHttpServer rrdPath rrdtool metricsPort)
+          , ("metrics-http", HttpServer.runHttpServer (busLogEnv bus) rrdPath rrdtool metricsPort)
           ] ++ [ (name, runController rootPath bus c) | c@(Controller True name _) <- active ]
     runKatipContextT (busLogEnv bus) () mempty $
       mapConcurrently_ (uncurry supervised) workers
diff --git a/src/HttpServer.hs b/src/HttpServer.hs
index 0074977..6a9258d 100644
--- a/src/HttpServer.hs
+++ b/src/HttpServer.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DerivingVia #-}
 module HttpServer where
 
 import Control.Monad (forever)
@@ -6,18 +7,19 @@ import Control.Monad.IO.Class (liftIO, MonadIO)
 import qualified Data.ByteString as BS
 import Data.Void (Void)
 import Network.Wai.Handler.Warp (run)
-import Servant.API ((:>), Capture, Get, QueryParam, (:-), MimeRender (..), Accept (..))
+import Servant.API ((:>), Capture, Get, QueryParam, (:-), MimeRender (..), Accept (..), NamedRoutes)
 import Data.ByteString (ByteString)
 import GHC.Generics (Generic)
 import Servant (Handler, err404)
-import Control.Monad.Catch (throwM)
-import Servant.Server (err500)
+import Control.Monad.Catch (throwM, MonadCatch, MonadThrow)
+import Servant.Server (err500, ServerT)
 import Data.Maybe (fromMaybe)
 import Control.Exception.Annotated (checkpoint, Annotation (Annotation))
-import Servant.Server.Generic (AsServer, genericServe)
+import Servant.Server.Generic (genericServeT)
 import Network.Wai (Application)
 import Network.HTTP.Media ((//))
 import HomeAssistant.Runtime.Graphing (Graph, Range (..), lookupGraph, graphs, renderGraph)
+import Katip (KatipContextT, Katip, runKatipContextT, LogEnv, KatipContext, ls, Severity (..), logFM)
 
 data ImagePng
 
@@ -34,22 +36,29 @@ newtype API mode = API
   deriving Generic
 
 
-getMetricsHandler :: FilePath -> FilePath -> Graph -> Maybe Range -> Handler ByteString
+getMetricsHandler :: FilePath -> FilePath -> Graph -> Maybe Range -> LoggingHandler ByteString
 getMetricsHandler rrdPath rrdtool graphMode mRange = checkpoint (Annotation (graphMode, mRange)) $ do
   case lookupGraph graphs graphMode of
     Nothing -> throwM err404
     Just spec -> do
       let range = fromMaybe OneDay mRange
       g <- renderGraph rrdPath rrdtool spec range
-      -- XXX: Want logging for the error (not expose to response body)
-      -- but I don't have logging context yet
-      either (\_ -> throwM err500) pure g
+      either (\e -> logFM ErrorS (ls e) >> throwM err500) pure g
 
-server :: FilePath -> FilePath -> API AsServer
+-- server :: FilePath -> FilePath -> API AsServer
+server :: FilePath -> FilePath -> ServerT (NamedRoutes API) LoggingHandler
 server rrdPath rrdtool = API { getMetrics = getMetricsHandler rrdPath rrdtool }
 
-servantApp :: FilePath -> FilePath -> Application
-servantApp rrdPath rrdtool = genericServe (server rrdPath rrdtool)
+servantApp :: LogEnv -> FilePath -> FilePath -> Application
+servantApp le rrdPath rrdtool = genericServeT (toHandler le) (server rrdPath rrdtool)
+
+runHttpServer :: MonadIO m => LogEnv -> FilePath -> FilePath -> Int -> m Void
+runHttpServer le rrdPath rrdtool port = liftIO $ forever $ run port (servantApp le rrdPath rrdtool)
+
+newtype LoggingHandler a = LoggingHandler (KatipContextT Handler a)
+  deriving (Functor, Applicative, Monad, MonadIO, Katip, KatipContext, MonadCatch, MonadThrow) via (KatipContextT Handler)
+
+toHandler :: LogEnv -> (forall a.  LoggingHandler a -> Handler a)
+toHandler le (LoggingHandler k) = runKatipContextT le () "http" k
+
 
-runHttpServer :: MonadIO m => FilePath -> FilePath -> Int -> m Void
-runHttpServer rrdPath rrdtool port = liftIO $ forever $ run port (servantApp rrdPath rrdtool)