/
Handler.hs
176 lines (155 loc) · 7.11 KB
/
Handler.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
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Plutus.Contract.Marconi.Handler where
import Cardano.Api (AddressInEra (AddressInEra), AddressTypeInEra (..), ChainPoint (..), SlotNo (SlotNo), TxIx (TxIx),
toAddressAny)
import Cardano.Api qualified as C
import Control.Concurrent (MVar, putMVar, readMVar)
import Control.Lens (Lens', _1, folded, makeLenses, views, (&), (.~), (^.), (^..))
import Control.Monad.Freer (Eff, LastMember, Member, interpret, type (~>))
import Control.Monad.Freer.Error (Error, runError, throwError)
import Control.Monad.Freer.Extras (raiseMUnderN)
import Control.Monad.Freer.Extras.Pagination (PageQuery, pageOf)
import Control.Monad.Freer.State qualified as Eff (State, get, put, runState)
import Control.Monad.Freer.TH (makeEffect)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Foldable (foldl')
import Data.Maybe (fromJust)
import Data.Set qualified as Set
import Ledger (CardanoTx (CardanoTx))
import Ledger.Address (CardanoAddress)
import Ledger.Tx.CardanoAPI.Internal (fromCardanoTxId)
import Marconi.ChainIndex.Indexers.Utxo (StorableEvent (UtxoEvent), StorableQuery (UtxoAddress), UtxoHandle, getInputs,
getUtxoResult, getUtxos, txId, txIx, urUtxo)
import Marconi.Core.Storable (HasPoint, QueryInterval (QEverything), Queryable, State, StorableMonad, StorablePoint,
StorableResult, insertMany, query)
import Plutus.ChainIndex.Api (UtxosResponse (UtxosResponse))
import Plutus.ChainIndex.ChainIndexError (ChainIndexError (..))
import Plutus.ChainIndex.Compatibility (toCardanoBlockId)
import Plutus.ChainIndex.Effects (ChainIndexControlEffect (AppendBlocks), ChainIndexQueryEffect (UtxoSetAtAddress))
import Plutus.ChainIndex.Types (ChainSyncBlock (..), Point (Point, PointAtGenesis), Tip (TipAtGenesis), citxCardanoTx,
tipAsPoint)
import Plutus.V2.Ledger.Api (TxOutRef (TxOutRef))
{- Developer note:
How to add new indexer to support new effect?
1. add the indexer MVar to `ChainIndexIndexersMvar` and the corresponding indexer to `ChainIndexIndexers`
2. edit `getChainIndexIndexers` and `putChainIndexIndexers` accordingly
3. generate `MarconiEffect` on the appropriate queries of `ChainIndexQueries` in `handleQuery`
4. Add the indexer update in the control operations
5. Add the `handleMarconiQuery` for the new effect in `handleChainIndexEffects`
-}
data ChainIndexIndexers -- We don't use `newtype` since other indexers will be needed
= ChainIndexIndexers
{ _utxosIndexer :: State UtxoHandle
}
makeLenses ''ChainIndexIndexers
data ChainIndexIndexersMVar -- We don't use `newtype` since other indexers will be needed
= ChainIndexIndexersMVar
{ _utxosIndexerMVar :: MVar (State UtxoHandle)
}
makeLenses ''ChainIndexIndexersMVar
getChainIndexIndexers :: ChainIndexIndexersMVar -> IO ChainIndexIndexers
getChainIndexIndexers mvarCi =
ChainIndexIndexers <$> readMVar (mvarCi ^. utxosIndexerMVar)
putChainIndexIndexers :: ChainIndexIndexers -> ChainIndexIndexersMVar -> IO ()
putChainIndexIndexers ci mvarCi = do
putMVar (mvarCi ^. utxosIndexerMVar) (ci ^. utxosIndexer)
data MarconiEffect handle r where
QueryIndexer :: StorableQuery handle -> MarconiEffect handle (StorableResult handle)
makeEffect ''MarconiEffect
handleMarconiQuery ::
( LastMember IO effs
, Member (Eff.State ChainIndexIndexers) effs
, StorableMonad handle ~ IO
, HasPoint (StorableEvent handle) (StorablePoint handle)
, Ord (StorablePoint handle)
, Queryable handle
)
=> Lens' ChainIndexIndexers (State handle) -> MarconiEffect handle ~> Eff effs
handleMarconiQuery l (QueryIndexer q) = do
ci <- Eff.get
liftIO $ query QEverything (ci ^. l) q
getUtxoSetAtAddress
:: forall effs.
( Member (MarconiEffect UtxoHandle) effs
)
=> PageQuery TxOutRef
-> CardanoAddress
-> Eff effs UtxosResponse
getUtxoSetAtAddress pageQuery addrInEra = let
toTxOutRef utxo = TxOutRef
(fromCardanoTxId $ utxo ^. txId)
(toInteger . (\(TxIx x) -> x) $ utxo ^. txIx)
addr = case addrInEra of
AddressInEra ByronAddressInAnyEra addr' -> toAddressAny addr'
AddressInEra (ShelleyAddressInEra _) addr' -> toAddressAny addr'
in UtxosResponse TipAtGenesis
. pageOf pageQuery
. Set.fromList
. fmap (views urUtxo toTxOutRef)
. getUtxoResult
<$> queryIndexer (UtxoAddress addr)
getUtxoEvents
:: [CardanoTx]
-> C.ChainPoint
-> StorableEvent UtxoHandle -- ^ UtxoEvents are stored in storage after conversion to UtxoRow
getUtxoEvents txs cp =
let
utxosFromCardanoTx (CardanoTx c _) = getUtxos Nothing c
inputsFromCardanoTx (CardanoTx c _) = getInputs c
utxos = Set.fromList $ concatMap utxosFromCardanoTx txs
ins = foldl' Set.union Set.empty $ inputsFromCardanoTx <$> txs
in UtxoEvent utxos ins cp
handleControl ::
( LastMember IO effs
, Member (Eff.State ChainIndexIndexers) effs
, Member (Error ChainIndexError) effs
) =>
ChainIndexControlEffect ~> Eff effs
handleControl = \case
AppendBlocks xs -> do
ci <- Eff.get
utxosIndexer' <- liftIO $ insertMany (extractUtxosEvent <$> xs) (ci ^. utxosIndexer)
Eff.put (ci & utxosIndexer .~ utxosIndexer')
_other -> throwError UnsupportedControlOperation
where
toCardanoPoint PointAtGenesis = ChainPointAtGenesis
toCardanoPoint (Point slot blockId) =
ChainPoint (SlotNo (fromIntegral slot)) (fromJust $ toCardanoBlockId blockId)
extractUtxosEvent Block{blockTip,blockTxs} = let
point = toCardanoPoint $ tipAsPoint blockTip
in getUtxoEvents
(blockTxs ^.. folded . _1 . citxCardanoTx . folded)
point
handleQuery ::
( Member (MarconiEffect UtxoHandle) effs
, Member (Error ChainIndexError) effs
) => ChainIndexQueryEffect
~> Eff effs
handleQuery = \case
UtxoSetAtAddress pageQuery addr -> getUtxoSetAtAddress pageQuery addr
_eff -> throwError UnsupportedQuery
-- | Handle the chain index effects from the set of all effects.
handleChainIndexEffects
:: LastMember IO effs
=> ChainIndexIndexersMVar
-> Eff (ChainIndexQueryEffect ': ChainIndexControlEffect ': MarconiEffect UtxoHandle ': effs) a
-> Eff effs (Either ChainIndexError a)
handleChainIndexEffects mIndexers action = do
indexers <- liftIO $ getChainIndexIndexers mIndexers
(result, indexers') <- Eff.runState indexers
$ runError @ChainIndexError
$ interpret (handleMarconiQuery utxosIndexer)
$ interpret handleControl
$ interpret handleQuery
$ raiseMUnderN @[_,_] @[_,_,_] action
liftIO $ putChainIndexIndexers indexers' mIndexers
pure result