Move http to separate module

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)