From 5a3ebc63a5351394afc03a7c3e80266cca5620fa Mon Sep 17 00:00:00 2001 From: paolino Date: Tue, 14 May 2024 09:07:37 +0000 Subject: [PATCH 1/5] Re-add polymorphism to the return type of continuations --- .../lib/Cardano/Wallet/Launch/Cluster/Http/Client.hs | 6 +++--- .../lib/Cardano/Wallet/Launch/Cluster/Http/Service.hs | 10 ++++++---- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Client.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Client.hs index 5658e08dab0..4d4fb6ff114 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Client.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Client.hs @@ -89,7 +89,7 @@ withHttpClient -- ^ how to trace the http client operations -> PortNumber -- ^ Monitoring port to attach to (http://localhost is hardcoded) - -> ContT () m (RunMonitorQ m, RunFaucetQ m) + -> ContT r m (RunMonitorQ m, RunFaucetQ m) withHttpClient networkId tracer httpPort = ContT $ \continue -> do let tr = traceWith tracer tr MsgClientStart @@ -111,6 +111,6 @@ withHttpClient networkId tracer httpPort = ContT $ \continue -> do query (MsgFaucetClient >$< tracer) $ mkFaucet networkId - continue (runQuery, runFaucet) - + r <- continue (runQuery, runFaucet) tr MsgClientDone + pure r diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Service.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Service.hs index 95ce865e0b4..94f587138fc 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Service.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Service.hs @@ -110,13 +110,14 @@ withServiceClient => SNetworkId n -> PortNumber -> Tracer IO MsgHttpService - -> ContT () IO (RunMonitorQ IO, RunFaucetQ IO) + -> ContT r IO (RunMonitorQ IO, RunFaucetQ IO) withServiceClient network port tr = do liftIO $ traceWith tr MsgHttpServiceClientStarted queries <- withHttpClient network (MsgHttpServiceQuery >$< tr) port ContT $ \k -> do - k queries + r <- k queries traceWith tr MsgHttpServiceClientStopped + pure r withServiceServer :: HasSNetworkId n @@ -125,7 +126,7 @@ withServiceServer -> Config -> Tracer IO MsgHttpService -> ServiceConfiguration - -> ContT () IO (PortNumber, Tracer IO Phase) + -> ContT r IO (PortNumber, Tracer IO Phase) withServiceServer network conn clusterConfig tr ServiceConfiguration{..} = do monitor <- liftIO $ withTracingState timedMonitor monitorInitialState port <- liftIO $ maybe getRandomPort pure servicePort @@ -137,5 +138,6 @@ withServiceServer network conn clusterConfig tr ServiceConfiguration{..} = do (mkFaucetHandlers conn clusterConfig) liftIO $ traceWith tr MsgHttpServiceServerStarted ContT $ \k -> do - k (port, monitorTracer monitor) + r <- k (port, monitorTracer monitor) traceWith tr MsgHttpServiceServerStopped + pure r From ed34d3676059b43ef1fd4bad96b47ec6a23152e6 Mon Sep 17 00:00:00 2001 From: paolino Date: Tue, 14 May 2024 15:57:15 +0000 Subject: [PATCH 2/5] Add one minute of recovery to all monitor queries --- .../Wallet/Launch/Cluster/Http/Monitor/Client.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/Client.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/Client.hs index 0c4cf1705f0..8aab0564e19 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/Client.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/Client.hs @@ -118,7 +118,8 @@ instance ToText MsgMonitorClient where MsgMonitorClientRetry q -> "Client retry: " <> toText (show q) newRunQuery - :: MonadUnliftIO m + :: forall m + . MonadUnliftIO m => (forall a. ClientM a -> IO a) -> Tracer m MsgMonitorClient -> MonitorClient @@ -128,15 +129,16 @@ newRunQuery query tr MonitorClient{ready, observe, step, switch} = UnliftIO unlift <- askUnliftIO pure $ RunQuery $ \request -> do traceWith tr $ MsgMonitorClientReq $ AnyQuery request - liftIO $ case request of - ReadyQ -> recoverAll retryPolicy + let recovering :: forall a. IO a -> IO a + recovering doing = recoverAll retryPolicy $ \rt -> do unless (firstTry rt) $ unlift - $ traceWith tr - $ MsgMonitorClientRetry + $ traceWith tr . MsgMonitorClientRetry $ AnyQuery request - query ready + doing + liftIO $ recovering $ case request of + ReadyQ -> query ready ObserveQ -> unApiT <$> query observe StepQ -> query step $> () SwitchQ -> unApiT <$> query switch From 6d806f2d1223ca2e3d3ba3566b43068f2d14d2f8 Mon Sep 17 00:00:00 2001 From: paolino Date: Tue, 14 May 2024 16:07:12 +0000 Subject: [PATCH 3/5] Report `RunningNode` in place of `RelayNode` on the `observe` api when the cluster is ready --- lib/local-cluster/data/swagger.json | 42 ++++-- lib/local-cluster/exe/local-cluster.hs | 5 +- .../Wallet/Launch/Cluster/Http/Monitor/API.hs | 131 +++++++++++++++++- .../Launch/Cluster/Http/Monitor/OpenApi.hs | 51 +++++-- .../Wallet/Launch/Cluster/Monitoring/Phase.hs | 33 +---- lib/local-cluster/local-cluster.cabal | 4 + .../Launch/Cluster/Http/Monitor/APISpec.hs | 121 ++++++++++++++-- 7 files changed, 319 insertions(+), 68 deletions(-) diff --git a/lib/local-cluster/data/swagger.json b/lib/local-cluster/data/swagger.json index 5a33a98b1b2..e19644351c9 100644 --- a/lib/local-cluster/data/swagger.json +++ b/lib/local-cluster/data/swagger.json @@ -21,7 +21,7 @@ "properties": { "tag": { "enum": [ - "RetrievingFunds" + "retrieving-funds" ], "type": "string" } @@ -32,7 +32,7 @@ "properties": { "tag": { "enum": [ - "Metadata" + "metadata" ], "type": "string" } @@ -43,7 +43,7 @@ "properties": { "tag": { "enum": [ - "Genesis" + "genesis" ], "type": "string" } @@ -54,7 +54,7 @@ "properties": { "tag": { "enum": [ - "Pool0" + "pool0" ], "type": "string" } @@ -65,7 +65,7 @@ "properties": { "tag": { "enum": [ - "Funding" + "funding" ], "type": "string" } @@ -76,7 +76,7 @@ "properties": { "tag": { "enum": [ - "Pools" + "pools" ], "type": "string" } @@ -87,7 +87,7 @@ "properties": { "tag": { "enum": [ - "Relay" + "relay" ], "type": "string" } @@ -96,13 +96,33 @@ }, { "properties": { - "contents": { - "description": "The socket file or pipe of a relay node", - "type": "string" + "content": { + "description": "A running node", + "properties": { + "genesis": { + "additionalProperties": true, + "type": "object" + }, + "socket": { + "type": "string" + }, + "version": { + "properties": { + "magic": { + "type": "number" + }, + "query": { + "type": "boolean" + } + }, + "type": "object" + } + }, + "type": "object" }, "tag": { "enum": [ - "Cluster" + "cluster" ], "type": "string" } diff --git a/lib/local-cluster/exe/local-cluster.hs b/lib/local-cluster/exe/local-cluster.hs index 8f1b622769a..f3fa768ecac 100644 --- a/lib/local-cluster/exe/local-cluster.hs +++ b/lib/local-cluster/exe/local-cluster.hs @@ -39,7 +39,6 @@ import Cardano.Wallet.Launch.Cluster.Http.Service ) import Cardano.Wallet.Launch.Cluster.Monitoring.Phase ( Phase (..) - , RelayNode (..) ) import Cardano.Wallet.Primitive.NetworkId ( NetworkId (..) @@ -333,9 +332,7 @@ main = withUtf8 $ do liftIO $ traceWith phaseTracer $ Cluster - $ Just - $ RelayNode - $ toFilePath nodeSocket + $ Just node debug "Wait forever or ctrl-c" threadDelay maxBound diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/API.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/API.hs index 56da92797fc..eb2c00d80bd 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/API.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/API.hs @@ -21,12 +21,23 @@ where import Prelude +import Cardano.Launcher.Node + ( cardanoNodeConn + , nodeSocketFile + ) import Cardano.Wallet.Launch.Cluster.Http.Monitor.OpenApi ( monitorStateSchema , observationSchema ) import Cardano.Wallet.Launch.Cluster.Monitoring.Phase ( History (..) + , Phase (..) + ) +import Cardano.Wallet.Launch.Cluster.Node.RunningNode + ( RunningNode (..) + ) +import Control.Applicative + ( asum ) import Control.Monitoring.Tracing ( MonitorState (..) @@ -49,9 +60,18 @@ import Data.OpenApi ( NamedSchema (..) , ToSchema (..) ) +import Data.Text + ( Text + ) import GHC.Generics ( Generic (..) ) +import Ouroboros.Network.Magic + ( NetworkMagic (..) + ) +import Ouroboros.Network.NodeToClient + ( NodeToClientVersionData (..) + ) import Servant ( Post , PostNoContent @@ -63,6 +83,8 @@ import Servant.API , (:>) ) +import qualified Data.Map as Map + type ReadyAPI = "ready" :> Get '[JSON] Bool type StepAPI = "control" :> "step" :> PostNoContent type SwitchAPI = "control" :> "switch" :> Post '[JSON] (ApiT MonitorState) @@ -81,7 +103,52 @@ renderHistory History{history} = toJSON $ do pure $ object [ "time" .= time - , "phase" .= phase + , "phase" .= renderPhase phase + ] + +renderTagged :: Text -> Value +renderTagged tagName = + object + [ "tag" .= tagName + ] + +renderTaggedWithContent :: Text -> (Maybe Value) -> Value +renderTaggedWithContent tagName mContent = + object + $ [ "tag" .= tagName + ] + <> ["content" .= content | Just content <- [mContent]] + +renderPhase :: Phase -> Value +renderPhase = \case + RetrievingFunds -> renderTagged "retrieving-funds" + Metadata -> renderTagged "metadata" + Genesis -> renderTagged "genesis" + Pool0 -> renderTagged "pool0" + Funding -> renderTagged "funding" + Pools -> renderTagged "pools" + Relay -> renderTagged "relay" + Cluster mNode -> renderTaggedWithContent "cluster" $ fmap renderNode mNode + +renderNode :: RunningNode -> Value +renderNode + RunningNode + { runningNodeSocketPath + , runningNodeShelleyGenesis + , runningNodeVersionData = + NodeToClientVersionData + { networkMagic = NetworkMagic nm + , query + } + } = + object + [ "socket" .= nodeSocketFile runningNodeSocketPath + , "genesis" .= runningNodeShelleyGenesis + , "version" + .= object + [ "magic" .= nm + , "query" .= query + ] ] parseHistory :: Value -> Parser History @@ -91,9 +158,69 @@ parseHistory = withArray "History" $ \arr -> do where parsePhase = withObject "Phase" $ \o -> do time <- o .: "time" - phase <- o .: "phase" + phase <- o .: "phase" >>= parsePhase' pure (time, phase) +type Tags a = [(Text, [Either a (Value -> Parser a)])] + +tag :: a -> b -> (a, [b]) +tag a b = (a, [b]) + +tags :: a -> [b] -> (a, [b]) +tags a bs = (a, bs) + +parseTaggeds :: Tags a -> Value -> Parser a +parseTaggeds ts = withObject "Tagged" $ \o -> do + t <- o .: "tag" + case Map.lookup t $ Map.fromList ts of + Just fs -> + let g :: Either a (Value -> Parser a) -> Parser a + g = \case + Left a -> pure a + Right f -> o .: "content" >>= f + in asum $ g <$> fs + Nothing -> fail "Invalid tag" + +parsePhase' :: Value -> Parser Phase +parsePhase' = + parseTaggeds + [ tag "retrieving-funds" $ Left RetrievingFunds + , tag "metadata" $ Left Metadata + , tag "genesis" $ Left Genesis + , tag "pool0" $ Left Pool0 + , tag "funding" $ Left Funding + , tag "pools" $ Left Pools + , tag "relay" $ Left Relay + , tags "cluster" [Right parseNode, Left $ Cluster Nothing] + ] + +parseNode :: Value -> Parser Phase +parseNode = withObject "RunningNode" $ \o -> do + socket <- o .: "socket" + genesis <- o .: "genesis" + version <- o .: "version" >>= parseVersionData + case cardanoNodeConn socket of + Left e -> fail e + Right nodeConn -> + pure + $ Cluster + $ Just + RunningNode + { runningNodeSocketPath = nodeConn + , runningNodeShelleyGenesis = genesis + , runningNodeVersionData = version + } + +parseVersionData :: Value -> Parser NodeToClientVersionData +parseVersionData = withObject "NodeToClientVersionData" $ \o -> do + nm <- o .: "magic" + query <- o .: "query" + pure + NodeToClientVersionData + { networkMagic = NetworkMagic nm + , query + } + instance ToJSON (ApiT MonitorState) where toJSON = \case ApiT Wait -> String "waiting" diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/OpenApi.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/OpenApi.hs index 1de0e7158e3..0ccbfd530e9 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/OpenApi.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/OpenApi.hs @@ -6,6 +6,7 @@ module Cardano.Wallet.Launch.Cluster.Http.Monitor.OpenApi , monitoringDefinitions , monitorStateSchema , observationSchema + , phaseSchema ) where import Prelude @@ -21,7 +22,9 @@ import Data.HashMap.Strict.InsOrd ( InsOrdHashMap ) import Data.OpenApi - ( Definitions + ( AdditionalProperties (AdditionalPropertiesAllowed) + , Definitions + , HasAdditionalProperties (additionalProperties) , HasContent (..) , HasDescription (..) , HasEnum (..) @@ -106,28 +109,48 @@ taggedWithContent tagName mContentSchema = & enum_ ?~ [String tagName] ) ] - <> maybe [] (\s' -> [("contents", Inline s')]) mContentSchema + <> maybe [] (\s' -> [("content", Inline s')]) mContentSchema phaseSchema :: Schema phaseSchema = mempty & type_ ?~ OpenApiString & description ?~ "The different phases the cluster can be in" & oneOf - ?~ [ tagged "RetrievingFunds" - , tagged "Metadata" - , tagged "Genesis" - , tagged "Pool0" - , tagged "Funding" - , tagged "Pools" - , tagged "Relay" - , taggedWithContent "Cluster" $ Just relayNodeSchema + ?~ [ tagged "retrieving-funds" + , tagged "metadata" + , tagged "genesis" + , tagged "pool0" + , tagged "funding" + , tagged "pools" + , tagged "relay" + , taggedWithContent "cluster" $ Just runningNodeSchema ] -relayNodeSchema :: Schema -relayNodeSchema = +runningNodeSchema :: Schema +runningNodeSchema = mempty - & type_ ?~ OpenApiString - & description ?~ "The socket file or pipe of a relay node" + & type_ ?~ OpenApiObject + & description ?~ "A running node" + & properties + .~ [ ("socket", Inline $ mempty & type_ ?~ OpenApiString) + , ("genesis", Inline genesisSchema) + , ("version", Inline nodeToClientVersionDataSchema) + ] + +genesisSchema :: Schema +genesisSchema = + mempty + & type_ ?~ OpenApiObject + & additionalProperties ?~ AdditionalPropertiesAllowed True + +nodeToClientVersionDataSchema :: Schema +nodeToClientVersionDataSchema = + mempty + & type_ ?~ OpenApiObject + & properties + .~ [ ("magic", Inline $ mempty & type_ ?~ OpenApiNumber) + , ("query", Inline $ mempty & type_ ?~ OpenApiBoolean) + ] monitoringPaths :: InsOrdHashMap FilePath PathItem monitoringPaths = diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Monitoring/Phase.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Monitoring/Phase.hs index 531e29fd462..331074bb48c 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Monitoring/Phase.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Monitoring/Phase.hs @@ -1,27 +1,16 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} module Cardano.Wallet.Launch.Cluster.Monitoring.Phase ( Phase (..) - , RelayNode (..) , History (..) ) where import Prelude -import Cardano.Launcher.Node - ( cardanoNodeConn - , nodeSocketFile - ) -import Data.Aeson - ( FromJSON - , ToJSON - ) -import Data.Aeson.Types - ( FromJSON (..) - , ToJSON (..) +import Cardano.Wallet.Launch.Cluster.Node.RunningNode + ( RunningNode ) import Data.Time ( UTCTime @@ -30,20 +19,6 @@ import GHC.Generics ( Generic ) --- | A relay node as a reference to its socket file or pipe -newtype RelayNode = RelayNode FilePath - deriving stock (Eq, Show, Generic) - -instance ToJSON RelayNode where - toJSON (RelayNode f) = toJSON f - -instance FromJSON RelayNode where - parseJSON x = do - f <- parseJSON x - case cardanoNodeConn f of - Right conn -> pure $ RelayNode $ nodeSocketFile conn - Left e -> fail e - -- | The different phases the cluster can be in. We use the convention to report -- the start of a phase. data Phase @@ -54,9 +29,9 @@ data Phase | Funding | Pools | Relay - | Cluster (Maybe RelayNode) + | Cluster (Maybe RunningNode) deriving stock (Eq, Show, Generic) - deriving anyclass (ToJSON, FromJSON) + -- deriving anyclass (ToJSON, FromJSON) -- | The history of the cluster phases newtype History = History diff --git a/lib/local-cluster/local-cluster.cabal b/lib/local-cluster/local-cluster.cabal index 858d3b33941..da48654688a 100644 --- a/lib/local-cluster/local-cluster.cabal +++ b/lib/local-cluster/local-cluster.cabal @@ -195,8 +195,10 @@ common test-common hs-source-dirs: test/unit build-depends: , aeson + , aeson-qq , base , bytestring + , cardano-ledger-shelley , cardano-wallet-application-extras , cardano-wallet-launcher , cardano-wallet-primitive @@ -211,6 +213,7 @@ common test-common , local-cluster , mtl , openapi3 + , ouroboros-network , pathtype , process , QuickCheck @@ -218,6 +221,7 @@ common test-common , unliftio , with-utf8 + build-tool-depends: , hspec-discover:hspec-discover , local-cluster:local-cluster diff --git a/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/Monitor/APISpec.hs b/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/Monitor/APISpec.hs index 2d32b3cea1e..f4326629ed2 100644 --- a/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/Monitor/APISpec.hs +++ b/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/Monitor/APISpec.hs @@ -1,4 +1,7 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} module Cardano.Wallet.Launch.Cluster.Http.Monitor.APISpec ( spec @@ -9,13 +12,25 @@ where import Prelude +import Cardano.Launcher.Node + ( CardanoNodeConn + , cardanoNodeConn + ) +import Cardano.Ledger.Shelley.Genesis + ( ShelleyGenesis + ) +import Cardano.Wallet.Launch.Cluster + ( RunningNode (..) + ) import Cardano.Wallet.Launch.Cluster.Http.Monitor.API ( ApiT (..) ) import Cardano.Wallet.Launch.Cluster.Monitoring.Phase ( History (..) , Phase (..) - , RelayNode (..) + ) +import Cardano.Wallet.Primitive.Ledger.Shelley + ( StandardCrypto ) import Control.Monitoring.Tracing ( MonitorState (..) @@ -24,8 +39,12 @@ import Data.Aeson ( FromJSON (..) , Result (..) , ToJSON (..) + , Value , fromJSON ) +import Data.Aeson.QQ + ( aesonQQ + ) import Data.OpenApi ( ToSchema , validateToJSON @@ -35,6 +54,12 @@ import Data.Time , UTCTime (UTCTime) , secondsToDiffTime ) +import Ouroboros.Network.Magic + ( NetworkMagic (..) + ) +import Ouroboros.Network.NodeToClient + ( NodeToClientVersionData (..) + ) import Test.Hspec ( Expectation , Spec @@ -99,12 +124,92 @@ genPhase = , pure Funding , pure Pools , pure Relay - , Cluster - <$> oneof - [pure Nothing, Just <$> genRelayNodePath] + , Cluster <$> oneof [pure Nothing, Just <$> genRunningNode] ] -genRelayNodePath :: Gen RelayNode -genRelayNodePath = - RelayNode <$> do - oneof [pure "path1", pure "path1/path2", pure "/path3"] +genCardanoNodeConn :: Gen CardanoNodeConn +genCardanoNodeConn = do + mConn <- + cardanoNodeConn <$> do + oneof [pure "path1", pure "path1/path2", pure "/path3"] + case mConn of + Left e -> error $ "genCardanoNodeConn: " <> e + Right conn -> pure conn + +genRunningNode :: Gen RunningNode +genRunningNode = do + socket <- genCardanoNodeConn + genesis <- genShelleyGenesis + version <- genNodeToClientVersionData + pure + $ RunningNode + { runningNodeSocketPath = socket + , runningNodeShelleyGenesis = genesis + , runningNodeVersionData = version + } + +genNodeToClientVersionData :: Gen NodeToClientVersionData +genNodeToClientVersionData = + pure + $ NodeToClientVersionData + { networkMagic = NetworkMagic 42 + , query = True + } + +genShelleyGenesis :: Gen (ShelleyGenesis StandardCrypto) +genShelleyGenesis = pure $ case fromJSON shelleyGenesis of + Success genesis -> genesis + Error e -> error e + +shelleyGenesis :: Value +shelleyGenesis = + [aesonQQ| +{ + "activeSlotsCoeff": 5.0e-2, + "epochLength": 21600, + "genDelegs": { + "8a1cebc0df78b69ef71099de3867a78d85b93b57513fc0508b27bee6": { + "delegate": "2103d8279e759d7163d1422467cfb88c19e584adc9506d4b8484a397", + "vrf": "8d8f6e4c0685ca835d7dbe4ec4c240f4d71d0ceb2e4fe1d7bd97b7b3d30f435d" + } + }, + "initialFunds": {}, + "maxKESEvolutions": 62, + "maxLovelaceSupply": 45000000000000000, + "networkId": "Testnet", + "networkMagic": 42, + "protocolParams": { + "a0": 0.3, + "decentralisationParam": 1.0, + "eMax": 18, + "extraEntropy": { + "tag": "NeutralNonce" + }, + "keyDeposit": 2000000, + "maxBlockBodySize": 65536, + "maxBlockHeaderSize": 1100, + "maxTxSize": 16384, + "minFeeA": 44, + "minFeeB": 155381, + "minPoolCost": 340000000, + "minUTxOValue": 1000000, + "nOpt": 150, + "poolDeposit": 500000000, + "protocolVersion": { + "major": 6, + "minor": 0 + }, + "rho": 3.0e-3, + "tau": 0.2 + }, + "securityParam": 108, + "slotLength": 1, + "slotsPerKESPeriod": 129600, + "staking": { + "pools": {}, + "stake": {} + }, + "systemStart": "2024-03-25T10:34:26.544957596Z", + "updateQuorum": 1 +} +|] From cbd67666d89be8af1f9edcc47678945ee1b14b66 Mon Sep 17 00:00:00 2001 From: paolino Date: Tue, 14 May 2024 16:13:40 +0000 Subject: [PATCH 4/5] Add JSON counterexample for failing roundtrips and openapi validation --- .../Wallet/Launch/Cluster/Http/Monitor/API.hs | 1 + lib/local-cluster/local-cluster.cabal | 1 + .../Launch/Cluster/Http/Monitor/APISpec.hs | 78 ++++++++++++++++--- 3 files changed, 70 insertions(+), 10 deletions(-) diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/API.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/API.hs index eb2c00d80bd..0d9af51f4e2 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/API.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/API.hs @@ -16,6 +16,7 @@ module Cardano.Wallet.Launch.Cluster.Http.Monitor.API , SwitchAPI , ObserveAPI , ControlAPI + , renderPhase ) where diff --git a/lib/local-cluster/local-cluster.cabal b/lib/local-cluster/local-cluster.cabal index da48654688a..5e2d672c59f 100644 --- a/lib/local-cluster/local-cluster.cabal +++ b/lib/local-cluster/local-cluster.cabal @@ -195,6 +195,7 @@ common test-common hs-source-dirs: test/unit build-depends: , aeson + , aeson-pretty , aeson-qq , base , bytestring diff --git a/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/Monitor/APISpec.hs b/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/Monitor/APISpec.hs index f4326629ed2..78f2988af3e 100644 --- a/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/Monitor/APISpec.hs +++ b/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/Monitor/APISpec.hs @@ -24,6 +24,13 @@ import Cardano.Wallet.Launch.Cluster ) import Cardano.Wallet.Launch.Cluster.Http.Monitor.API ( ApiT (..) + , renderPhase + ) +import Cardano.Wallet.Launch.Cluster.Http.Monitor.OpenApi + ( monitorStateSchema + , monitoringDefinitions + , observationSchema + , phaseSchema ) import Cardano.Wallet.Launch.Cluster.Monitoring.Phase ( History (..) @@ -42,12 +49,16 @@ import Data.Aeson , Value , fromJSON ) +import Data.Aeson.Encode.Pretty + ( encodePretty + ) import Data.Aeson.QQ ( aesonQQ ) import Data.OpenApi - ( ToSchema - , validateToJSON + ( Definitions + , Schema + , validateJSON ) import Data.Time ( Day (ModifiedJulianDay) @@ -70,33 +81,80 @@ import Test.Hspec import Test.QuickCheck ( Arbitrary (..) , Gen + , Property + , Testable + , counterexample , forAll + , forAllShrink , listOf , oneof + , shrinkList + , shrinkNothing ) +import qualified Data.ByteString.Lazy.Char8 as BL + jsonRoundtrip :: (ToJSON a, FromJSON a, Eq a, Show a) => a -> IO () jsonRoundtrip a = fromJSON (toJSON a) `shouldBe` Success a -validate :: (ToJSON t, ToSchema t) => t -> Expectation -validate x = validateToJSON x `shouldBe` [] +validate :: Definitions Schema -> Schema -> Value -> Expectation +validate defs sch x = validateJSON defs sch x `shouldBe` [] + +validateInstance :: ToJSON a => Definitions Schema -> Schema -> a -> Expectation +validateInstance defs sch = validate defs sch . toJSON + +counterExampleJSON + :: (Testable prop) + => String + -> (a -> Value) + -> (a -> prop) + -> a + -> Property +counterExampleJSON t tojson f x = + counterexample + ("Failed to " <> t <> ":\n" <> BL.unpack (encodePretty $ tojson x)) + $ f x + +counterExampleJSONInstance + :: (Testable prop, ToJSON (ApiT a)) + => String + -> (ApiT a -> prop) + -> a + -> Property +counterExampleJSONInstance t f x = counterExampleJSON t toJSON f $ ApiT x spec :: Spec spec = do describe "observe endpoint" $ do it "json response roundtrips" - $ forAll genObservation - $ jsonRoundtrip . ApiT + $ forAllShrink genObservation shrinkObservation + $ counterExampleJSONInstance "roundtrip" jsonRoundtrip it "json response schema validates random data" - $ forAll genObservation - $ validate . ApiT + $ forAllShrink genObservation shrinkNothing + $ counterExampleJSONInstance "validate" + $ validateInstance monitoringDefinitions observationSchema + describe "phase type" $ do + it "json response validates random data" + $ forAll genPhase + $ counterExampleJSON "validate" renderPhase + $ validate monitoringDefinitions phaseSchema . renderPhase describe "switch endpoint" $ do it "json response roundtrips" $ forAll genMonitorState - $ jsonRoundtrip . ApiT + $ counterExampleJSONInstance "roundtrip" jsonRoundtrip it "json response validates random data" $ forAll genMonitorState - $ validate . ApiT + $ counterExampleJSONInstance "validate" + $ validateInstance monitoringDefinitions monitorStateSchema + +shrinkObservation :: (History, MonitorState) -> [(History, MonitorState)] +shrinkObservation (h, s) = [(h', s) | h' <- shrinkHistory h] + +shrinkHistory :: History -> [History] +shrinkHistory (History xs) = + [ History xs' + | xs' <- shrinkList pure xs + ] genObservation :: Gen (History, MonitorState) genObservation = do From 56af9977ba15a6edb0e1266cde226b826256bdd7 Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 15 May 2024 12:04:03 +0000 Subject: [PATCH 5/5] Add network layer access in the local-cluster http service specs --- .../Wallet/Launch/Cluster/Faucet/Serialize.hs | 8 -- lib/local-cluster/local-cluster.cabal | 17 ++-- .../Wallet/Launch/Cluster/Http/ServiceSpec.hs | 95 +++++++++++++++---- 3 files changed, 90 insertions(+), 30 deletions(-) diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Faucet/Serialize.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Faucet/Serialize.hs index a668029385f..0bb2fe43f4b 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Faucet/Serialize.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Faucet/Serialize.hs @@ -83,14 +83,6 @@ faucetFundsToValue FaucetFunds{..} = massiveWalletFunds' = encodeAddrCoins massiveWalletFunds encodeAddrCoins = map (\(addr, Coin coin) -> (bech32 addr, coin)) - -- encodeTokenBundle :: (TokenBundle, [(String, String)]) -> Value - -- encodeTokenBundle (bundle, keys) = - -- let (Coin c, assets) = toFlatList bundle - -- in object - -- [ "coin" .= c - -- , "assets" .= (encodeAssets <$> assets) - -- , "keys" .= keys - -- ] encodeTokenBundle :: (TokenBundle, [(String, String)]) -> Value encodeTokenBundle (bundle, keys) = let (Coin c, assets) = toFlatList bundle diff --git a/lib/local-cluster/local-cluster.cabal b/lib/local-cluster/local-cluster.cabal index 5e2d672c59f..62d3dc36198 100644 --- a/lib/local-cluster/local-cluster.cabal +++ b/lib/local-cluster/local-cluster.cabal @@ -10,7 +10,9 @@ maintainer: hal@cardanofoundation.org copyright: 2023 Cardano Foundation category: Web build-type: Simple -data-files: data/swagger.json + +data-files: + data/swagger.json common language default-language: Haskell2010 @@ -26,6 +28,7 @@ common language -Wmissing-deriving-strategies -Wmissing-local-signatures -Wpartial-fields -Wredundant-constraints -Wtabs -Wunused-foralls -Wunused-packages + -Wno-missing-home-modules flag release description: Enable optimization and `-Werror` @@ -202,6 +205,7 @@ common test-common , cardano-ledger-shelley , cardano-wallet-application-extras , cardano-wallet-launcher + , cardano-wallet-network-layer , cardano-wallet-primitive , cardano-wallet-test-utils , contra-tracer @@ -227,6 +231,12 @@ common test-common , hspec-discover:hspec-discover , local-cluster:local-cluster +-- until cabal has no support for multi home, hls requires to have only one home +-- for the other modules , so we cannot use the common test-common for those +test-suite test-local-cluster + import: test-common + main-is: test.hs + type: exitcode-stdio-1.0 other-modules: Cardano.Wallet.Launch.Cluster.Faucet.SerializeSpec Cardano.Wallet.Launch.Cluster.Http.Faucet.APISpec @@ -240,11 +250,6 @@ common test-common Spec SpecHook -test-suite test-local-cluster - import: test-common - main-is: test.hs - type: exitcode-stdio-1.0 - executable test-local-cluster-exe import: test-common main-is: test-exe.hs diff --git a/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/ServiceSpec.hs b/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/ServiceSpec.hs index e902ae76b38..b9a009728d0 100644 --- a/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/ServiceSpec.hs +++ b/lib/local-cluster/test/unit/Cardano/Wallet/Launch/Cluster/Http/ServiceSpec.hs @@ -24,6 +24,7 @@ import Cardano.Launcher import Cardano.Wallet.Launch.Cluster ( FaucetFunds (FaucetFunds) , FileOf (..) + , RunningNode (..) ) import Cardano.Wallet.Launch.Cluster.Faucet.Serialize ( saveFunds @@ -44,15 +45,32 @@ import Cardano.Wallet.Launch.Cluster.Monitoring.Phase ( History (..) , Phase (..) ) +import Cardano.Wallet.Network + ( NetworkLayer (currentNodeTip) + ) +import Cardano.Wallet.Network.Implementation + ( withNetworkLayer + ) +import Cardano.Wallet.Network.Implementation.Ouroboros + ( tunedForMainnetPipeliningStrategy + ) import Cardano.Wallet.Network.Ports ( PortNumber , getRandomPort ) +import Cardano.Wallet.Primitive.Ledger.Shelley + ( CardanoBlock + , StandardCrypto + , fromGenesisData + ) import Cardano.Wallet.Primitive.NetworkId ( NetworkId (..) , SNetworkId (SMainnet) , withSNetworkId ) +import Cardano.Wallet.Primitive.SyncProgress + ( SyncTolerance (SyncTolerance) + ) import Control.Monad ( forM_ , unless @@ -112,6 +130,8 @@ import UnliftIO.Directory ( createDirectoryIfMissing ) +import qualified Cardano.Wallet.Network.Implementation as NL + testService :: MonitorState -> (Tracer IO Phase -> RunMonitorQ IO -> IO ()) @@ -192,9 +212,8 @@ getClusterLogsMinSeverity = lookupEnv "CLUSTER_LOGS_MIN_SEVERITY" testServiceWithCluster :: FilePath -> FaucetFunds - -> ((RunMonitorQ IO, RunFaucetQ IO) -> IO ()) - -> IO () -testServiceWithCluster name faucetFundsValue action = evalContT $ do + -> ContT () IO ((RunMonitorQ IO, RunFaucetQ IO), ToTextTracer) +testServiceWithCluster name faucetFundsValue = do port <- liftIO getRandomPort faucetFundsPath <- ContT withTempFile liftIO $ saveFunds (FileOf $ absFile faucetFundsPath) faucetFundsValue @@ -215,7 +234,23 @@ testServiceWithCluster name faucetFundsValue action = evalContT $ do DoNotSendSigINT queries <- withSNetworkId (NTestnet 42) $ \network -> withServiceClient network port nullTracer - liftIO $ action queries + pure (queries, ToTextTracer processLogs) + +withNetwork + :: Tracer IO NL.Log + -> RunningNode + -> ContT r IO (NetworkLayer IO (CardanoBlock StandardCrypto)) +withNetwork tr (RunningNode sock genesisData vData) = do + let (np, _, _) = fromGenesisData genesisData + let sTol = SyncTolerance 60 + ContT + $ withNetworkLayer + tr + tunedForMainnetPipeliningStrategy + np + sock + vData + sTol noFunds :: FaucetFunds noFunds = FaucetFunds [] [] [] @@ -278,16 +313,44 @@ spec = do (History phases, _state) <- query ObserveQ snd <$> phases `shouldBe` [RetrievingFunds] describe "withService application" $ do - it "can start and stop" $ do - testServiceWithCluster - "can-start-and-stop" noFunds - $ \(RunQuery query, _) -> do + it "can start and stop" $ evalContT $ do + ((RunQuery query, _), _) <- + testServiceWithCluster + "can-start-and-stop" + noFunds + liftIO $ do + result <- query ReadyQ + result `shouldBe` False + it "can wait for cluster ready before ending" $ evalContT $ do + ((RunQuery query, _), _) <- + testServiceWithCluster + "can-wait-for-cluster-ready-before-ending" + noFunds + liftIO $ do + fix $ \loop -> do result <- query ReadyQ - result `shouldBe` False - it "can wait for cluster ready before ending" $ do - testServiceWithCluster - "can-wait-for-cluster-ready-before-ending" noFunds - $ \(RunQuery query, _) -> do - fix $ \loop -> do - result <- query ReadyQ - unless result $ threadDelay 10000 >> loop + unless result $ threadDelay 10000 >> loop + describe "withNetwork" $ do + it "can start and stop" $ evalContT $ do + ((query, _), ToTextTracer tr) <- + testServiceWithCluster + "withNetwork-can-start-and-stop" + noFunds + node <- liftIO $ waitForNode query + nl <- withNetwork tr node + tip <- liftIO $ currentNodeTip nl + tip `seq` pure () + +waitForNode :: RunMonitorQ IO -> IO RunningNode +waitForNode (RunQuery query) = fix $ \loop -> do + (history', _) <- query ObserveQ + case getNode history' of + Nothing -> threadDelay 10000 >> loop + Just node -> pure node + +getNode :: History -> Maybe RunningNode +getNode (History phases) = case phases of + [] -> Nothing + (_time, phase) : _ -> case phase of + Cluster (Just node) -> Just node + _ -> Nothing