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..9d116dd 100644 --- a/home-assistant-controller.cabal +++ b/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, diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index 3737b33..9e0e780 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/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 diff --git a/src/HomeAssistant/Runtime/Graphing.hs b/src/HomeAssistant/Runtime/Graphing.hs index 0534924..6a609fc 100644 --- a/src/HomeAssistant/Runtime/Graphing.hs +++ b/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" + + + +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) 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 + + +