-
Notifications
You must be signed in to change notification settings - Fork 463
/
Handlers.hs
188 lines (181 loc) · 8.98 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
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-| Handlers for the 'ChainIndexQueryEffect' and the 'ChainIndexControlEffect'
in the emulator
-}
module Plutus.ChainIndex.Emulator.Handlers(
handleQuery
, handleControl
, ChainIndexEmulatorState(..)
, diskState
, utxoIndex
) where
import Control.Lens (at, ix, makeLenses, over, preview, set, to, view, (&))
import Control.Monad.Freer (Eff, Member, type (~>))
import Control.Monad.Freer.Error (Error, throwError)
import Control.Monad.Freer.Extras.Log (LogMsg, logDebug, logError, logWarn)
import Control.Monad.Freer.State (State, get, gets, modify, put)
import Data.Default (Default (..))
import Data.FingerTree (Measured (..))
import Data.Maybe (catMaybes, fromMaybe)
import Data.Semigroup.Generic (GenericSemigroupMonoid (..))
import qualified Data.Set as Set
import GHC.Generics (Generic)
import Plutus.ChainIndex.ChainIndexError (ChainIndexError (..))
import Plutus.ChainIndex.ChainIndexLog (ChainIndexLog (..))
import Ledger (Address (addressCredential),
ChainIndexTxOut(..),
MintingPolicy (MintingPolicy),
MintingPolicyHash (MintingPolicyHash),
StakeValidator (StakeValidator),
StakeValidatorHash (StakeValidatorHash), TxId,
TxOut (txOutAddress), TxOutRef (..), Validator (Validator),
ValidatorHash (ValidatorHash), txOutDatumHash, txOutValue)
import Ledger.Scripts (ScriptHash (ScriptHash))
import Ledger.Tx (ChainIndexTxOut (ScriptChainIndexTxOut))
import Plutus.ChainIndex.Effects (ChainIndexControlEffect (..), ChainIndexQueryEffect (..))
import Plutus.ChainIndex.Emulator.DiskState (DiskState, addressMap, dataMap, diagnostics, redeemerMap,
scriptMap, txMap)
import qualified Plutus.ChainIndex.Emulator.DiskState as DiskState
import Plutus.ChainIndex.Tx (ChainIndexTx, _ValidTx, citxOutputs)
import Plutus.ChainIndex.Types (Tip (..), pageOf)
import Plutus.ChainIndex.UtxoState (InsertUtxoSuccess (..), RollbackResult (..), TxUtxoBalance,
UtxoIndex, isUnspentOutput, tip)
import qualified Plutus.ChainIndex.UtxoState as UtxoState
import Plutus.V1.Ledger.Api (Credential (PubKeyCredential, ScriptCredential))
data ChainIndexEmulatorState =
ChainIndexEmulatorState
{ _diskState :: DiskState
, _utxoIndex :: UtxoIndex TxUtxoBalance
}
deriving stock (Eq, Show, Generic)
deriving (Semigroup, Monoid) via (GenericSemigroupMonoid ChainIndexEmulatorState)
makeLenses ''ChainIndexEmulatorState
-- | Get the 'ChainIndexTx' for a transaction ID
getTxFromTxId ::
forall effs.
(Member (State ChainIndexEmulatorState) effs
, Member (LogMsg ChainIndexLog) effs
) => TxId
-> Eff effs (Maybe ChainIndexTx)
getTxFromTxId i = do
result <- gets (view $ diskState . txMap . at i)
case result of
Nothing -> logWarn (TxNotFound i) >> pure Nothing
_ -> pure result
-- | Get the 'ChainIndexTxOut' for a 'TxOutRef'.
getTxOutFromRef ::
forall effs.
( Member (State ChainIndexEmulatorState) effs
, Member (LogMsg ChainIndexLog) effs
)
=> TxOutRef
-> Eff effs (Maybe ChainIndexTxOut)
getTxOutFromRef ref@TxOutRef{txOutRefId, txOutRefIdx} = do
ds <- gets (view diskState)
-- Find the output in the tx matching the output ref
case preview (txMap . ix txOutRefId . citxOutputs . _ValidTx . ix (fromIntegral txOutRefIdx)) ds of
Nothing -> logWarn (TxOutNotFound ref) >> pure Nothing
Just txout -> do
-- The output might come from a public key address or a script address.
-- We need to handle them differently.
case addressCredential $ txOutAddress txout of
PubKeyCredential _ ->
pure $ Just $ PublicKeyChainIndexTxOut (txOutAddress txout) (txOutValue txout)
ScriptCredential vh@(ValidatorHash h) -> do
case txOutDatumHash txout of
Nothing -> do
-- If the txout comes from a script address, the Datum should not be Nothing
logWarn $ NoDatumScriptAddr txout
pure Nothing
Just dh -> do
let v = maybe (Left vh) (Right . Validator) $ preview (scriptMap . ix (ScriptHash h)) ds
let d = maybe (Left dh) Right $ preview (dataMap . ix dh) ds
pure $ Just $ ScriptChainIndexTxOut (txOutAddress txout) v d (txOutValue txout)
handleQuery ::
forall effs.
( Member (State ChainIndexEmulatorState) effs
, Member (Error ChainIndexError) effs
, Member (LogMsg ChainIndexLog) effs
) => ChainIndexQueryEffect
~> Eff effs
handleQuery = \case
DatumFromHash h -> gets (view $ diskState . dataMap . at h)
ValidatorFromHash (ValidatorHash h) -> do
gets (fmap (fmap Validator) . view $ diskState . scriptMap . at (ScriptHash h))
MintingPolicyFromHash (MintingPolicyHash h) ->
gets (fmap (fmap MintingPolicy) . view $ diskState . scriptMap . at (ScriptHash h))
StakeValidatorFromHash (StakeValidatorHash h) ->
gets (fmap (fmap StakeValidator) . view $ diskState . scriptMap . at (ScriptHash h))
TxOutFromRef ref -> getTxOutFromRef ref
RedeemerFromHash h -> gets (view $ diskState . redeemerMap . at h)
TxFromTxId i -> getTxFromTxId i
UtxoSetMembership r -> do
utxoState <- gets (measure . view utxoIndex)
case tip utxoState of
TipAtGenesis -> throwError QueryFailedNoTip
tp -> pure (tp, isUnspentOutput r utxoState)
UtxoSetAtAddress cred -> do
state <- get
let outRefs = view (diskState . addressMap . at cred) state
utxoState = view (utxoIndex . to measure) state
page = pageOf def $ Set.filter (\r -> isUnspentOutput r utxoState) (fromMaybe mempty outRefs)
case tip utxoState of
TipAtGenesis -> do
logWarn TipIsGenesis
pure (TipAtGenesis, pageOf def Set.empty)
tp -> pure (tp, page)
GetTip ->
gets (tip . measure . view utxoIndex)
handleControl ::
forall effs.
( Member (State ChainIndexEmulatorState) effs
, Member (Error ChainIndexError) effs
, Member (LogMsg ChainIndexLog) effs
)
=> ChainIndexControlEffect
~> Eff effs
handleControl = \case
AppendBlock tip_ transactions -> do
oldState <- get @ChainIndexEmulatorState
case UtxoState.insert (UtxoState.fromBlock tip_ transactions) (view utxoIndex oldState) of
Left err -> do
let reason = InsertionFailed err
logError $ Err reason
throwError reason
Right InsertUtxoSuccess{newIndex, insertPosition} -> do
put $ oldState
& set utxoIndex newIndex
& over diskState (mappend $ foldMap DiskState.fromTx transactions)
logDebug $ InsertionSuccess tip_ insertPosition
Rollback tip_ -> do
oldState <- get @ChainIndexEmulatorState
case UtxoState.rollback tip_ (view utxoIndex oldState) of
Left err -> do
let reason = RollbackFailed err
logError $ Err reason
throwError reason
Right RollbackResult{newTip, rolledBackIndex} -> do
put $ oldState & set utxoIndex rolledBackIndex
logDebug $ RollbackSuccess newTip
CollectGarbage -> do
-- Rebuild the index using only transactions that still have at
-- least one output in the UTXO set
utxos <- gets $
Set.toList
. Set.map txOutRefId
. UtxoState.unspentOutputs
. UtxoState.utxoState
. view utxoIndex
newDiskState <- foldMap DiskState.fromTx . catMaybes <$> mapM getTxFromTxId utxos
modify $ set diskState newDiskState
GetDiagnostics -> diagnostics . _diskState <$> get @ChainIndexEmulatorState