MasseR/home-assistant-controller
1
0
Fork 0
Code Issues 2 Pull Requests Actions Packages Projects Releases Wiki Activity

Logging in http

Browse Source
This commit is contained in:
MasseR
2026-09-25 12:10:24 +03:00
parent 5d16bf4ade
commit d6f785662b
2 changed files with 23 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/HttpServer.hs
+22 -13
View File
@@ -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)