Add send faucet end-point to local-cluster http service

justfile

@@ -31,10 +31,10 @@ bench target:
 local-cluster:
   nix shell '.#local-cluster' '.#cardano-node' \
     -c "local-cluster" \
-    control \
     --cluster-configs lib/local-cluster/test/data/cluster-configs \
     --cluster-logs ignore-me/cluster.logs \
-    --socket-path ignore-me/cluster.socket
+    --socket-path ignore-me/cluster.socket \
+    --monitoring-port 12788
 
 # run unit tests on a match
 unit-tests-cabal-match match:

lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Monitoring/Http/API.hs

@@ -10,8 +10,12 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Cardano.Wallet.Launch.Cluster.Monitoring.Http.API
-    ( API
-    , ApiT (..)
+    ( ApiT (..)
+    , ReadyAPI
+    , StepAPI
+    , SwitchAPI
+    , ObserveAPI
+    , ControlAPI
     )
 where
 
@@ -59,12 +63,13 @@ import Servant.API
     , (:>)
     )
 
--- | The API for the monitoring server
-type API =
-    "ready" :> Get '[JSON] Bool
-        :<|> "control" :> "step" :> PostNoContent
-        :<|> "control" :> "switch" :> Post '[JSON] (ApiT MonitorState)
-        :<|> "control" :> "observe" :> Get '[JSON] (ApiT (History, MonitorState))
+type ReadyAPI = "ready" :> Get '[JSON] Bool
+type StepAPI = "control" :> "step" :> PostNoContent
+type SwitchAPI = "control" :> "switch" :> Post '[JSON] (ApiT MonitorState)
+type ObserveAPI = "control" :> "observe" :> Get '[JSON] (ApiT (History, MonitorState))
+
+-- | The API to control the monitoring server
+type ControlAPI = ReadyAPI :<|> StepAPI :<|> SwitchAPI :<|> ObserveAPI
 
 -- | A newtype wrapper to avoid orphan instances
 newtype ApiT a = ApiT {unApiT :: a}

lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Monitoring/Http/Client.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE RankNTypes #-}
@@ -9,29 +10,30 @@
 {-# LANGUAGE TypeApplications #-}
 
 module Cardano.Wallet.Launch.Cluster.Monitoring.Http.Client
-    ( withHttpClient
-    , RunQuery (..)
-    , Query (..)
-    , MsgClient (..)
-    , AnyQuery (..)
+    ( RunMonitorQ (..)
+    , MonitorQ (..)
+    , MsgMonitorClient (..)
+    , AnyMonitorQ (..)
+    , newRunQuery
+    , mkMonitorClient
     )
 where
 
 import Prelude
 
 import Cardano.Wallet.Launch.Cluster.Monitoring.Http.API
-    ( API
-    , ApiT (..)
+    ( ApiT (..)
+    , ObserveAPI
+    , ReadyAPI
+    , StepAPI
+    , SwitchAPI
     )
 import Cardano.Wallet.Launch.Cluster.Monitoring.Phase
     ( History
     )
 import Control.Monad
     ( unless
     )
-import Control.Monad.Cont
-    ( ContT (..)
-    )
 import Control.Monad.IO.Class
     ( liftIO
     )
@@ -52,116 +54,92 @@ import Control.Tracer
 import Data.Functor
     ( ($>)
     )
-import Network.HTTP.Client
-    ( ManagerSettings (..)
-    , defaultManagerSettings
-    , newManager
-    , responseTimeoutNone
-    )
-import Network.Socket
-    ( PortNumber
+import Data.Text.Class
+    ( ToText (..)
     )
 import Servant
     ( NoContent
     , Proxy (..)
-    , (:<|>) (..)
     )
 import Servant.Client
-    ( BaseUrl (..)
-    , ClientM
-    , Scheme (..)
+    ( ClientM
     , client
-    , mkClientEnv
-    , runClientM
     )
 import UnliftIO
     ( MonadUnliftIO
     , UnliftIO (..)
     , askUnliftIO
-    , throwIO
     )
 
 -- | Queries that can be sent to the monitoring server via HTTP.
-data Query a where
-    ReadyQ :: Query Bool
-    ObserveQ :: Query (History, MonitorState)
-    StepQ :: Query ()
-    SwitchQ :: Query MonitorState
+data MonitorQ a where
+    ReadyQ :: MonitorQ Bool
+    ObserveQ :: MonitorQ (History, MonitorState)
+    StepQ :: MonitorQ ()
+    SwitchQ :: MonitorQ MonitorState
 
-data Client = Client
+data MonitorClient = MonitorClient
     { ready :: ClientM Bool
     , observe :: ClientM (ApiT (History, MonitorState))
     , step :: ClientM NoContent
     , switch :: ClientM (ApiT MonitorState)
     }
 
-mkClient :: Client
-mkClient =
-    let ready :<|> step :<|> switch :<|> observe = client (Proxy @API)
-    in  Client{..}
+mkMonitorClient
+    :: MonitorClient
+mkMonitorClient =
+    let ready = client (Proxy @ReadyAPI)
+        observe = client (Proxy @ObserveAPI)
+        step = client (Proxy @StepAPI)
+        switch = client (Proxy @SwitchAPI)
+    in  MonitorClient{..}
 
 -- | A showable existential wrapper around a 'Query' value, for logging purposes.
-data AnyQuery = forall a. Show a => AnyQuery (Query a)
+data AnyMonitorQ = forall a. Show a => AnyQuery (MonitorQ a)
 
-instance Show AnyQuery where
+instance Show AnyMonitorQ where
     show (AnyQuery ReadyQ) = "Ready"
     show (AnyQuery ObserveQ) = "Observe"
     show (AnyQuery StepQ) = "Step"
     show (AnyQuery SwitchQ) = "Switch"
 
 -- | Run any query against the monitoring server.
-newtype RunQuery m = RunQuery (forall a. Show a => Query a -> m a)
+newtype RunMonitorQ m = RunQuery (forall a. Show a => MonitorQ a -> m a)
 
 -- | Messages that can be logged by the http client.
-data MsgClient
-    = MsgClientStart
-    | MsgClientReq AnyQuery
-    | MsgClientRetry AnyQuery
-    | MsgClientDone
+data MsgMonitorClient
+    = MsgMonitorClientReq AnyMonitorQ
+    | MsgMonitorClientRetry AnyMonitorQ
     deriving stock (Show)
 
--- | Produce a closure over the http client of an http monitoring server that
--- can be used to query the server.
-withHttpClient
-    :: MonadUnliftIO m
-    => Tracer m MsgClient
-    -- ^ how to trace the http client operations
-    -> PortNumber
-    -- ^ Monitoring port to attach to (http://localhost is hardcoded)
-    -> ContT () m (RunQuery m)
-withHttpClient tracer httpPort = ContT $ \continue -> do
-    let tr = traceWith tracer
-    tr MsgClientStart
-    UnliftIO unlift <- askUnliftIO
-    let url = BaseUrl Http "localhost" (fromIntegral httpPort) ""
-    manager <-
-        liftIO
-            $ newManager
-            $ defaultManagerSettings
-                { managerResponseTimeout = responseTimeoutNone
-                }
-    let
-        query :: ClientM a -> IO a
-        query f = do
-            r <- runClientM f $ mkClientEnv manager url
-            either throwIO pure r
-        Client{ready, observe, step, switch} = mkClient
-    continue $ RunQuery $ \request -> do
-        tr $ MsgClientReq $ AnyQuery request
-        liftIO $ case request of
-            ReadyQ -> recoverAll retryPolicy
-                $ \rt -> do
-                    unless (firstTry rt)
-                        $ unlift
-                        $ tr
-                        $ MsgClientRetry
-                        $ AnyQuery request
-                    query ready
-            ObserveQ -> unApiT <$> query observe
-            StepQ -> query step $> ()
-            SwitchQ -> unApiT <$> query switch
+instance ToText MsgMonitorClient where
+    toText = \case
+        MsgMonitorClientReq q -> "Client request: " <> toText (show q)
+        MsgMonitorClientRetry q -> "Client retry: " <> toText (show q)
 
-    tr MsgClientDone
+newRunQuery
+    :: MonadUnliftIO m
+    => (forall a. ClientM a -> IO a)
+    -> Tracer m MsgMonitorClient
+    -> MonitorClient
+    -> m (RunMonitorQ m)
+newRunQuery query tr MonitorClient{ready, observe, step, switch} =
+    do
+        UnliftIO unlift <- askUnliftIO
+        pure $ RunQuery $ \request -> do
+            traceWith tr $ MsgMonitorClientReq $ AnyQuery request
+            liftIO $ case request of
+                ReadyQ -> recoverAll retryPolicy
+                    $ \rt -> do
+                        unless (firstTry rt)
+                            $ unlift
+                            $ traceWith tr
+                            $ MsgMonitorClientRetry
+                            $ AnyQuery request
+                        query ready
+                ObserveQ -> unApiT <$> query observe
+                StepQ -> query step $> ()
+                SwitchQ -> unApiT <$> query switch
 
 retryPolicy :: RetryPolicyM IO
 retryPolicy = capDelay (60 * oneSecond) $ exponentialBackoff oneSecond