-
Notifications
You must be signed in to change notification settings - Fork 211
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Add send faucet end-point to local-cluster http service
- Loading branch information
Showing
13 changed files
with
494 additions
and
79 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
27 changes: 27 additions & 0 deletions
27
lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Monitoring/Http/Application/API.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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 |
95 changes: 95 additions & 0 deletions
95
lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Monitoring/Http/Application/Client.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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) $> () |
103 changes: 103 additions & 0 deletions
103
lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Monitoring/Http/Application/Server.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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"} | ||
} |
Oops, something went wrong.