diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index 9d116dd..a655a1b 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -74,6 +74,7 @@ library , HomeAssistant.Runtime.Metrics , HomeAssistant.Runtime.Supervisor , HomeAssistant.Runtime.RateLimit + , HttpServer -- Modules included in this library but not exported. -- other-modules: diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index 9e0e780..6cfd44f 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/src/HomeAssistant/Runtime.hs @@ -40,8 +40,8 @@ import HomeAssistant.Controller.Livingroom (livingroomPresenceController) import HomeAssistant.Runtime.RateLimit (slidingWindowLimiter, registerRateLimitMetrics) import UnliftIO.Async import HomeAssistant.Runtime.Supervisor (supervised) -import qualified HomeAssistant.Runtime.Graphing import HomeAssistant.Controller.Hallway (hallwayLightsController) +import qualified HttpServer step :: (MonadIO m) => FilePath -> UUID -> Auto m a b -> a -> m (b, Auto m a b) step path trace st a = do @@ -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", HomeAssistant.Runtime.Graphing.servantGraphAction rrdPath rrdtool metricsPort) + , ("metrics-http", HttpServer.runHttpServer 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/HomeAssistant/Runtime/Graphing.hs b/src/HomeAssistant/Runtime/Graphing.hs index 6a609fc..dfd8cb8 100644 --- a/src/HomeAssistant/Runtime/Graphing.hs +++ b/src/HomeAssistant/Runtime/Graphing.hs @@ -12,31 +12,18 @@ module HomeAssistant.Runtime.Graphing , buildGraphArgs , readProcessBytes , Graph(..) - , servantGraphAction + , renderGraph ) where import Control.Exception (evaluate) -import Control.Monad (forever) import Control.Monad.IO.Class (liftIO, MonadIO) import qualified Data.ByteString as BS import Data.Text (Text) import qualified Data.Text as T -import Data.Void (Void) -import Network.Wai.Handler.Warp (run) import System.Exit (ExitCode (..)) import System.IO (hGetContents) import System.Process (CreateProcess (..), StdStream (..), proc, waitForProcess, withCreateProcess) -import Servant.API ((:>), Capture, Get, FromHttpApiData (..), ToHttpApiData (..), QueryParam, (:-), MimeRender (..), Accept (..)) -import Data.ByteString (ByteString) -import GHC.Generics (Generic) -import Servant (Handler, err404) -import Control.Monad.Catch (throwM) -import Servant.Server (err500) -import Data.Maybe (fromMaybe) -import Control.Exception.Annotated (checkpoint, Annotation (Annotation)) -import Servant.Server.Generic (AsServer, genericServe) -import Network.Wai (Application) -import Network.HTTP.Media ((//)) +import Servant.API (FromHttpApiData (..), ToHttpApiData (..)) data Range = TenMinutes | OneHour | OneDay | OneWeek | OneMonth deriving (Eq, Show, Bounded, Enum) @@ -292,37 +279,3 @@ instance FromHttpApiData Graph where parseQueryParam "ratelimit.png" = Right RateLimit parseQueryParam x = Left ("Can't parse '" <> x <> "' as Graph") -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 -> Handler 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 - -server :: FilePath -> FilePath -> API AsServer -server rrdPath rrdtool = API { getMetrics = getMetricsHandler rrdPath rrdtool } - -servantApp :: FilePath -> FilePath -> Application -servantApp rrdPath rrdtool = genericServe (server rrdPath rrdtool) - -servantGraphAction :: MonadIO m => FilePath -> FilePath -> Int -> m Void -servantGraphAction rrdPath rrdtool port = liftIO $ forever $ run port (servantApp rrdPath rrdtool) diff --git a/src/HttpServer.hs b/src/HttpServer.hs new file mode 100644 index 0000000..0074977 --- /dev/null +++ b/src/HttpServer.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} +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 (..)) +import Data.ByteString (ByteString) +import GHC.Generics (Generic) +import Servant (Handler, err404) +import Control.Monad.Catch (throwM) +import Servant.Server (err500) +import Data.Maybe (fromMaybe) +import Control.Exception.Annotated (checkpoint, Annotation (Annotation)) +import Servant.Server.Generic (AsServer, genericServe) +import Network.Wai (Application) +import Network.HTTP.Media ((//)) +import HomeAssistant.Runtime.Graphing (Graph, Range (..), lookupGraph, graphs, renderGraph) + +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 -> Handler 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 + +server :: FilePath -> FilePath -> API AsServer +server rrdPath rrdtool = API { getMetrics = getMetricsHandler rrdPath rrdtool } + +servantApp :: FilePath -> FilePath -> Application +servantApp rrdPath rrdtool = genericServe (server rrdPath rrdtool) + +runHttpServer :: MonadIO m => FilePath -> FilePath -> Int -> m Void +runHttpServer rrdPath rrdtool port = liftIO $ forever $ run port (servantApp rrdPath rrdtool)