-
Notifications
You must be signed in to change notification settings - Fork 463
/
Handlers.hs
208 lines (196 loc) · 9.51 KB
/
Handlers.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module Cardano.Wallet.Mock.Handlers
( processWalletEffects
, integer2ByteString32
, byteString2Integer
, newWallet
, distributeNewWalletFunds
) where
import Cardano.BM.Data.Trace (Trace)
import qualified Cardano.Node.Client as NodeClient
import qualified Cardano.Protocol.Socket.Mock.Client as MockClient
import Cardano.Wallet.Mock.Types (MultiWalletEffect (..), WalletEffects, WalletInfo (..),
WalletMsg (..), Wallets, fromWalletState)
import Control.Concurrent (MVar)
import Control.Concurrent.MVar (putMVar, takeMVar)
import Control.Lens (at, (?~))
import Control.Monad.Error (MonadError)
import qualified Control.Monad.Except as MonadError
import Control.Monad.Freer
import Control.Monad.Freer.Error
import Control.Monad.Freer.Extras
import Control.Monad.Freer.Reader (runReader)
import Control.Monad.Freer.State (State, evalState, get, put, runState)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Crypto.Random (getRandomBytes)
import Data.Bits (shiftL, shiftR)
import Data.ByteArray (ScrubbedBytes, unpack)
import qualified Data.ByteString as BS
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 qualified Data.Map as Map
import Data.Text.Encoding (encodeUtf8)
import Data.Text.Prettyprint.Doc (pretty)
import qualified Ledger.Ada as Ada
import Ledger.CardanoWallet (MockWallet)
import qualified Ledger.CardanoWallet as CW
import Ledger.Crypto (PubKeyHash)
import Ledger.Fee (FeeConfig)
import Ledger.TimeSlot (SlotConfig)
import Ledger.Tx (Tx)
import Plutus.ChainIndex (ChainIndexQueryEffect)
import qualified Plutus.ChainIndex.Client as ChainIndex
import Plutus.PAB.Arbitrary ()
import qualified Plutus.PAB.Monitoring.Monitoring as LM
import Servant (ServerError (..), err400, err401, err404)
import Servant.Client (ClientEnv)
import Servant.Server (err500)
import Wallet.API (WalletAPIError (..))
import qualified Wallet.API as WAPI
import Wallet.Effects (NodeClientEffect)
import Wallet.Emulator.LogMessages (TxBalanceMsg)
import qualified Wallet.Emulator.Wallet as Wallet
newtype Seed = Seed ScrubbedBytes
generateSeed :: (LastMember m effs, MonadIO m) => Eff effs Seed
generateSeed = do
(bytes :: ScrubbedBytes) <- sendM $ liftIO $ getRandomBytes 32
pure $ Seed bytes
{-# INLINE byteString2Integer #-}
-- |Helper function to convert bytestrings to integers
byteString2Integer :: BS.ByteString -> Integer
byteString2Integer = BS.foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0
{-# INLINE integer2ByteString32 #-}
-- |@i2bs bitLen i@ converts @i@ to a 'ByteString' of @bitLen@ bits (must be a multiple of 8).
integer2ByteString32 :: Integer -> BS.ByteString
integer2ByteString32 i = BS.unfoldr (\l' -> if l' < 0 then Nothing else Just (fromIntegral (i `shiftR` l'), l' - 8)) (31*8)
distributeNewWalletFunds :: forall effs. (Member WAPI.WalletEffect effs, Member (Error WalletAPIError) effs) => PubKeyHash -> Eff effs Tx
distributeNewWalletFunds = WAPI.payToPublicKeyHash WAPI.defaultSlotRange (Ada.adaValueOf 10000)
newWallet :: forall m effs. (LastMember m effs, MonadIO m) => Eff effs MockWallet
newWallet = do
Seed seed <- generateSeed
let secretKeyBytes = BS.pack . unpack $ seed
return $ CW.fromSeed secretKeyBytes
-- | Handle multiple wallets using existing @Wallet.handleWallet@ handler
handleMultiWallet :: forall m effs.
( Member NodeClientEffect effs
, Member ChainIndexQueryEffect effs
, Member (State Wallets) effs
, Member (Error WAPI.WalletAPIError) effs
, Member (LogMsg WalletMsg) effs
, LastMember m effs
, MonadIO m
)
=> FeeConfig
-> MultiWalletEffect ~> Eff effs
handleMultiWallet feeCfg = \case
MultiWallet wallet action -> do
wallets <- get @Wallets
case Map.lookup wallet wallets of
Just walletState -> do
(x, newState) <- runState walletState
$ action
& raiseEnd
& interpret (Wallet.handleWallet feeCfg)
& interpret (mapLog @TxBalanceMsg @WalletMsg Balancing)
put @Wallets (wallets & at wallet ?~ newState)
pure x
Nothing -> throwError $ WAPI.OtherError "Wallet not found"
CreateWallet -> do
wallets <- get @Wallets
mockWallet <- newWallet
let walletId = Wallet.Wallet $ Wallet.WalletId $ CW.mwWalletId mockWallet
wallets' = Map.insert walletId (Wallet.fromMockWallet mockWallet) wallets
pkh = CW.pubKeyHash mockWallet
put wallets'
-- For some reason this doesn't work with (Wallet 1)/privateKey1,
-- works just fine with (Wallet 2)/privateKey2
-- ¯\_(ツ)_/¯
let sourceWallet = Wallet.fromMockWallet (CW.knownWallet 2)
_ <- evalState sourceWallet $
interpret (mapLog @TxBalanceMsg @WalletMsg Balancing)
$ interpret (Wallet.handleWallet feeCfg)
$ distributeNewWalletFunds
$ pkh
return $ WalletInfo{wiWallet = walletId, wiPubKeyHash = pkh}
GetWalletInfo wllt -> do
wallets <- get @Wallets
return $ fmap fromWalletState $ Map.lookup (Wallet.Wallet wllt) wallets
-- | 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
-> MockClient.TxSendHandle -- ^ node client
-> NodeClient.ChainSyncHandle -- ^ node client
-> ClientEnv -- ^ chain index client
-> MVar Wallets -- ^ wallets state
-> FeeConfig
-> SlotConfig
-> Eff (WalletEffects IO) a -- ^ wallet effect
-> m a
processWalletEffects trace txSendHandle chainSyncHandle chainIndexEnv mVarState feeCfg slotCfg action = do
oldState <- liftIO $ takeMVar mVarState
result <- liftIO $ runWalletEffects trace
txSendHandle
chainSyncHandle
chainIndexEnv
oldState
feeCfg
slotCfg
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 ::
Trace IO WalletMsg -- ^ trace for logging
-> MockClient.TxSendHandle -- ^ node client
-> NodeClient.ChainSyncHandle -- ^ node client
-> ClientEnv -- ^ chain index client
-> Wallets -- ^ current state
-> FeeConfig
-> SlotConfig
-> Eff (WalletEffects IO) a -- ^ wallet effect
-> IO (Either ServerError (a, Wallets))
runWalletEffects trace txSendHandle chainSyncHandle chainIndexEnv wallets feeCfg slotCfg action =
reinterpret (handleMultiWallet feeCfg) action
& interpret (LM.handleLogMsgTrace trace)
& reinterpret2 (NodeClient.handleNodeClientClient slotCfg)
& runReader chainSyncHandle
& runReader txSendHandle
& reinterpret ChainIndex.handleChainIndexClient
& runReader chainIndexEnv
& runState wallets
& interpret (LM.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 = LM.convertLog ChainClientMsg
-- | Convert Wallet errors to Servant error responses
fromWalletAPIError :: WalletAPIError -> ServerError
fromWalletAPIError (InsufficientFunds text) =
err401 {errBody = BSL.fromStrict $ encodeUtf8 text}
fromWalletAPIError e@(PrivateKeyNotFound _) =
err404 {errBody = BSL8.pack $ show e}
fromWalletAPIError e@(ValidationError _) =
err500 {errBody = BSL8.pack $ show $ pretty e}
fromWalletAPIError (OtherError text) =
err500 {errBody = BSL.fromStrict $ encodeUtf8 text}