Replace scotty with servant

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
-, lens, lens-aeson, lib, network, process, retry, scotty, stm, text
-, time, unordered-containers, uuid, wai, warp, websockets
+, exceptions, filepath, hedgehog, hspec, hspec-hedgehog, http-types
+, katip, lens, lens-aeson, lib, network, process, retry, scotty
+, 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
-    http-types katip lens lens-aeson network process retry scotty stm
-    text time unordered-containers uuid wai warp websockets
+    cereal-conduit conduit containers directory ekg-core exceptions
+    filepath http-types katip lens lens-aeson network process retry
+    scotty servant servant-server stm text time unliftio
+    unordered-containers uuid wai warp websockets
   ];
   executableHaskellDepends = [ base ];
   testHaskellDepends = [

home-assistant-controller.cabal

@@ -84,6 +84,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 +109,8 @@ library
                     , filepath
                     , conduit
                     , cereal-conduit
-                    , scotty
+                    , servant
+                    , servant-server
                     , http-types
                     , warp
                     , wai
@@ -182,6 +184,7 @@ test-suite home-assistant-controller-test
         bytestring,
         hspec,
         stm,
+        servant,
         aeson,
         cereal,
         text,

src/HomeAssistant/Runtime.hs

@@ -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

src/HomeAssistant/Runtime/Graphing.hs

@@ -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"
-    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")
+
+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)

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
+
+
+