Merge pull request 'Replace scotty with servant' (#4) from servant into main

Reviewed-on: #4

src/HomeAssistant/Runtime.hs

@@ -40,8 +40,8 @@ import HomeAssistant.Controller.Livingroom (livingroomPresenceController, living
 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
@@ -116,7 +116,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.graphAction rrdPath rrdtool metricsPort)
+          , ("metrics-http", HttpServer.runHttpServer (busLogEnv bus) 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

@@ -11,37 +11,19 @@ module HomeAssistant.Runtime.Graphing
   , parseNameParam
   , buildGraphArgs
   , readProcessBytes
-  , graphAction
+  , Graph(..)
+  , renderGraph
   ) where
 
 import Control.Exception (evaluate)
-import Control.Monad (forever)
 import Control.Monad.IO.Class (liftIO, MonadIO)
 import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as BL
 import Data.Text (Text)
 import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
-import Data.Void (Void)
-import Network.HTTP.Types.Status (Status, status400, status404, status500)
-import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort)
 import System.Exit (ExitCode (..))
 import System.IO (hGetContents)
 import System.Process (CreateProcess (..), StdStream (..), proc, waitForProcess, withCreateProcess)
-import Web.Scotty
-  ( ActionM
-  , ScottyM
-  , defaultOptions
-  , get
-  , pathParam
-  , queryParamMaybe
-  , raw
-  , scottyOpts
-  , setHeader
-  , settings
-  , status
-  , text
-  )
+import Servant.API (FromHttpApiData (..), ToHttpApiData (..))
 
 data Range = TenMinutes | OneHour | OneDay | OneWeek | OneMonth
   deriving (Eq, Show, Bounded, Enum)
@@ -56,6 +38,12 @@ rangeSuffix OneMonth    = "30d"
 parseRange :: Text -> Maybe Range
 parseRange t = lookup t [(T.pack (rangeSuffix r), r) | r <- [minBound .. maxBound]]
 
+instance ToHttpApiData Range where
+  toQueryParam = T.pack . rangeSuffix
+
+instance FromHttpApiData Range where
+  parseQueryParam x = maybe (Left ("Could not parse '" <> x <> "' as Range")) Right $ parseRange x
+
 rangeStart :: Range -> String
 rangeStart r = "end-" ++ rangeSuffix r
 
@@ -91,6 +79,7 @@ data GraphSpec = GraphSpec
   { gsName  :: Text
   , gsTitle :: String
   , gsPlots :: [Plot]
+  , gsIdentifier :: Graph
   }
   deriving (Eq, Show)
 
@@ -141,6 +130,7 @@ ratelimitGraph =
             , serLabel = "Requests exhausted/min"
             }
         ]
+    , gsIdentifier = RateLimit
     }
 
 trafficGraph :: GraphSpec
@@ -164,6 +154,7 @@ trafficGraph =
             , serLabel = "Service calls out/min"
             }
         ]
+    , gsIdentifier = Traffic
     }
 
 memoryGraph :: GraphSpec
@@ -174,17 +165,21 @@ memoryGraph =
     [ area "live" "#99ccff" (average "rts_gc_current__a7a")
     , line "peak" "#cc0000" (maximumCF "rts_gc_current__a7a")
     ]
+    Memory
 
 graphs :: [GraphSpec]
 graphs = [memoryGraph, ratelimitGraph, trafficGraph]
 
-lookupGraph :: [GraphSpec] -> Text -> Maybe GraphSpec
-lookupGraph specs name = case [g | g <- specs, gsName g == name] of
+-- XXX: Proper lookup..?
+lookupGraph :: [GraphSpec] -> Graph -> Maybe GraphSpec
+lookupGraph specs graphMode = case [g | g <- specs, gsIdentifier g == graphMode] of
   (g : _) -> Just g
   []      -> Nothing
 
 parseNameParam :: [GraphSpec] -> Text -> Maybe GraphSpec
-parseNameParam specs t = T.stripSuffix ".png" t >>= lookupGraph specs
+parseNameParam specs t = rightToMaybe (parseQueryParam t) >>= lookupGraph specs
+  where
+    rightToMaybe = either (const Nothing) Just
 
 cfName :: CF -> String
 cfName = \case
@@ -255,39 +250,32 @@ readProcessBytes cmd args =
           pure (code, out, err)
         _ -> pure (ExitFailure 1, BS.empty, "failed to create pipes")
 
-respond :: Status -> TL.Text -> ActionM ()
-respond st body = status st >> text body
-
-serve :: FilePath -> FilePath -> GraphSpec -> Range -> ActionM ()
-serve rrdPath rrdtool spec range = do
+renderGraph :: MonadIO m => FilePath -> FilePath -> GraphSpec -> Range -> m (Either Text BS.ByteString)
+renderGraph rrdPath rrdtool spec range = do
   (code, out, err) <- liftIO (readProcessBytes rrdtool (buildGraphArgs rrdPath spec range))
   case code of
     ExitSuccess
-      | not (BS.null out) -> do
-          setHeader "Content-Type" "image/png"
-          raw (BL.fromStrict out)
-      | otherwise -> respond status500 "empty graph"
-    _ -> respond status500 (TL.pack (take 200 err))
+      | not (BS.null out) -> pure $ Right out
+      | otherwise -> pure $ Left "empty graph"
+    _ -> pure $ Left (T.pack $ take 200 err)
 
-handler :: FilePath -> FilePath -> ActionM ()
-handler rrdPath rrdtool = do
-  name <- pathParam "name"
-  case parseNameParam graphs name of
-    Nothing -> respond status404 "unknown graph"
-    Just spec -> do
-      rangeArg <- queryParamMaybe "range"
-      case rangeArg of
-        Nothing -> serve rrdPath rrdtool spec OneDay
-        Just t -> case parseRange t of
-          Nothing -> respond status400 "invalid range"
-          Just range -> serve rrdPath rrdtool spec range
 
-app :: FilePath -> FilePath -> ScottyM ()
-app rrdPath rrdtool = get "/metrics/:name" (handler rrdPath rrdtool)
 
-graphAction :: MonadIO m => FilePath -> FilePath -> Int -> m Void
-graphAction rrdPath rrdtool port = liftIO $ forever $ scottyOpts opts (app rrdPath rrdtool)
-  where
-    opts = defaultOptions
-      { settings = setHost "0.0.0.0" (setPort port defaultSettings)
-      }
+
+data Graph
+  = Memory
+  | Traffic
+  | RateLimit
+  deriving (Show, Eq, Enum, Bounded)
+
+instance ToHttpApiData Graph where
+  toQueryParam Memory = "memory.png"
+  toQueryParam Traffic = "traffic.png"
+  toQueryParam RateLimit = "ratelimit.png"
+
+instance FromHttpApiData Graph where
+  parseQueryParam "memory.png" = Right Memory
+  parseQueryParam "traffic.png" = Right Traffic
+  parseQueryParam "ratelimit.png" = Right RateLimit
+  parseQueryParam x = Left ("Can't parse '" <> x <> "' as Graph")
+

src/HttpServer.hs

@@ -0,0 +1,64 @@
+{-# 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
+
+