Move http to separate module

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:

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

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 Servant.API (FromHttpApiData (..), ToHttpApiData (..))
-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 ((//))
 
 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)

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)