|
| 1 | +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} |
| 2 | + |
| 3 | +-- | Indexer events, i.e. indexer outputs. |
| 4 | +module Cardano.CEM.Indexing.Event where |
| 5 | + |
| 6 | +import Cardano.Api qualified as C |
| 7 | +import Cardano.Api.ScriptData qualified as C |
| 8 | +import Cardano.Api.SerialiseRaw qualified as SerialiseRaw |
| 9 | +import Cardano.CEM (CEMScript, CEMScriptDatum, State, Transition, transitionStage) |
| 10 | +import Cardano.CEM.Address qualified as Address |
| 11 | +import Cardano.CEM.Indexing.Tx |
| 12 | +import Cardano.CEM.OnChain (CEMScriptCompiled, CEMScriptIsData) |
| 13 | +import Cardano.Ledger.BaseTypes qualified as Ledger |
| 14 | +import Control.Lens (view, (^.)) |
| 15 | +import Data.Bifunctor (first) |
| 16 | +import Data.ByteString.Base16 qualified as B16 |
| 17 | +import Data.Data (Proxy (Proxy)) |
| 18 | +import Data.Either.Extra (eitherToMaybe) |
| 19 | +import Data.Function ((&)) |
| 20 | +import Data.List (find) |
| 21 | +import Data.Map.Strict qualified as Map |
| 22 | +import Data.Maybe (fromJust) |
| 23 | +import Data.Spine (Spine, getSpine) |
| 24 | +import Data.Text.Encoding (encodeUtf8) |
| 25 | +import Data.Tuple (swap) |
| 26 | +import PlutusLedgerApi.V1 (FromData) |
| 27 | +import PlutusLedgerApi.V1 qualified |
| 28 | +import Prelude |
| 29 | + |
| 30 | +-- --- |
| 31 | + |
| 32 | +{- | Indexer events. |
| 33 | + We extract events from transactions, where we can encounter three situations: |
| 34 | +
|
| 35 | + (1) For the very first transition there is only target datum and no redeemer. |
| 36 | + In that case we can only restore the name of the transition, |
| 37 | + i.e. 'Spine Transition' |
| 38 | +
|
| 39 | + (2) For intermidiate transitions we have both datums that identify them and |
| 40 | + additionally redeemer, that contains the whole transition. In that case |
| 41 | + we can restore the whole transition. |
| 42 | +
|
| 43 | + (3) For the final transition the situation is like (2) except the target |
| 44 | + datum is missing, which doesn't matter. |
| 45 | +
|
| 46 | +
|
| 47 | + TODO: How we can improve this in the future: |
| 48 | + * API is probably bad, as we always have some transition like Init state - |
| 49 | + which you can decode, as you have State. If one changes data |
| 50 | + `CEMAction script = MkCEMAction (Params script) (Transition script)` to |
| 51 | + `... = Init (Params script) (State script) |
| 52 | + | Transition (Params script) (Transition script)` |
| 53 | + one could reuse this datatype in all situations. |
| 54 | +-} |
| 55 | +data IndexerEvent script |
| 56 | + = Initial (Spine (Transition script)) |
| 57 | + | -- | TODO: Migrate from (Spine (Transition script)) to (Transition script) |
| 58 | + -- once we have this done: https://github.com/utxorpc/spec/issues/132 |
| 59 | + Following (Spine (Transition script)) -- (Transition script) |
| 60 | + |
| 61 | +deriving stock instance |
| 62 | + (Show (Spine (Transition script))) => |
| 63 | + (Show (IndexerEvent script)) |
| 64 | +deriving stock instance |
| 65 | + (Eq (Spine (Transition script))) => |
| 66 | + (Eq (IndexerEvent script)) |
| 67 | + |
| 68 | +{- | The core function, that extracts an Event out of a Oura transaction. |
| 69 | +It might be a pure function, IO here was used mostly to simplify debugging |
| 70 | +during its development. |
| 71 | +-} |
| 72 | +extractEvent :: |
| 73 | + forall script. |
| 74 | + ( CEMScript script |
| 75 | + , CEMScriptIsData script |
| 76 | + , CEMScriptCompiled script |
| 77 | + ) => |
| 78 | + Ledger.Network -> |
| 79 | + Tx -> |
| 80 | + IO (Maybe (IndexerEvent script)) |
| 81 | +extractEvent network tx = do |
| 82 | + -- Script payemnt credential based predicate |
| 83 | + let ~(Right scriptAddr) = Address.scriptCardanoAddress (Proxy @script) network |
| 84 | + let cPred = hasAddr scriptAddr |
| 85 | + |
| 86 | + -- Source state |
| 87 | + let mOwnInput :: Maybe TxInput = find (cPred . view as_output) (tx ^. inputs) |
| 88 | + let mSourceState :: Maybe (State script) = (extractState . view as_output) =<< mOwnInput |
| 89 | + let mSourceSpine :: Maybe (Spine (State script)) = getSpine <$> mSourceState |
| 90 | + |
| 91 | + -- Target state |
| 92 | + let mOwnOutput :: Maybe TxOutput = find cPred $ tx ^. outputs |
| 93 | + let mTargetState :: Maybe (State script) = extractState =<< mOwnOutput |
| 94 | + let mTargetSpine :: Maybe (Spine (State script)) = getSpine <$> mTargetState |
| 95 | + |
| 96 | + -- Look up the transition |
| 97 | + let transitions = |
| 98 | + first |
| 99 | + (\(_, b, c) -> (b, c)) |
| 100 | + . swap |
| 101 | + <$> Map.toList (transitionStage $ Proxy @script) |
| 102 | + let transSpine = lookup (mSourceSpine, mTargetSpine) transitions |
| 103 | + |
| 104 | + -- Return |
| 105 | + case mOwnInput of |
| 106 | + Nothing -> pure $ Initial <$> transSpine |
| 107 | + Just _ownInput -> do |
| 108 | + -- TODO: fix once Oura has rawCbor for redeemer |
| 109 | + -- rdm <- ownInput ^. redeemer |
| 110 | + -- pure $ Following $ undefined (rdm ^. redeemerPayload) |
| 111 | + pure $ Following <$> transSpine |
| 112 | + |
| 113 | +extractState :: |
| 114 | + forall script. |
| 115 | + (FromData (CEMScriptDatum script)) => |
| 116 | + TxOutput -> |
| 117 | + Maybe (State script) |
| 118 | +extractState MkTxOutput {_datum = mDtm} = |
| 119 | + case mDtm of |
| 120 | + Nothing -> Nothing |
| 121 | + Just dtm -> do |
| 122 | + let MkDatum _ _ cbor = dtm |
| 123 | + let datumAsData :: PlutusLedgerApi.V1.Data = |
| 124 | + cbor |
| 125 | + & C.toPlutusData |
| 126 | + . C.getScriptData |
| 127 | + . fromJust |
| 128 | + . eitherToMaybe |
| 129 | + . C.deserialiseFromCBOR C.AsHashableScriptData |
| 130 | + . B16.decodeBase16Lenient -- use base64 |
| 131 | + . encodeUtf8 |
| 132 | + let ~(Just (_, _, state)) = PlutusLedgerApi.V1.fromData @(CEMScriptDatum script) datumAsData |
| 133 | + pure state |
| 134 | + |
| 135 | +hasAddr :: C.Address C.ShelleyAddr -> TxOutput -> Bool |
| 136 | +hasAddr addr' output = |
| 137 | + let addr = output ^. address |
| 138 | + in fromOuraAddress addr == addr' |
| 139 | + |
| 140 | +fromOuraAddress :: Address -> C.Address C.ShelleyAddr |
| 141 | +fromOuraAddress (MkAddressAsBase64 addr) = |
| 142 | + addr |
| 143 | + & fromJust |
| 144 | + . eitherToMaybe |
| 145 | + . SerialiseRaw.deserialiseFromRawBytes (C.AsAddress C.AsShelleyAddr) |
| 146 | + . B16.decodeBase16Lenient -- use base64 |
| 147 | + . encodeUtf8 |
0 commit comments