diff --git a/default.nix b/default.nix index 51ccfba..ed421bf 100644 --- a/default.nix +++ b/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 = [ diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index 2814112..a655a1b 100644 --- a/home-assistant-controller.cabal +++ b/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, diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index 2b4cc25..891ec51 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/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 diff --git a/src/HomeAssistant/Runtime/Graphing.hs b/src/HomeAssistant/Runtime/Graphing.hs index 0534924..dfd8cb8 100644 --- a/src/HomeAssistant/Runtime/Graphing.hs +++ b/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") + diff --git a/src/HttpServer.hs b/src/HttpServer.hs new file mode 100644 index 0000000..6a9258d --- /dev/null +++ b/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 + + diff --git a/test/GraphingSpec.hs b/test/GraphingSpec.hs index 40255f8..1028a7f 100644 --- a/test/GraphingSpec.hs +++ b/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 + + +