65 lines
2.5 KiB
Haskell
65 lines
2.5 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE DerivingVia #-}
|
|
module HttpServer where
|
|
|
|
import Control.Monad (forever)
|
|
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 (..), NamedRoutes)
|
|
import Data.ByteString (ByteString)
|
|
import GHC.Generics (Generic)
|
|
import Servant (Handler, err404)
|
|
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 (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
|
|
|
|
instance MimeRender ImagePng ByteString where
|
|
mimeRender _ = BS.fromStrict
|
|
|
|
instance Accept ImagePng where
|
|
contentType _ = "image" // "png"
|
|
|
|
|
|
newtype API mode = API
|
|
{ getMetrics :: mode :- "metrics" :> Capture "graph" Graph :> QueryParam "range" Range :> Get '[ImagePng] ByteString
|
|
}
|
|
deriving Generic
|
|
|
|
|
|
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
|
|
either (\e -> logFM ErrorS (ls e) >> throwM err500) pure g
|
|
|
|
-- server :: FilePath -> FilePath -> API AsServer
|
|
server :: FilePath -> FilePath -> ServerT (NamedRoutes API) LoggingHandler
|
|
server rrdPath rrdtool = API { getMetrics = getMetricsHandler 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
|
|
|
|
|