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

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,61 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Cardano.Wallet.Launch.Cluster.Monitoring.Http.Application.Server
+    ( ApplicationHandlers (..)
+    , mkApplicationHandlers
+    )
+where
+
+import Prelude
+
+import Cardano.Launcher.Node
+    ( CardanoNodeConn
+    )
+import Cardano.Wallet.Launch.Cluster.ClusterM
+    ( ClusterM
+    , UnliftClusterM (..)
+    )
+import Cardano.Wallet.Launch.Cluster.Faucet
+    ( sendFaucetAssetsTo
+    )
+import Cardano.Wallet.Launch.Cluster.Monitoring.Http.SendFaucetAssets
+    ( SendFaucetAssets (..)
+    )
+import Cardano.Wallet.Primitive.Types.Address
+    ( Address (..)
+    )
+import Data.Bifunctor
+    ( first
+    )
+
+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
+
+-- | Create an application handlers record
+mkApplicationHandlers
+    :: CardanoNodeConn
+    -> UnliftClusterM
+    -> ApplicationHandlers
+mkApplicationHandlers relayConnection (UnliftClusterM unlift _) =
+    ApplicationHandlers
+        { handleSendAssets =
+            unlift . sendFaucetAssetsHandler relayConnection
+        }

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

@@ -20,12 +20,25 @@ where
 import Prelude
 
 import Cardano.Wallet.Launch.Cluster.Monitoring.Http.API
-    ( API
-    , ApiT (..)
+    ( ApiT (..)
+    , ObserveAPI
+    , ReadyAPI
+    , StepAPI
+    , SwitchAPI
+    )
+import Cardano.Wallet.Launch.Cluster.Monitoring.Http.Application.Client
+    ( AnyApplicationQ
+    , RunApplicationQ
+    , mkApplication
+    , newApplicationQ
     )
 import Cardano.Wallet.Launch.Cluster.Monitoring.Phase
     ( History
     )
+import Cardano.Wallet.Primitive.NetworkId
+    ( HasSNetworkId
+    , SNetworkId
+    )
 import Control.Monad
     ( unless
     )
@@ -52,6 +65,9 @@ import Control.Tracer
 import Data.Functor
     ( ($>)
     )
+import Data.Functor.Contravariant
+    ( (>$<)
+    )
 import Network.HTTP.Client
     ( ManagerSettings (..)
     , defaultManagerSettings
@@ -64,7 +80,6 @@ import Network.Socket
 import Servant
     ( NoContent
     , Proxy (..)
-    , (:<|>) (..)
     )
 import Servant.Client
     ( BaseUrl (..)
@@ -95,9 +110,13 @@ data Client = Client
     , switch :: ClientM (ApiT MonitorState)
     }
 
-mkClient :: Client
+mkClient
+    :: Client
 mkClient =
-    let ready :<|> step :<|> switch :<|> observe = client (Proxy @API)
+    let ready = client (Proxy @ReadyAPI)
+        observe = client (Proxy @ObserveAPI)
+        step = client (Proxy @StepAPI)
+        switch = client (Proxy @SwitchAPI)
     in  Client{..}
 
 -- | A showable existential wrapper around a 'Query' value, for logging purposes.
@@ -117,22 +136,47 @@ data MsgClient
     = MsgClientStart
     | MsgClientReq AnyQuery
     | MsgClientRetry AnyQuery
+    | MsgClienAppReq AnyApplicationQ
     | MsgClientDone
     deriving stock (Show)
 
+newRunQuery
+    :: MonadUnliftIO m
+    => (forall a. ClientM a -> IO a)
+    -> Tracer m MsgClient
+    -> Client
+    -> m (RunQuery m)
+newRunQuery query tr Client{ready, observe, step, switch} =
+    do
+        UnliftIO unlift <- askUnliftIO
+        pure $ RunQuery $ \request -> do
+            traceWith tr $ MsgClientReq $ AnyQuery request
+            liftIO $ case request of
+                ReadyQ -> recoverAll retryPolicy
+                    $ \rt -> do
+                        unless (firstTry rt)
+                            $ unlift
+                            $ traceWith tr
+                            $ MsgClientRetry
+                            $ AnyQuery request
+                        query ready
+                ObserveQ -> unApiT <$> query observe
+                StepQ -> query step $> ()
+                SwitchQ -> unApiT <$> query switch
+
 -- | 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
+    :: (MonadUnliftIO m, HasSNetworkId n)
+    => SNetworkId n
+    -> 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
+    -> ContT () m (RunQuery m, RunApplicationQ m)
+withHttpClient networkId tracer httpPort = ContT $ \continue -> do
     let tr = traceWith tracer
     tr MsgClientStart
-    UnliftIO unlift <- askUnliftIO
     let url = BaseUrl Http "localhost" (fromIntegral httpPort) ""
     manager <-
         liftIO
@@ -145,21 +189,13 @@ withHttpClient tracer httpPort = ContT $ \continue -> do
         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
+    runQuery <- newRunQuery query tracer mkClient
+    runApplication <-
+        newApplicationQ
+            query
+            (MsgClienAppReq >$< tracer)
+            $ mkApplication networkId
+    continue (runQuery, runApplication)
 
     tr MsgClientDone