Skip to content

Commit

Permalink
[ADP-3305] Expose RunningNode in local cluster api (#4591)
Browse files Browse the repository at this point in the history 
- [x] Change the `observe` end-point to serve a full `RunningNode` value
in place of just the socket path
- [x] Test the new `RunningNode` via cardano-wallet-network

ADP-3305
  • Loading branch information
@paolino
paolino authored May 17, 2024
2 parents 47f4ccc + 56af997 commit c8dcd32
Show file tree
Hide file tree
Showing 12 changed files with 496 additions and 121 deletions.
42 changes: 31 additions & 11 deletions lib/local-cluster/data/swagger.json
View file
Original file line number Diff line number Diff line change
Expand Up @@ -21,7 +21,7 @@
"properties": {
"tag": {
"enum": [
"RetrievingFunds"
"retrieving-funds"
],
"type": "string"
}
Expand All @@ -32,7 +32,7 @@
"properties": {
"tag": {
"enum": [
"Metadata"
"metadata"
],
"type": "string"
}
Expand All @@ -43,7 +43,7 @@
"properties": {
"tag": {
"enum": [
"Genesis"
"genesis"
],
"type": "string"
}
Expand All @@ -54,7 +54,7 @@
"properties": {
"tag": {
"enum": [
"Pool0"
"pool0"
],
"type": "string"
}
Expand All @@ -65,7 +65,7 @@
"properties": {
"tag": {
"enum": [
"Funding"
"funding"
],
"type": "string"
}
Expand All @@ -76,7 +76,7 @@
"properties": {
"tag": {
"enum": [
"Pools"
"pools"
],
"type": "string"
}
Expand All @@ -87,7 +87,7 @@
"properties": {
"tag": {
"enum": [
"Relay"
"relay"
],
"type": "string"
}
Expand All @@ -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"
}
Expand Down
5 changes: 1 addition & 4 deletions lib/local-cluster/exe/local-cluster.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..)
Expand Down Expand Up @@ -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
8 changes: 0 additions & 8 deletions lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Faucet/Serialize.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
6 changes: 3 additions & 3 deletions lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Client.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
132 changes: 130 additions & 2 deletions lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/API.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,17 +16,29 @@ module Cardano.Wallet.Launch.Cluster.Http.Monitor.API
, SwitchAPI
, ObserveAPI
, ControlAPI
, renderPhase
)
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 (..)
Expand All @@ -49,9 +61,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
Expand All @@ -63,6 +84,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)
Expand All @@ -81,7 +104,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
Expand All @@ -91,9 +159,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"
Expand Down
14 changes: 8 additions & 6 deletions lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Monitor/Client.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down
Loading

0 comments on commit c8dcd32

Please sign in to comment.