Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- add comments - remove redundant code - remove unused logging data types - introduce newtypes to avoid confusion
- Loading branch information
Showing
6 changed files
with
179 additions
and
241 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
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,106 +1,91 @@ | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE FlexibleContexts #-} | ||
| {-# LANGUAGE GADTs #-} | ||
| {-# LANGUAGE LambdaCase #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| {-# LANGUAGE TypeOperators #-} | ||
| {-# OPTIONS_GHC -fno-warn-deprecations #-} | ||
|
|
||
| module Cardano.Wallet.Mock where | ||
| module Cardano.Wallet.Mock | ||
| ( processWalletEffects | ||
| ) where | ||
|
|
||
| import Cardano.Wallet.Types (WalletId) | ||
| import Control.Lens (view) | ||
| import qualified Control.Monad.Except as MonadError | ||
| import Control.Monad.Freer | ||
| import Control.Monad.Freer.Error (Error, runError, throwError) | ||
| import Control.Monad.Freer.Extras.Log (LogMsg, logInfo) | ||
| import Control.Monad.IO.Class (MonadIO, liftIO) | ||
| import Data.Bifunctor (Bifunctor (..)) | ||
| import qualified Data.ByteString.Lazy as BSL | ||
| import qualified Data.ByteString.Lazy.Char8 as BSL8 | ||
| import qualified Data.Map as Map | ||
| import Data.Text.Encoding (encodeUtf8) | ||
| import Data.Text.Prettyprint.Doc (Pretty (..), (<+>)) | ||
| import Language.Plutus.Contract.Trace (allWallets) | ||
| import Ledger (Address, PubKey, TxOut (..), TxOutRef, TxOutTx (..), Value) | ||
| import Ledger.AddressMap (UtxoMap) | ||
| import qualified Ledger.AddressMap as AddressMap | ||
| import Plutus.PAB.Arbitrary () | ||
| import Servant (ServerError, err401, err404, err500, errBody) | ||
| import Test.QuickCheck (arbitrary, generate) | ||
| import Wallet.API (WalletAPIError (InsufficientFunds, OtherError, PrivateKeyNotFound)) | ||
| import Wallet.Effects (ChainIndexEffect) | ||
| import qualified Wallet.Effects as W | ||
| import Wallet.Emulator.Wallet (Wallet (Wallet)) | ||
| import qualified Wallet.Emulator.Wallet as EM | ||
| import Control.Monad.Freer.Error | ||
| import Control.Monad.Freer.State (runState) | ||
| import Control.Monad.IO.Class (MonadIO, liftIO) | ||
| import qualified Data.ByteString.Lazy as BSL | ||
| import qualified Data.ByteString.Lazy.Char8 as BSL8 | ||
| import qualified Data.ByteString.Lazy.Char8 as Char8 | ||
| import Data.Function ((&)) | ||
| import Data.Text.Encoding (encodeUtf8) | ||
| import Servant (ServerError (..), err400, err401, err404) | ||
| import Servant.Client (ClientEnv) | ||
|
|
||
| data MockWalletMsg = | ||
| CallWallets | ||
| | CallValueAt | ||
| | ValueAtResponse Address Value | ||
| | CallSelectCoin WalletId Value | ||
| | SelectCoinResult (Either WalletAPIError ([(TxOutRef, Value)], Value)) | ||
| | CallAllocateAddress | ||
| import Cardano.BM.Data.Trace (Trace) | ||
| import qualified Cardano.ChainIndex.Client as ChainIndexClient | ||
| import qualified Cardano.Node.Client as NodeClient | ||
| import Cardano.Wallet.Types (WalletEffects, WalletMsg (..)) | ||
| import Control.Concurrent (MVar) | ||
| import Control.Concurrent.MVar (putMVar, takeMVar) | ||
| import Control.Monad.Error (MonadError) | ||
| import Plutus.PAB.Arbitrary () | ||
| import Plutus.PAB.Monitoring (convertLog, handleLogMsgTrace) | ||
| import Servant.Server (err500) | ||
| import Wallet.API (WalletAPIError (InsufficientFunds, OtherError, PrivateKeyNotFound)) | ||
| import Wallet.Emulator.Wallet (WalletState) | ||
| import qualified Wallet.Emulator.Wallet as Wallet | ||
|
|
||
| instance Pretty MockWalletMsg where | ||
| pretty = \case | ||
| CallWallets -> "wallets" | ||
| CallValueAt -> "valueAt" | ||
| ValueAtResponse addr vl -> "valueAt" <+> pretty addr <> ":" <+> pretty vl | ||
| CallSelectCoin walletID target -> "selectCoin" <+> pretty walletID <+> pretty target | ||
| SelectCoinResult result -> "selectCoin result:" <+> pretty result | ||
| CallAllocateAddress -> "allocateAddress" | ||
|
|
||
| wallets :: (Member (LogMsg MockWalletMsg) effs) => Eff effs [Wallet] | ||
| wallets = do | ||
| logInfo CallWallets | ||
| pure allWallets | ||
| -- | Process wallet effects. Retain state and yield HTTP400 on error | ||
| -- or set new state on success. | ||
| processWalletEffects :: | ||
| (MonadIO m, MonadError ServerError m) | ||
| => Trace IO WalletMsg -- ^ trace for logging | ||
| -> ClientEnv -- ^ node client | ||
| -> ClientEnv -- ^ chain index client | ||
| -> MVar WalletState -- ^ wallet state | ||
| -> Eff (WalletEffects IO) a -- ^ wallet effect | ||
| -> m a | ||
| processWalletEffects trace nodeClientEnv chainIndexEnv mVarState action = do | ||
| oldState <- liftIO $ takeMVar mVarState | ||
| result <- liftIO $ runWalletEffects trace nodeClientEnv chainIndexEnv oldState action | ||
| case result of | ||
| Left e -> do | ||
| liftIO $ putMVar mVarState oldState | ||
| MonadError.throwError $ err400 { errBody = Char8.pack (show e) } | ||
| Right (result_, newState) -> do | ||
| liftIO $ putMVar mVarState newState | ||
| pure result_ | ||
|
|
||
| -- | Interpret wallet effects | ||
| runWalletEffects :: | ||
| MonadIO m | ||
| => Trace m WalletMsg -- ^ trace for logging | ||
| -> ClientEnv -- ^ node client | ||
| -> ClientEnv -- ^ chain index client | ||
| -> WalletState -- ^ current state | ||
| -> Eff (WalletEffects m) a -- ^ wallet effect | ||
| -> m (Either ServerError (a, WalletState)) | ||
| runWalletEffects trace nodeClientEnv chainIndexEnv walletState action = | ||
| Wallet.handleWallet action | ||
| & interpret (NodeClient.handleNodeClientClient nodeClientEnv) | ||
| & interpret (ChainIndexClient.handleChainIndexClient chainIndexEnv) | ||
| & runState walletState | ||
| & handleLogMsgTrace (toWalletMsg trace) | ||
| & handleWalletApiErrors | ||
| & handleClientErrors | ||
| & runError | ||
| & runM | ||
| where | ||
| handleWalletApiErrors = flip handleError (throwError . fromWalletAPIError) | ||
| handleClientErrors = flip handleError (\e -> throwError $ err500 { errBody = Char8.pack (show e) }) | ||
| toWalletMsg = convertLog ChainClientMsg | ||
|
|
||
| -- | Convert Wallet errors to Servant error responses | ||
| fromWalletAPIError :: WalletAPIError -> ServerError | ||
| fromWalletAPIError (InsufficientFunds text) = | ||
| err401 {errBody = BSL.fromStrict $ encodeUtf8 text} | ||
| fromWalletAPIError err@(PrivateKeyNotFound _) = | ||
| err404 {errBody = BSL8.pack $ show err} | ||
| fromWalletAPIError e@(PrivateKeyNotFound _) = | ||
| err404 {errBody = BSL8.pack $ show e} | ||
| fromWalletAPIError (OtherError text) = | ||
| err500 {errBody = BSL.fromStrict $ encodeUtf8 text} | ||
|
|
||
| valueAt :: | ||
| ( Member (LogMsg MockWalletMsg) effs | ||
| , Member ChainIndexEffect effs | ||
| ) | ||
| => Address | ||
| -> Eff effs Value | ||
| valueAt address = do | ||
| logInfo CallValueAt | ||
| value <- foldMap (txOutValue . txOutTxOut) . view (AddressMap.fundsAt address) <$> W.watchedAddresses | ||
| logInfo $ ValueAtResponse address value | ||
| pure value | ||
|
|
||
| selectCoin :: | ||
| ( Member (LogMsg MockWalletMsg) effs | ||
| , Member ChainIndexEffect effs | ||
| , Member (Error ServerError) effs | ||
| ) | ||
| => WalletId | ||
| -> Value | ||
| -> Eff effs ([(TxOutRef, Value)], Value) | ||
| selectCoin walletId target = do | ||
| logInfo $ CallSelectCoin walletId target | ||
| let address = EM.walletAddress (Wallet walletId) | ||
| utxos :: UtxoMap <- view (AddressMap.fundsAt address) <$> W.watchedAddresses | ||
| let funds :: [(TxOutRef, Value)] | ||
| funds = fmap (second (txOutValue . txOutTxOut)) . Map.toList $ utxos | ||
| result <- runM $ runError $ EM.selectCoin funds target | ||
| logInfo $ SelectCoinResult result | ||
| case result of | ||
| Right value -> pure value | ||
| Left err -> throwError $ fromWalletAPIError err | ||
|
|
||
| allocateAddress :: | ||
| ( LastMember m effs | ||
| , Member (LogMsg MockWalletMsg) effs | ||
| , MonadIO m | ||
| ) | ||
| => WalletId | ||
| -> Eff effs PubKey | ||
| allocateAddress _ = do | ||
| logInfo CallAllocateAddress | ||
| sendM $ liftIO $ generate arbitrary |
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
Oops, something went wrong.