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

@@ -12,11 +12,19 @@
 module Cardano.Wallet.Launch.Cluster.Monitoring.Http.API
     ( API
     , ApiT (..)
+    , ReadyAPI
+    , StepAPI
+    , SwitchAPI
+    , ObserveAPI
+    , ControlAPI
     )
 where
 
 import Prelude
 
+import Cardano.Wallet.Launch.Cluster.Monitoring.Http.Application.API
+    ( ApplicationAPI
+    )
 import Cardano.Wallet.Launch.Cluster.Monitoring.Http.OpenApi
     ( monitorStateSchema
     , observationSchema
@@ -59,12 +67,16 @@ 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
+
+-- | The API for the monitoring server and the query cluster application
+type API n = ControlAPI :<|> ApplicationAPI n
 
 -- | A newtype wrapper to avoid orphan instances
 newtype ApiT a = ApiT {unApiT :: a}

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

@@ -0,0 +1,27 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Cardano.Wallet.Launch.Cluster.Monitoring.Http.Application.API
+    ( ApplicationAPI
+    , SendFaucetAssetsAPI
+    )
+where
+
+import Cardano.Wallet.Launch.Cluster.Monitoring.Http.SendFaucetAssets
+    ( SendFaucetAssets
+    , WithNetwork (..)
+    )
+import Servant
+    ( JSON
+    , PostNoContent
+    , ReqBody
+    , (:>)
+    )
+
+type SendFaucetAssetsAPI n =
+    "send"
+        :> "faucet-assets"
+        :> ReqBody '[JSON] (WithNetwork SendFaucetAssets n)
+        :> PostNoContent
+
+type ApplicationAPI n = SendFaucetAssetsAPI n

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

@@ -0,0 +1,95 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Cardano.Wallet.Launch.Cluster.Monitoring.Http.Application.Client
+    ( newApplicationQ
+    , mkApplication
+    , ApplicationQ (..)
+    , AnyApplicationQ (..)
+    , RunApplicationQ (..)
+    , Application
+    )
+where
+
+import Prelude
+
+import Cardano.Wallet.Launch.Cluster.Monitoring.Http.Application.API
+    ( SendFaucetAssetsAPI
+    )
+import Cardano.Wallet.Launch.Cluster.Monitoring.Http.SendFaucetAssets
+    ( SendFaucetAssets
+    , WithNetwork (..)
+    )
+import Cardano.Wallet.Primitive.NetworkId
+    ( HasSNetworkId
+    , SNetworkId
+    )
+import Control.Monad.IO.Class
+    ( MonadIO (..)
+    )
+import Control.Tracer
+    ( Tracer
+    , traceWith
+    )
+import Data.Data
+    ( Proxy (Proxy)
+    )
+import Data.Functor
+    ( ($>)
+    )
+import Servant
+    ( NoContent
+    )
+import Servant.Client
+    ( ClientM
+    , client
+    )
+import UnliftIO
+    ( MonadUnliftIO
+    )
+
+-- | Queries that can be run against the local cluster
+data ApplicationQ a where
+    SendFaucetAssetsQ :: SendFaucetAssets -> ApplicationQ ()
+
+-- | Existential wrapper for any application query that has a show instance
+data AnyApplicationQ = forall a. Show a => AnyApplicationQ (ApplicationQ a)
+
+instance Show AnyApplicationQ where
+    show (AnyApplicationQ (SendFaucetAssetsQ _)) = "SendFaucetAssets"
+
+-- | Opaque record of the client application
+newtype Application n = Application
+    { sendFaucetAssets :: WithNetwork SendFaucetAssets n -> ClientM NoContent
+    }
+
+-- | Construct the client application given the network id witness
+mkApplication :: forall n. HasSNetworkId n => SNetworkId n -> Application n
+mkApplication _ =
+    Application
+        { sendFaucetAssets = client (Proxy @(SendFaucetAssetsAPI n))
+        }
+
+-- | Run any query against the monitoring server.
+newtype RunApplicationQ m
+    = RunApplicationQ (forall a. Show a => ApplicationQ a -> m a)
+
+-- | Construct the run function for the client application
+newApplicationQ
+    :: MonadUnliftIO m
+    => (forall a. ClientM a -> IO a)
+    -> Tracer m AnyApplicationQ
+    -> Application n
+    -> m (RunApplicationQ m)
+newApplicationQ query tr Application{..} = pure
+    $ RunApplicationQ
+    $ \request -> do
+        traceWith tr (AnyApplicationQ request)
+        case request of
+            SendFaucetAssetsQ assets ->
+                liftIO
+                    $ query
+                    $ sendFaucetAssets (WithNetwork assets) $> ()

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

@@ -0,0 +1,103 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Cardano.Wallet.Launch.Cluster.Monitoring.Http.Application.Server
+    ( ApplicationHandlers (..)
+    , mkApplicationHandlers
+    , newNodeConnVar
+    , NodeConnVar (..)
+    )
+where
+
+import Prelude
+
+import Cardano.Launcher.Node
+    ( CardanoNodeConn
+    )
+import Cardano.Wallet.Launch.Cluster
+    ( Config
+    )
+import Cardano.Wallet.Launch.Cluster.ClusterM
+    ( ClusterM
+    , runClusterM
+    )
+import Cardano.Wallet.Launch.Cluster.Faucet
+    ( sendFaucetAssetsTo
+    )
+import Cardano.Wallet.Launch.Cluster.Monitoring.Http.SendFaucetAssets
+    ( SendFaucetAssets (..)
+    )
+import Cardano.Wallet.Primitive.Types.Address
+    ( Address (..)
+    )
+import Control.Exception
+    ( throwIO
+    )
+import Data.Bifunctor
+    ( first
+    )
+import Servant
+    ( ServerError (..)
+    , err500
+    )
+import UnliftIO
+    ( atomically
+    , newTVarIO
+    , readTVarIO
+    , writeTVar
+    )
+
+import qualified Cardano.Address as Address
+
+-- | Handlers for local-cluster application
+newtype ApplicationHandlers = ApplicationHandlers
+    { handleSendAssets :: SendFaucetAssets -> IO ()
+    }
+
+-- Handler for sending assets to some addresses
+sendFaucetAssetsHandler
+    :: CardanoNodeConn
+    -> SendFaucetAssets
+    -> ClusterM ()
+sendFaucetAssetsHandler
+    relayConnection
+    SendFaucetAssets{..} = do
+        sendFaucetAssetsTo relayConnection batchSize
+            $ first mkLibAddress <$> assets
+
+mkLibAddress :: Address -> Address.Address
+mkLibAddress (Address a) = Address.unsafeMkAddress a
+
+-- | A thread-safe variable to store the connection to the Cardano node
+-- The connection could not be available at the time of creation
+data NodeConnVar = NodeConnVar
+    { getNodeConn :: IO (Maybe CardanoNodeConn)
+    , setNodeConn :: CardanoNodeConn -> IO ()
+    }
+
+-- | Create a new, empty 'NodeConnVar'
+newNodeConnVar :: IO NodeConnVar
+newNodeConnVar = do
+    var <- newTVarIO Nothing
+    pure
+        NodeConnVar
+            { getNodeConn = readTVarIO var
+            , setNodeConn = atomically . writeTVar var . Just
+            }
+
+-- | Create an application handlers record
+mkApplicationHandlers
+    :: NodeConnVar
+    -> Config
+    -> ApplicationHandlers
+mkApplicationHandlers mRelayConnection config =
+    ApplicationHandlers
+        { handleSendAssets = \ass -> do
+            mConn <- getNodeConn mRelayConnection
+            case mConn of
+                Just relayConnection ->
+                    runClusterM config
+                        $ sendFaucetAssetsHandler relayConnection ass
+                Nothing ->
+                    throwIO
+                        err500{errBody = "The relay node is not available yet"}
+        }