Replace scotty with servant

2026-09-25 11:48:42 +03:00
parent 9c47bbcb42
commit 05bd609c7e
5 changed files with 118 additions and 60 deletions
@@ -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.graphAction rrdPath rrdtool metricsPort)
+          , ("metrics-http", HomeAssistant.Runtime.Graphing.servantGraphAction rrdPath rrdtool metricsPort)
          ] ++ [ (name, runController rootPath bus c) | c@(Controller True name _) <- active ]
    runKatipContextT (busLogEnv bus) () mempty $
      mapConcurrently_ (uncurry supervised) workers
@@ -11,37 +11,32 @@ module HomeAssistant.Runtime.Graphing
  , parseNameParam
  , buildGraphArgs
  , readProcessBytes
-  , graphAction
+  , Graph(..)
+  , servantGraphAction
  ) 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 Network.Wai.Handler.Warp (run)
 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 ((:>), 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 ((//))

 data Range = TenMinutes | OneHour | OneDay | OneWeek | OneMonth
  deriving (Eq, Show, Bounded, Enum)
@@ -56,6 +51,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 +92,7 @@ data GraphSpec = GraphSpec
  { gsName  :: Text
  , gsTitle :: String
  , gsPlots :: [Plot]
+  , gsIdentifier :: Graph
  }
  deriving (Eq, Show)

@@ -141,6 +143,7 @@ ratelimitGraph =
            , serLabel = "Requests exhausted/min"
            }
        ]
+    , gsIdentifier = RateLimit
    }

 trafficGraph :: GraphSpec
@@ -164,6 +167,7 @@ trafficGraph =
            , serLabel = "Service calls out/min"
            }
        ]
+    , gsIdentifier = Traffic
    }

 memoryGraph :: GraphSpec
@@ -174,17 +178,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 +263,66 @@ 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"
+
+
+
+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")
+
+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
-      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
+      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

-app :: FilePath -> FilePath -> ScottyM ()
-app rrdPath rrdtool = get "/metrics/:name" (handler rrdPath rrdtool)
+server :: FilePath -> FilePath -> API AsServer
+server rrdPath rrdtool = API { getMetrics = getMetricsHandler 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)
-      }
+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)