From 14d6a8d1a67f675add5d80f2ae3329323466e7a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Baldur=20Bl=C3=B6ndal?= Date: Tue, 20 Aug 2024 10:25:22 +0100 Subject: [PATCH] cardano-tracer: Allow switching EKG service between different nodes. --- bench/ekg-restart-test/CHANGELOG.md | 5 + bench/ekg-restart-test/app/Main.hs | 100 ++++++++++ bench/ekg-restart-test/ekg-restart-test.cabal | 54 ++++++ cabal.project | 4 + cardano-tracer/cardano-tracer.cabal | 9 +- .../Tracer/Handlers/Metrics/Monitoring.hs | 175 +++++++++++++++++- .../Tracer/Handlers/Metrics/Servers.hs | 3 +- 7 files changed, 338 insertions(+), 12 deletions(-) create mode 100644 bench/ekg-restart-test/CHANGELOG.md create mode 100644 bench/ekg-restart-test/app/Main.hs create mode 100644 bench/ekg-restart-test/ekg-restart-test.cabal diff --git a/bench/ekg-restart-test/CHANGELOG.md b/bench/ekg-restart-test/CHANGELOG.md new file mode 100644 index 00000000000..b90defb5ff6 --- /dev/null +++ b/bench/ekg-restart-test/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for ekg-restart-test + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/bench/ekg-restart-test/app/Main.hs b/bench/ekg-restart-test/app/Main.hs new file mode 100644 index 00000000000..3dffaee0bef --- /dev/null +++ b/bench/ekg-restart-test/app/Main.hs @@ -0,0 +1,100 @@ +{-# Language OverloadedStrings #-} +{-# Language StandaloneKindSignatures #-} +{-# Language BangPatterns #-} +{-# Language LambdaCase #-} +{-# Language RecordWildCards #-} +{-# Language GADTs #-} +{-# Language TemplateHaskell #-} +{-# Language DeriveAnyClass #-} +{-# Language DerivingStrategies #-} +{-# Language NumericUnderscores #-} +{-# Language ScopedTypeVariables #-} +{-# Language TypeApplications #-} +{-# Language BlockArguments #-} + +module Main where + +import System.IO.Unsafe +import Data.ByteString.Builder +import Data.Kind +import qualified Data.Text as T +import Data.Text (Text) +import Control.Concurrent +import Control.Exception +import Control.Monad +import GHC.IO.Exception +import Network.Wai +import Network.Wai.Handler.Warp +import Network.Wai.Handler.Warp +import System.Metrics +import Network.Wai.Middleware.RequestLogger +import System.Remote.Monitoring.Wai +import Network.HTTP.Types +import qualified Data.Map as Map +import Data.Map (Map) + +main = m 8000 + +type ConnectedNodes :: Type +type ConnectedNodes = Map [Text] Store + +connectedNodes :: MVar ConnectedNodes +connectedNodes = unsafePerformIO do + newMVar (Map.fromList []) + +m :: Int -> IO () +m port = do + stores :: [Store] <- + replicateM 5 newStore + say + "run port" + run port do logStdout do app stores + +app :: [Store] -> Application +app stores req send = do + let + ok :: Builder -> IO ResponseReceived + ok = send . responseBuilder status200 [] + + print (queryString req) + + case pathInfo req of + [] -> do + print req + monitor (stores !! 2) req send + ["0"] -> do + ok "/0" + ["1"] -> ok "/1" + ["2"] -> monitor (stores !! 2) req send + ["3"] -> monitor (stores !! 3) req send + ["4"] -> monitor (stores !! 4) req send + path -> send do + responseBuilder + do status404 + do [] + do "Not found: " <> stringUtf8 (show path) + +-- run port $ do +-- path <- pathInfo <$> getRequestBody +-- let store = lookup path connectedNodes +-- case store of +-- Just store' -> monitor store' +-- Nothing -> response404 + +-- main :: IO () +-- main = run 3000 $ \req send -> +-- case pathInfo req of +-- [] -> send $ responseBuilder +-- status303 +-- [("Location", "/home")] +-- "Redirecting" +-- ["home"] -> send $ responseBuilder +-- status200 +-- [("Content-Type", "text/plain")] +-- "This is the home route" + +say :: String -> IO () +say msg = putStrLn (" + " ++ msg) + +sleep :: Int -> IO () +sleep n = threadDelay (fromIntegral n * 1_000_000) diff --git a/bench/ekg-restart-test/ekg-restart-test.cabal b/bench/ekg-restart-test/ekg-restart-test.cabal new file mode 100644 index 00000000000..1afab1fa085 --- /dev/null +++ b/bench/ekg-restart-test/ekg-restart-test.cabal @@ -0,0 +1,54 @@ +cabal-version: 2.4 +name: ekg-restart-test +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- A URL where users can report bugs. +-- bug-reports: + +-- The license under which the package is released. +-- license: +author: Baldur Blöndal +maintainer: baldur.blondal@iohk.io + +-- A copyright notice. +-- copyright: +-- category: +extra-source-files: CHANGELOG.md + +executable ekg-restart-test + main-is: Main.hs + other-modules: + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base >= 4.14 && < 5 + , ekg + , ekg-core + , ekg-wai + , warp + , ekg-forward ^>= 0.5 + , random + , bytestring + , network + , time + , wai + , wai-extra + , http-types + , ghc + , template-haskell + , text + , containers + , unordered-containers + ghc-options: -threaded + + hs-source-dirs: app + default-language: Haskell2010 diff --git a/cabal.project b/cabal.project index c796a173d35..9f4332fef87 100644 --- a/cabal.project +++ b/cabal.project @@ -32,6 +32,10 @@ packages: trace-resources trace-forward + -- ||| TMP PACKAGE, DON'T MAKE PR + bench/ekg-restart-test + -- ||| TMP PACKAGE, DON'T MAKE PR + extra-packages: Cabal program-options diff --git a/cardano-tracer/cardano-tracer.cabal b/cardano-tracer/cardano-tracer.cabal index cfc53723a54..35ac26b091c 100644 --- a/cardano-tracer/cardano-tracer.cabal +++ b/cardano-tracer/cardano-tracer.cabal @@ -168,18 +168,20 @@ library , containers , contra-tracer , directory - , ekg , ekg-core , ekg-forward ^>= 0.5 + , ekg-wai , extra , filepath + , http-types , mime-mail , optparse-applicative , ouroboros-network ^>= 0.17 , ouroboros-network-api , ouroboros-network-framework , signal - , smtp-mail ^>= 0.5 + , slugify + , smtp-mail == 0.3.0.0 , snap-blaze , snap-core , snap-server @@ -191,6 +193,9 @@ library , trace-forward , trace-resources , unordered-containers + , wai + , wai-extra + , warp , yaml if flag(systemd) && os(linux) diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Monitoring.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Monitoring.hs index 5b5074adb74..3968d4cd75f 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Monitoring.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Monitoring.hs @@ -1,3 +1,5 @@ +{-# Options_GHC -w #-} + {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -5,8 +7,10 @@ module Cardano.Tracer.Handlers.Metrics.Monitoring ( runMonitoringServer + , runMonitoringServerWai ) where +import Prelude hiding (head) import Cardano.Tracer.Configuration import Cardano.Tracer.Environment #if RTVIEW @@ -18,41 +22,58 @@ import Cardano.Tracer.Types import Control.Concurrent (ThreadId) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TMVar (TMVar, newEmptyTMVarIO, putTMVar, tryReadTMVar) -import Control.Concurrent.STM.TVar (readTVarIO) +import Control.Concurrent.STM.TVar (readTVar, readTVarIO) #if RTVIEW import Control.Monad (forM, void) #endif import Control.Monad.Extra (whenJust) import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString.Lazy as Lazy #if !RTVIEW import Data.Foldable import Data.Function ((&)) #endif import qualified Data.Map.Strict as M -import qualified Data.Set as S +import Data.Map.Strict (Map) +import qualified Data.Set as Set #if !RTVIEW import Data.String #endif import qualified Data.Text as T +import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) -import System.Remote.Monitoring (forkServerWith, serverThreadId) +-- import System.Remote.Monitoring hiding (forkServerWith) import System.Time.Extra (sleep) #if !RTVIEW import System.IO.Unsafe (unsafePerformIO) -import Text.Blaze.Html5 hiding (title) -import Text.Blaze.Html5.Attributes +import Text.Blaze.Html5 hiding (map) +import Text.Blaze.Html5.Attributes hiding (head, title) +import qualified Text.Blaze.Html5.Attributes as Attr #endif #if RTVIEW import qualified Graphics.UI.Threepenny as UI import Graphics.UI.Threepenny.Core (Element, UI, set, (#), (#+)) #else +import Text.Blaze.Html.Renderer.Utf8 (renderHtml) import Snap.Blaze (blaze) import Snap.Core (Snap, route) import Snap.Http.Server (Config, ConfigLog (..), defaultConfig, setAccessLog, setBind, setErrorLog, setPort, simpleHttpServe) #endif +import Network.Wai.Middleware.Approot (approotMiddleware) +import qualified System.Metrics as EKG +import Text.Slugify +import Data.Bifunctor (first) +import Data.ByteString.Builder (stringUtf8) +import qualified Data.Bimap as Bimap +import System.Remote.Monitoring.Wai +import Network.Wai +import Network.Wai.Internal +import Network.Wai.Handler.Warp hiding (setPort) +import Network.HTTP.Types + -- | 'ekg' package allows to run only one EKG server, to display only one web page -- for particular EKG.Store. Since 'cardano-tracer' can be connected to any number -- of nodes, we display their list on the first web page (the first 'Endpoint') @@ -116,7 +137,7 @@ runMonitoringServer tracerEnv (endpoint@(Endpoint listHost listPort), monitorEP) renderEkg :: Snap () renderEkg = do - nodes <- liftIO $ S.toList <$> readTVarIO teConnectedNodes + nodes <- liftIO $ Set.toList <$> readTVarIO teConnectedNodes -- HACK case nodes of [] -> @@ -147,10 +168,108 @@ ekgHtml (Endpoint monitorHost monitorPort) = \case li do a ! href (fromString ("http://" <> monitorHost <> ":" <> show monitorPort)) ! target "_blank" - ! title "Open EKG monitor page for this node" + ! Attr.title "Open EKG monitor page for this node" $ toHtml anId #endif +runMonitoringServerWai + :: TracerEnv + -> (Endpoint, Endpoint) -- ^ (web page with list of connected nodes, EKG web page). + -> IO () +runMonitoringServerWai tracerEnv (endpoint@(Endpoint listHost listPort), monitorEP) = do + -- Pause to prevent collision between "Listening"-notifications from servers. + sleep 0.2 + traceWith (teTracer tracerEnv) TracerStartedMonitoring + { ttMonitoringEndpoint = endpoint + , ttMonitoringType = "list" + } + run (fromIntegral listPort :: Port) do + renderEkg + -- simpleHttpServe config do + -- route + -- [ ("/", renderEkg) + -- ] + + -- run port do logStdout do app + + where + TracerEnv{teConnectedNodesNames, teAcceptedMetrics} = tracerEnv + + -- config :: Config Snap () + -- config = defaultConfig + -- & setErrorLog ConfigNoLog + -- & setAccessLog ConfigNoLog + -- & setBind (encodeUtf8 (T.pack listHost)) + -- & setPort (fromIntegral listPort) + + -- renderEkg :: Request -> (Response -> IO ..) -> IO .. + renderEkg :: Application + renderEkg request send = do + (nodeNames :: [NodeName], routeDictionary :: [(Text, MetricsStores)]) <- + atomically do + nIdsWithNames :: Map NodeId NodeName <- + Bimap.toMap <$> readTVar teConnectedNodesNames + + acceptedMetrics :: Map NodeId MetricsStores <- + readTVar teAcceptedMetrics + + let x :: [(NodeName, MetricsStores)] + x = M.elems (M.intersectionWith (,) nIdsWithNames acceptedMetrics) + + pure (M.elems nIdsWithNames, fmap (first slugify) x) + + case pathInfo request of + [] -> + case routeDictionary of + (_, (store :: EKG.Store, _)):_ -> monitor store request send + ["list"] -> + send $ responseLBS status200 [] (renderListOfConnectedNodes endpoint nodeNames) + route:_ + | Just (store :: EKG.Store, _tvar :: _TVar _MetricsLocalStore) <- lookup route routeDictionary + -> monitor store request { pathInfo = tail (pathInfo request) } send + | otherwise + -> send $ responseBuilder status404 [] do + "Route (" <> stringUtf8 (show route) <> ") not found\n" <> stringUtf8 (show nodeNames) <> "\n" <> stringUtf8 (show (fmap fst routeDictionary)) + path -> send $ responseBuilder status404 [] do + "Not found: " <> stringUtf8 (show path) <> "\n" <> stringUtf8 (show nodeNames) <> "\n" <> stringUtf8 (show (fmap fst routeDictionary)) +-- run port $ do +-- path <- pathInfo <$> getRequestBody +-- let store = lookup path connectedNodes +-- case store of +-- Just store' -> monitor store' +-- Nothing -> response404 + -- undefined + -- nodes <- liftIO $ S.toList <$> readTVarIO teConnectedNodes + -- -- HACK + -- case nodes of + -- [] -> + -- pure () + -- nodeId:_nodes -> liftIO do + -- restartEKGServer tracerEnv nodeId monitorEP currentServerHack + -- blaze do + -- docTypeHtml do + -- ekgHtml monitorEP nodes + +renderListOfConnectedNodes :: Endpoint -> [NodeName] -> Lazy.ByteString +renderListOfConnectedNodes (Endpoint host port) = \case + [] -> + "There are no connected nodes yet." + nodenames -> + renderHtml $ mkPage mkHref nodenames + where + + mkHref :: NodeName -> Markup + mkHref nodeName = + a ! href (textValue ("/" <> slugify nodeName)) + $ toHtml nodeName' + where + nodeName' = T.unpack nodeName + + mkPage :: (NodeName -> Markup) -> [NodeName] -> Html + mkPage f hrefs = html do + head . title $ "EKG metrics" + body . ul $ for_ hrefs (li . f) + type CurrentEKGServer = TMVar (NodeId, ThreadId) #if RTVIEW -- | The first web page contains only the list of hrefs @@ -161,7 +280,7 @@ mkPageBody -> Endpoint -> UI Element mkPageBody window tracerEnv mEP@(Endpoint monitorHost monitorPort) = do - nodes <- liftIO $ S.toList <$> readTVarIO teConnectedNodes + nodes <- liftIO $ Set.toList <$> readTVarIO teConnectedNodes nodesHrefs <- if null nodes then UI.string "There are no connected nodes yet" @@ -199,7 +318,44 @@ restartEKGServer restartEKGServer TracerEnv{teAcceptedMetrics, teTracer} newNodeId endpoint@(Endpoint monitorHost monitorPort) currentServer = do metrics <- readTVarIO teAcceptedMetrics - whenJust (metrics M.!? newNodeId) \(storeForSelectedNode, _) -> + whenJust (metrics M.!? newNodeId) \(storeForSelectedNode, _) -> do + atomically (tryReadTMVar currentServer) >>= \case + Just (_curNodeId, _sThread) -> + -- TODO: Currently we cannot restart EKG server, + -- please see https://github.com/tibbe/ekg/issues/87 + return () + -- unless (newNodeId == curNodeId) do + -- killThread sThread + -- runEKGAndSave storeForSelectedNode + Nothing -> + -- Current server wasn't stored yet, it's a first click on the href. + runEKGAndSave storeForSelectedNode + where + runEKGAndSave store = do + traceWith teTracer TracerStartedMonitoring + { ttMonitoringEndpoint = endpoint + , ttMonitoringType = "monitor" + } + ekgServer <- forkServerWith store + (encodeUtf8 . T.pack $ monitorHost) + (fromIntegral monitorPort) + atomically do + putTMVar currentServer (newNodeId, serverThreadId ekgServer) + +{- +-- | After clicking on the node's href, the user will be redirected to the monitoring page +-- which is rendered by 'ekg' package. But before, we have to check if EKG server is +-- already launched, and if so, restart the server if needed. +restartEKGServer' + :: TracerEnv + -> NodeId + -> Endpoint + -> CurrentEKGServer + -> IO () +restartEKGServer' TracerEnv{teAcceptedMetrics, teTracer} newNodeId + endpoint@(Endpoint monitorHost monitorPort) currentServer = do + metrics <- readTVarIO teAcceptedMetrics + whenJust (metrics M.!? newNodeId) \(storeForSelectedNode, _) -> do atomically (tryReadTMVar currentServer) >>= \case Just (_curNodeId, _sThread) -> -- TODO: Currently we cannot restart EKG server, @@ -222,3 +378,4 @@ restartEKGServer TracerEnv{teAcceptedMetrics, teTracer} newNodeId (fromIntegral monitorPort) atomically do putTMVar currentServer (newNodeId, serverThreadId ekgServer) +-} diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Servers.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Servers.hs index 0a50e856fd3..208d121c601 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Servers.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Servers.hs @@ -28,7 +28,8 @@ runMetricsServers tracerEnv = void do sequenceConcurrently servers servers :: [IO ()] servers = catMaybes [ runPrometheusServer tracerEnv <$> hasPrometheus - , runMonitoringServer tracerEnv <$> hasEKG + , runMonitoringServerWai tracerEnv <$> hasEKG + -- , runMonitoringServer tracerEnv <$> hasEKG ] TracerEnv