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

Reviewed-on: #4

default.nix

@@ -1,8 +1,9 @@
 { mkDerivation, aeson, annotated-exception, async, base, bytestring
 , cereal, cereal-conduit, conduit, containers, directory, ekg-core
-, filepath, hedgehog, hspec, hspec-hedgehog, http-types, katip
+, exceptions, filepath, hedgehog, hspec, hspec-hedgehog, http-types
-, lens, lens-aeson, lib, network, process, retry, scotty, stm, text
+, katip, lens, lens-aeson, lib, network, process, retry, scotty
-, time, unordered-containers, uuid, wai, warp, websockets
+, servant, servant-server, stm, text, time, unliftio
+, unordered-containers, uuid, wai, warp, websockets
 }:
 mkDerivation {
   pname = "home-assistant-controller";
@@ -12,9 +13,10 @@ mkDerivation {
   isExecutable = true;
   libraryHaskellDepends = [
     aeson annotated-exception async base bytestring cereal
-    cereal-conduit conduit containers directory ekg-core filepath
+    cereal-conduit conduit containers directory ekg-core exceptions
-    http-types katip lens lens-aeson network process retry scotty stm
+    filepath http-types katip lens lens-aeson network process retry
-    text time unordered-containers uuid wai warp websockets
+    scotty servant servant-server stm text time unliftio
+    unordered-containers uuid wai warp websockets
   ];
   executableHaskellDepends = [ base ];
   testHaskellDepends = [

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:
@@ -84,6 +85,7 @@ library
     -- Other library packages from which modules are imported.
     build-depends:    base ^>=4.20.2.0
                     , websockets
+                    , http-media
                     , aeson
                     , lens-aeson
                     , lens
@@ -108,7 +110,8 @@ library
                     , filepath
                     , conduit
                     , cereal-conduit
-                    , scotty
+                    , servant
+                    , servant-server
                     , http-types
                     , warp
                     , wai
@@ -182,6 +185,7 @@ test-suite home-assistant-controller-test
         bytestring,
         hspec,
         stm,
+        servant,
         aeson,
         cereal,
         text,

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
+import Servant.API (FromHttpApiData (..), ToHttpApiData (..))
-  ( ActionM
-  , ScottyM
-  , defaultOptions
-  , get
-  , pathParam
-  , queryParamMaybe
-  , raw
-  , scottyOpts
-  , setHeader
-  , settings
-  , status
-  , text
-  )
 
 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
+-- XXX: Proper lookup..?
-lookupGraph specs name = case [g | g <- specs, gsName g == name] of
+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 ()
+renderGraph :: MonadIO m => FilePath -> FilePath -> GraphSpec -> Range -> m (Either Text BS.ByteString)
-respond st body = status st >> text body
+renderGraph rrdPath rrdtool spec range = do
-
-serve :: FilePath -> FilePath -> GraphSpec -> Range -> ActionM ()
-serve rrdPath rrdtool spec range = do
   (code, out, err) <- liftIO (readProcessBytes rrdtool (buildGraphArgs rrdPath spec range))
   case code of
     ExitSuccess
-      | not (BS.null out) -> do
+      | not (BS.null out) -> pure $ Right out
-          setHeader "Content-Type" "image/png"
+      | otherwise -> pure $ Left "empty graph"
-          raw (BL.fromStrict out)
+    _ -> pure $ Left (T.pack $ take 200 err)
-      | otherwise -> respond status500 "empty graph"
-    _ -> respond status500 (TL.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)
+data Graph
-  where
+  = Memory
-    opts = defaultOptions
+  | Traffic
-      { settings = setHost "0.0.0.0" (setPort port defaultSettings)
+  | 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
+
+

test/GraphingSpec.hs

@@ -20,15 +20,30 @@ import System.Directory (findExecutable, getTemporaryDirectory, removeFile)
 import System.Exit (ExitCode (..))
 import System.Process (readProcessWithExitCode)
 import Test.Hspec
+import Servant.API (FromHttpApiData(..), ToHttpApiData (..))
+import HomeAssistant.Runtime.Graphing (Graph(..))
 
 traffic :: GraphSpec
-traffic = case lookupGraph graphs "traffic" of
+traffic = case lookupGraph graphs Traffic of
   Just s  -> s
   Nothing -> error "traffic graph is missing from the table"
 
 spec :: Spec
 spec = do
+  describe "Graph HttpApiData" $ do
+    -- There's an enumerable amount of graphs, we can just enumerate through them all
+    it "satisfies roundtrip property" $ do
+      let modes = [minBound..maxBound]
+      let got = map (parseQueryParam . toQueryParam @Graph) modes
+      let wanted = map Right modes
+      got `shouldBe` wanted
   describe "parseRange" $ do
+    -- Fully enumerable
+    it "the http-api-data satisfies roundtrip property" $ do
+      let rs = [minBound..maxBound]
+      let got = map (parseQueryParam . toQueryParam @Range) rs
+      let wanted = map Right rs
+      got `shouldBe` wanted
     it "accepts every suffix in the closed set" $
       map parseRange ["10m", "1h", "24h", "7d", "30d"]
         `shouldBe` [ Just TenMinutes
@@ -124,3 +139,6 @@ spec = do
               out `shouldSatisfy` BS.isPrefixOf pngMagic
             )
             `finally` cleanup
+
+
+