{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module Cardano.Wallet.Mock.Server ( main ) where import Cardano.BM.Data.Trace (Trace) import Cardano.ChainIndex.Types (ChainIndexUrl (ChainIndexUrl)) import Cardano.Node.Emulator.Internal.Node.Params (Params (..)) import Cardano.Node.Types (ChainSyncHandle) import Cardano.Protocol.Socket.Mock.Client qualified as MockClient import Cardano.Wallet.Mock.API (API) import Cardano.Wallet.Mock.Handlers (processWalletEffects) import Cardano.Wallet.Mock.Types (Port (Port), WalletInfo (wiAddresses, wiPaymentPubKeyHash), WalletMsg (StartingWallet), Wallets, createWallet, getWalletInfo, multiWallet) import Cardano.Wallet.Types (LocalWalletSettings (LocalWalletSettings, baseUrl), WalletUrl (WalletUrl)) import Control.Concurrent.Availability (Availability, available) import Control.Concurrent.MVar (MVar, newMVar) import Control.Monad ((>=>)) import Control.Monad.Freer.Error (throwError) import Control.Monad.Freer.Extras.Log (logInfo) import Control.Monad.IO.Class (liftIO) import Data.Coerce (coerce) import Data.Function ((&)) import Data.Map.Strict qualified as Map import Data.Proxy (Proxy (Proxy)) import Ledger.CardanoWallet qualified as CW import Network.HTTP.Client (defaultManagerSettings, newManager) import Network.Wai.Handler.Warp qualified as Warp import Plutus.PAB.Arbitrary () import Plutus.PAB.Monitoring.Monitoring qualified as LM import Plutus.Script.Utils.Ada qualified as Ada import Servant (Application, NoContent (NoContent), err404, hoistServer, serve, (:<|>) ((:<|>))) import Servant.Client (BaseUrl (baseUrlPort), ClientEnv, mkClientEnv) import Wallet.Effects (balanceTx, submitTxn, totalFunds, walletAddSignature) import Wallet.Emulator.Wallet (Wallet (Wallet), WalletId) import Wallet.Emulator.Wallet qualified as Wallet app :: Trace IO WalletMsg -> MockClient.TxSendHandle -> ChainSyncHandle -> ClientEnv -> MVar Wallets -> Params -> Application app :: Trace IO WalletMsg -> TxSendHandle -> ChainSyncHandle -> ClientEnv -> MVar Wallets -> Params -> Application app Trace IO WalletMsg trace TxSendHandle txSendHandle ChainSyncHandle chainSyncHandle ClientEnv chainIndexEnv MVar Wallets mVarState Params params = Proxy (API WalletId) -> Server (API WalletId) -> Application forall api. HasServer api '[] => Proxy api -> Server api -> Application serve (Proxy (API WalletId) forall k (t :: k). Proxy t Proxy @(API WalletId)) (Server (API WalletId) -> Application) -> Server (API WalletId) -> Application forall a b. (a -> b) -> a -> b $ Proxy (API WalletId) -> (forall x. Eff (WalletEffects IO) x -> Handler x) -> ServerT (API WalletId) (Eff (WalletEffects IO)) -> Server (API WalletId) forall api (m :: * -> *) (n :: * -> *). HasServer api '[] => Proxy api -> (forall x. m x -> n x) -> ServerT api m -> ServerT api n hoistServer (Proxy (API WalletId) forall k (t :: k). Proxy t Proxy @(API WalletId)) (Trace IO WalletMsg -> TxSendHandle -> ChainSyncHandle -> ClientEnv -> MVar Wallets -> Params -> Eff (WalletEffects IO) x -> Handler x forall (m :: * -> *) a. (MonadIO m, MonadError ServerError m) => Trace IO WalletMsg -> TxSendHandle -> ChainSyncHandle -> ClientEnv -> MVar Wallets -> Params -> Eff (WalletEffects IO) a -> m a processWalletEffects Trace IO WalletMsg trace TxSendHandle txSendHandle ChainSyncHandle chainSyncHandle ClientEnv chainIndexEnv MVar Wallets mVarState Params params) (ServerT (API WalletId) (Eff (WalletEffects IO)) -> Server (API WalletId)) -> ServerT (API WalletId) (Eff (WalletEffects IO)) -> Server (API WalletId) forall a b. (a -> b) -> a -> b $ (\Maybe Integer funds -> Maybe Ada -> Eff (WalletEffects IO) WalletInfo forall (effs :: [* -> *]). Member MultiWalletEffect effs => Maybe Ada -> Eff effs WalletInfo createWallet (Integer -> Ada Ada.lovelaceOf (Integer -> Ada) -> Maybe Integer -> Maybe Ada forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe Integer funds)) (Maybe Integer -> Eff (WalletEffects IO) WalletInfo) -> ((WalletId -> CardanoTx -> Eff (WalletEffects IO) NoContent) :<|> ((WalletId -> Eff (WalletEffects IO) PaymentPubKeyHash) :<|> ((WalletId -> Eff (WalletEffects IO) (NonEmpty CardanoAddress)) :<|> ((WalletId -> UnbalancedTx -> Eff (WalletEffects IO) (Either WalletAPIError CardanoTx)) :<|> ((WalletId -> Eff (WalletEffects IO) Value) :<|> (WalletId -> CardanoTx -> Eff (WalletEffects IO) CardanoTx)))))) -> (Maybe Integer -> Eff (WalletEffects IO) WalletInfo) :<|> ((WalletId -> CardanoTx -> Eff (WalletEffects IO) NoContent) :<|> ((WalletId -> Eff (WalletEffects IO) PaymentPubKeyHash) :<|> ((WalletId -> Eff (WalletEffects IO) (NonEmpty CardanoAddress)) :<|> ((WalletId -> UnbalancedTx -> Eff (WalletEffects IO) (Either WalletAPIError CardanoTx)) :<|> ((WalletId -> Eff (WalletEffects IO) Value) :<|> (WalletId -> CardanoTx -> Eff (WalletEffects IO) CardanoTx)))))) forall a b. a -> b -> a :<|> b :<|> (\WalletId w CardanoTx tx -> Wallet -> Eff '[WalletEffect] () -> Eff (WalletEffects IO) () forall a (effs :: [* -> *]). Member MultiWalletEffect effs => Wallet -> Eff '[WalletEffect] a -> Eff effs a multiWallet (Maybe String -> WalletId -> Wallet Wallet Maybe String forall a. Maybe a Nothing WalletId w) (CardanoTx -> Eff '[WalletEffect] () forall (effs :: [* -> *]). Member WalletEffect effs => CardanoTx -> Eff effs () submitTxn CardanoTx tx) Eff (WalletEffects IO) () -> (() -> Eff (WalletEffects IO) NoContent) -> Eff (WalletEffects IO) NoContent forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Eff (WalletEffects IO) NoContent -> () -> Eff (WalletEffects IO) NoContent forall a b. a -> b -> a const (NoContent -> Eff (WalletEffects IO) NoContent forall (f :: * -> *) a. Applicative f => a -> f a pure NoContent NoContent)) (WalletId -> CardanoTx -> Eff (WalletEffects IO) NoContent) -> ((WalletId -> Eff (WalletEffects IO) PaymentPubKeyHash) :<|> ((WalletId -> Eff (WalletEffects IO) (NonEmpty CardanoAddress)) :<|> ((WalletId -> UnbalancedTx -> Eff (WalletEffects IO) (Either WalletAPIError CardanoTx)) :<|> ((WalletId -> Eff (WalletEffects IO) Value) :<|> (WalletId -> CardanoTx -> Eff (WalletEffects IO) CardanoTx))))) -> (WalletId -> CardanoTx -> Eff (WalletEffects IO) NoContent) :<|> ((WalletId -> Eff (WalletEffects IO) PaymentPubKeyHash) :<|> ((WalletId -> Eff (WalletEffects IO) (NonEmpty CardanoAddress)) :<|> ((WalletId -> UnbalancedTx -> Eff (WalletEffects IO) (Either WalletAPIError CardanoTx)) :<|> ((WalletId -> Eff (WalletEffects IO) Value) :<|> (WalletId -> CardanoTx -> Eff (WalletEffects IO) CardanoTx))))) forall a b. a -> b -> a :<|> b :<|> (WalletId -> Eff (WalletEffects IO) (Maybe WalletInfo) forall (effs :: [* -> *]). Member MultiWalletEffect effs => WalletId -> Eff effs (Maybe WalletInfo) getWalletInfo (WalletId -> Eff (WalletEffects IO) (Maybe WalletInfo)) -> (Maybe WalletInfo -> Eff (WalletEffects IO) PaymentPubKeyHash) -> WalletId -> Eff (WalletEffects IO) PaymentPubKeyHash forall (m :: * -> *) a b c. Monad m => (a -> m b) -> (b -> m c) -> a -> m c >=> Eff (WalletEffects IO) PaymentPubKeyHash -> (WalletInfo -> Eff (WalletEffects IO) PaymentPubKeyHash) -> Maybe WalletInfo -> Eff (WalletEffects IO) PaymentPubKeyHash forall b a. b -> (a -> b) -> Maybe a -> b maybe (ServerError -> Eff (WalletEffects IO) PaymentPubKeyHash forall e (effs :: [* -> *]) a. Member (Error e) effs => e -> Eff effs a throwError ServerError err404) (PaymentPubKeyHash -> Eff (WalletEffects IO) PaymentPubKeyHash forall (f :: * -> *) a. Applicative f => a -> f a pure (PaymentPubKeyHash -> Eff (WalletEffects IO) PaymentPubKeyHash) -> (WalletInfo -> PaymentPubKeyHash) -> WalletInfo -> Eff (WalletEffects IO) PaymentPubKeyHash forall b c a. (b -> c) -> (a -> b) -> a -> c . WalletInfo -> PaymentPubKeyHash wiPaymentPubKeyHash) ) (WalletId -> Eff (WalletEffects IO) PaymentPubKeyHash) -> ((WalletId -> Eff (WalletEffects IO) (NonEmpty CardanoAddress)) :<|> ((WalletId -> UnbalancedTx -> Eff (WalletEffects IO) (Either WalletAPIError CardanoTx)) :<|> ((WalletId -> Eff (WalletEffects IO) Value) :<|> (WalletId -> CardanoTx -> Eff (WalletEffects IO) CardanoTx)))) -> (WalletId -> Eff (WalletEffects IO) PaymentPubKeyHash) :<|> ((WalletId -> Eff (WalletEffects IO) (NonEmpty CardanoAddress)) :<|> ((WalletId -> UnbalancedTx -> Eff (WalletEffects IO) (Either WalletAPIError CardanoTx)) :<|> ((WalletId -> Eff (WalletEffects IO) Value) :<|> (WalletId -> CardanoTx -> Eff (WalletEffects IO) CardanoTx)))) forall a b. a -> b -> a :<|> b :<|> (WalletId -> Eff (WalletEffects IO) (Maybe WalletInfo) forall (effs :: [* -> *]). Member MultiWalletEffect effs => WalletId -> Eff effs (Maybe WalletInfo) getWalletInfo (WalletId -> Eff (WalletEffects IO) (Maybe WalletInfo)) -> (Maybe WalletInfo -> Eff (WalletEffects IO) (NonEmpty CardanoAddress)) -> WalletId -> Eff (WalletEffects IO) (NonEmpty CardanoAddress) forall (m :: * -> *) a b c. Monad m => (a -> m b) -> (b -> m c) -> a -> m c >=> Eff (WalletEffects IO) (NonEmpty CardanoAddress) -> (WalletInfo -> Eff (WalletEffects IO) (NonEmpty CardanoAddress)) -> Maybe WalletInfo -> Eff (WalletEffects IO) (NonEmpty CardanoAddress) forall b a. b -> (a -> b) -> Maybe a -> b maybe (ServerError -> Eff (WalletEffects IO) (NonEmpty CardanoAddress) forall e (effs :: [* -> *]) a. Member (Error e) effs => e -> Eff effs a throwError ServerError err404) (NonEmpty CardanoAddress -> Eff (WalletEffects IO) (NonEmpty CardanoAddress) forall (f :: * -> *) a. Applicative f => a -> f a pure (NonEmpty CardanoAddress -> Eff (WalletEffects IO) (NonEmpty CardanoAddress)) -> (WalletInfo -> NonEmpty CardanoAddress) -> WalletInfo -> Eff (WalletEffects IO) (NonEmpty CardanoAddress) forall b c a. (b -> c) -> (a -> b) -> a -> c . WalletInfo -> NonEmpty CardanoAddress wiAddresses) ) (WalletId -> Eff (WalletEffects IO) (NonEmpty CardanoAddress)) -> ((WalletId -> UnbalancedTx -> Eff (WalletEffects IO) (Either WalletAPIError CardanoTx)) :<|> ((WalletId -> Eff (WalletEffects IO) Value) :<|> (WalletId -> CardanoTx -> Eff (WalletEffects IO) CardanoTx))) -> (WalletId -> Eff (WalletEffects IO) (NonEmpty CardanoAddress)) :<|> ((WalletId -> UnbalancedTx -> Eff (WalletEffects IO) (Either WalletAPIError CardanoTx)) :<|> ((WalletId -> Eff (WalletEffects IO) Value) :<|> (WalletId -> CardanoTx -> Eff (WalletEffects IO) CardanoTx))) forall a b. a -> b -> a :<|> b :<|> (\WalletId w -> Wallet -> Eff '[WalletEffect] (Either WalletAPIError CardanoTx) -> Eff (WalletEffects IO) (Either WalletAPIError CardanoTx) forall a (effs :: [* -> *]). Member MultiWalletEffect effs => Wallet -> Eff '[WalletEffect] a -> Eff effs a multiWallet (Maybe String -> WalletId -> Wallet Wallet Maybe String forall a. Maybe a Nothing WalletId w) (Eff '[WalletEffect] (Either WalletAPIError CardanoTx) -> Eff (WalletEffects IO) (Either WalletAPIError CardanoTx)) -> (UnbalancedTx -> Eff '[WalletEffect] (Either WalletAPIError CardanoTx)) -> UnbalancedTx -> Eff (WalletEffects IO) (Either WalletAPIError CardanoTx) forall b c a. (b -> c) -> (a -> b) -> a -> c . UnbalancedTx -> Eff '[WalletEffect] (Either WalletAPIError CardanoTx) forall (effs :: [* -> *]). Member WalletEffect effs => UnbalancedTx -> Eff effs (Either WalletAPIError CardanoTx) balanceTx) (WalletId -> UnbalancedTx -> Eff (WalletEffects IO) (Either WalletAPIError CardanoTx)) -> ((WalletId -> Eff (WalletEffects IO) Value) :<|> (WalletId -> CardanoTx -> Eff (WalletEffects IO) CardanoTx)) -> (WalletId -> UnbalancedTx -> Eff (WalletEffects IO) (Either WalletAPIError CardanoTx)) :<|> ((WalletId -> Eff (WalletEffects IO) Value) :<|> (WalletId -> CardanoTx -> Eff (WalletEffects IO) CardanoTx)) forall a b. a -> b -> a :<|> b :<|> (\WalletId w -> Wallet -> Eff '[WalletEffect] Value -> Eff (WalletEffects IO) Value forall a (effs :: [* -> *]). Member MultiWalletEffect effs => Wallet -> Eff '[WalletEffect] a -> Eff effs a multiWallet (Maybe String -> WalletId -> Wallet Wallet Maybe String forall a. Maybe a Nothing WalletId w) Eff '[WalletEffect] Value forall (effs :: [* -> *]). Member WalletEffect effs => Eff effs Value totalFunds) (WalletId -> Eff (WalletEffects IO) Value) -> (WalletId -> CardanoTx -> Eff (WalletEffects IO) CardanoTx) -> (WalletId -> Eff (WalletEffects IO) Value) :<|> (WalletId -> CardanoTx -> Eff (WalletEffects IO) CardanoTx) forall a b. a -> b -> a :<|> b :<|> (\WalletId w CardanoTx tx -> Wallet -> Eff '[WalletEffect] CardanoTx -> Eff (WalletEffects IO) CardanoTx forall a (effs :: [* -> *]). Member MultiWalletEffect effs => Wallet -> Eff '[WalletEffect] a -> Eff effs a multiWallet (Maybe String -> WalletId -> Wallet Wallet Maybe String forall a. Maybe a Nothing WalletId w) (CardanoTx -> Eff '[WalletEffect] CardanoTx forall (effs :: [* -> *]). Member WalletEffect effs => CardanoTx -> Eff effs CardanoTx walletAddSignature CardanoTx tx)) main :: Trace IO WalletMsg -> LocalWalletSettings -> FilePath -> Params -> ChainIndexUrl -> Availability -> IO () main :: Trace IO WalletMsg -> LocalWalletSettings -> String -> Params -> ChainIndexUrl -> Availability -> IO () main Trace IO WalletMsg trace LocalWalletSettings { WalletUrl baseUrl :: WalletUrl baseUrl :: LocalWalletSettings -> WalletUrl baseUrl } String serverSocket Params params (ChainIndexUrl BaseUrl chainUrl) Availability availability = Trace IO WalletMsg -> Eff '[LogMsg WalletMsg, IO] ~> IO forall (m :: * -> *) l. MonadIO m => Trace m l -> Eff '[LogMsg l, m] ~> m LM.runLogEffects Trace IO WalletMsg trace (Eff '[LogMsg WalletMsg, IO] () -> IO ()) -> Eff '[LogMsg WalletMsg, IO] () -> IO () forall a b. (a -> b) -> a -> b $ do ClientEnv chainIndexEnv <- BaseUrl -> ManagerSettings -> Eff '[LogMsg WalletMsg, IO] ClientEnv forall (m :: * -> *). MonadIO m => BaseUrl -> ManagerSettings -> m ClientEnv buildEnv BaseUrl chainUrl ManagerSettings defaultManagerSettings let knownWallets :: Wallets knownWallets = [(WalletId, WalletState)] -> Wallets forall k a. Ord k => [(k, a)] -> Map k a Map.fromList ([(WalletId, WalletState)] -> Wallets) -> [(WalletId, WalletState)] -> Wallets forall a b. (a -> b) -> a -> b $ [WalletId] -> [WalletState] -> [(WalletId, WalletState)] forall a b. [a] -> [b] -> [(a, b)] zip (Wallet -> WalletId Wallet.getWalletId (Wallet -> WalletId) -> [Wallet] -> [WalletId] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Wallet] Wallet.knownWallets) (MockWallet -> WalletState Wallet.fromMockWallet (MockWallet -> WalletState) -> [MockWallet] -> [WalletState] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [MockWallet] CW.knownMockWallets) MVar Wallets mVarState <- IO (MVar Wallets) -> Eff '[LogMsg WalletMsg, IO] (MVar Wallets) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (MVar Wallets) -> Eff '[LogMsg WalletMsg, IO] (MVar Wallets)) -> IO (MVar Wallets) -> Eff '[LogMsg WalletMsg, IO] (MVar Wallets) forall a b. (a -> b) -> a -> b $ Wallets -> IO (MVar Wallets) forall a. a -> IO (MVar a) newMVar Wallets knownWallets TxSendHandle txSendHandle <- IO TxSendHandle -> Eff '[LogMsg WalletMsg, IO] TxSendHandle forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO TxSendHandle -> Eff '[LogMsg WalletMsg, IO] TxSendHandle) -> IO TxSendHandle -> Eff '[LogMsg WalletMsg, IO] TxSendHandle forall a b. (a -> b) -> a -> b $ String -> NetworkId -> IO TxSendHandle MockClient.runTxSender String serverSocket (Params -> NetworkId pNetworkId Params params) ChainSyncHandle chainSyncHandle <- ChainSyncHandle Block -> ChainSyncHandle forall a b. a -> Either a b Left (ChainSyncHandle Block -> ChainSyncHandle) -> Eff '[LogMsg WalletMsg, IO] (ChainSyncHandle Block) -> Eff '[LogMsg WalletMsg, IO] ChainSyncHandle forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (IO (ChainSyncHandle Block) -> Eff '[LogMsg WalletMsg, IO] (ChainSyncHandle Block) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (ChainSyncHandle Block) -> Eff '[LogMsg WalletMsg, IO] (ChainSyncHandle Block)) -> IO (ChainSyncHandle Block) -> Eff '[LogMsg WalletMsg, IO] (ChainSyncHandle Block) forall a b. (a -> b) -> a -> b $ String -> SlotConfig -> IO (ChainSyncHandle Block) MockClient.runChainSync' String serverSocket (SlotConfig -> IO (ChainSyncHandle Block)) -> SlotConfig -> IO (ChainSyncHandle Block) forall a b. (a -> b) -> a -> b $ Params -> SlotConfig pSlotConfig Params params) WalletMsg -> Eff '[LogMsg WalletMsg, IO] () forall a (effs :: [* -> *]). Member (LogMsg a) effs => a -> Eff effs () logInfo (WalletMsg -> Eff '[LogMsg WalletMsg, IO] ()) -> WalletMsg -> Eff '[LogMsg WalletMsg, IO] () forall a b. (a -> b) -> a -> b $ Port -> WalletMsg StartingWallet (Int -> Port Port Int servicePort) IO () -> Eff '[LogMsg WalletMsg, IO] () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> Eff '[LogMsg WalletMsg, IO] ()) -> IO () -> Eff '[LogMsg WalletMsg, IO] () forall a b. (a -> b) -> a -> b $ Settings -> Application -> IO () Warp.runSettings Settings warpSettings (Application -> IO ()) -> Application -> IO () forall a b. (a -> b) -> a -> b $ Trace IO WalletMsg -> TxSendHandle -> ChainSyncHandle -> ClientEnv -> MVar Wallets -> Params -> Application app Trace IO WalletMsg trace TxSendHandle txSendHandle ChainSyncHandle chainSyncHandle ClientEnv chainIndexEnv MVar Wallets mVarState Params params where servicePort :: Int servicePort = BaseUrl -> Int baseUrlPort (WalletUrl -> BaseUrl coerce WalletUrl baseUrl) warpSettings :: Settings warpSettings = Settings Warp.defaultSettings Settings -> (Settings -> Settings) -> Settings forall a b. a -> (a -> b) -> b & Int -> Settings -> Settings Warp.setPort Int servicePort Settings -> (Settings -> Settings) -> Settings forall a b. a -> (a -> b) -> b & IO () -> Settings -> Settings Warp.setBeforeMainLoop (Availability -> IO () forall (m :: * -> *). MonadIO m => Availability -> m () available Availability availability) buildEnv :: BaseUrl -> ManagerSettings -> m ClientEnv buildEnv BaseUrl url ManagerSettings settings = IO ClientEnv -> m ClientEnv forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO ClientEnv -> m ClientEnv) -> IO ClientEnv -> m ClientEnv forall a b. (a -> b) -> a -> b $ ManagerSettings -> IO Manager newManager ManagerSettings settings IO Manager -> (Manager -> IO ClientEnv) -> IO ClientEnv forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \Manager mgr -> ClientEnv -> IO ClientEnv forall (f :: * -> *) a. Applicative f => a -> f a pure (ClientEnv -> IO ClientEnv) -> ClientEnv -> IO ClientEnv forall a b. (a -> b) -> a -> b $ Manager -> BaseUrl -> ClientEnv mkClientEnv Manager mgr BaseUrl url