From e3c5c63f8ed33e936215a21d0659c4beb1aefee4 Mon Sep 17 00:00:00 2001 From: euonymos Date: Sat, 30 Nov 2024 17:07:51 -0600 Subject: [PATCH] feat: parse transition spines from transactions WIP --- src/Cardano/CEM/Examples/Auction.hs | 2 + test/Oura.hs | 1 + test/Oura/Config.hs | 129 ++++++++++++++-------------- test/OuraFilters/Mock.hs | 29 +++++++ 4 files changed, 97 insertions(+), 64 deletions(-) diff --git a/src/Cardano/CEM/Examples/Auction.hs b/src/Cardano/CEM/Examples/Auction.hs index f663141..ffd6fd5 100644 --- a/src/Cardano/CEM/Examples/Auction.hs +++ b/src/Cardano/CEM/Examples/Auction.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas -ddump-splices #-} {-# LANGUAGE NoPolyKinds #-} module Cardano.CEM.Examples.Auction where @@ -36,6 +37,7 @@ data SimpleAuctionStageParams | CanCloseAt POSIXTime deriving stock (Prelude.Eq, Prelude.Show) + instance Stages SimpleAuctionStage where type StageParams SimpleAuctionStage = SimpleAuctionStageParams stageToOnChainInterval NoControl _ = Interval.always diff --git a/test/Oura.hs b/test/Oura.hs index e5f9a34..32562ab 100644 --- a/test/Oura.hs +++ b/test/Oura.hs @@ -1,3 +1,4 @@ +{- TODO: move to the Indexing folder? -} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} diff --git a/test/Oura/Config.hs b/test/Oura/Config.hs index 3ba63e3..f519cbc 100644 --- a/test/Oura/Config.hs +++ b/test/Oura/Config.hs @@ -1,81 +1,82 @@ +{- FIXME: remove -} {-# LANGUAGE BlockArguments #-} module Oura.Config ( - filtersL, - predicateL, - tableL, - atKey, - _Table, - _Integer, - _Bool, - _Text, + -- filtersL, + -- predicateL, + -- tableL, + -- atKey, + -- _Table, + -- _Integer, + -- _Bool, + -- _Text, ) where -import Prelude +-- import Prelude -import Cardano.CEM.Indexing qualified as Config -import Control.Lens ( - At (at), - Each (each), - Iso', - Lens', - Prism', - Traversal', - from, - iso, - mapping, - partsOf, - prism', - _Just, - ) -import Data.Map (Map) -import Data.Text qualified as T -import Toml qualified +-- import Cardano.CEM.Indexing qualified as Config +-- import Control.Lens ( +-- At (at), +-- Each (each), +-- Iso', +-- Lens', +-- Prism', +-- Traversal', +-- from, +-- iso, +-- mapping, +-- partsOf, +-- prism', +-- _Just, +-- ) +-- import Data.Map (Map) +-- import Data.Text qualified as T +-- import Toml qualified --- * Config +-- -- * Config -filterL :: Iso' Config.Filter Toml.Table -filterL = iso Config.unFilter Config.MkFilter +-- filterL :: Iso' Config.Filter Toml.Table +-- filterL = iso Config.unFilter Config.MkFilter -predicateL :: Traversal' Config.Filter T.Text -predicateL = filterL . atKey "predicate" . _Just . _Text +-- predicateL :: Traversal' Config.Filter T.Text +-- predicateL = filterL . atKey "predicate" . _Just . _Text -filtersL :: Traversal' Toml.Table [Config.Filter] -filtersL = - atKey "filters" - . _Just - . _List - . partsOf (each . _Table . from filterL) +-- filtersL :: Traversal' Toml.Table [Config.Filter] +-- filtersL = +-- atKey "filters" +-- . _Just +-- . _List +-- . partsOf (each . _Table . from filterL) -atKey :: T.Text -> Traversal' Toml.Table (Maybe Toml.Value) -atKey key = tableL . at key +-- atKey :: T.Text -> Traversal' Toml.Table (Maybe Toml.Value) +-- atKey key = tableL . at key -tableL :: Lens' Toml.Table (Map T.Text Toml.Value) -tableL = - iso (\(Toml.MkTable t) -> t) Toml.MkTable - . mapping (iso snd ((),)) +-- tableL :: Lens' Toml.Table (Map T.Text Toml.Value) +-- tableL = +-- iso (\(Toml.MkTable t) -> t) Toml.MkTable +-- . mapping (iso snd ((),)) -_Table :: Prism' Toml.Value Toml.Table -_Table = prism' Toml.Table \case - Toml.Table table -> Just table - _ -> Nothing +-- _Table :: Prism' Toml.Value Toml.Table +-- _Table = prism' Toml.Table \case +-- Toml.Table table -> Just table +-- _ -> Nothing -_Text :: Prism' Toml.Value T.Text -_Text = prism' Toml.Text \case - Toml.Text t -> Just t - _ -> Nothing +-- _Text :: Prism' Toml.Value T.Text +-- _Text = prism' Toml.Text \case +-- Toml.Text t -> Just t +-- _ -> Nothing -_List :: Prism' Toml.Value [Toml.Value] -_List = prism' Toml.List \case - Toml.List xs -> Just xs - _ -> Nothing +-- _List :: Prism' Toml.Value [Toml.Value] +-- _List = prism' Toml.List \case +-- Toml.List xs -> Just xs +-- _ -> Nothing -_Bool :: Prism' Toml.Value Bool -_Bool = prism' Toml.Bool \case - Toml.Bool b -> Just b - _ -> Nothing +-- _Bool :: Prism' Toml.Value Bool +-- _Bool = prism' Toml.Bool \case +-- Toml.Bool b -> Just b +-- _ -> Nothing -_Integer :: Prism' Toml.Value Integer -_Integer = prism' Toml.Integer \case - Toml.Integer n -> Just n - _ -> Nothing +-- _Integer :: Prism' Toml.Value Integer +-- _Integer = prism' Toml.Integer \case +-- Toml.Integer n -> Just n +-- _ -> Nothing diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs index a05c8e6..82e4cfe 100644 --- a/test/OuraFilters/Mock.hs +++ b/test/OuraFilters/Mock.hs @@ -21,6 +21,7 @@ import Data.ByteString.Base16 qualified as Base16 import Data.ByteString.Base64 qualified as Base64 import Data.ByteString.Lazy qualified as LBS import Data.Functor ((<&>)) +import Data.Map.Strict qualified as Map import Data.Text qualified as T import Data.Vector qualified as Vec import GHC.Generics (Generic (Rep)) @@ -29,6 +30,11 @@ import PlutusLedgerApi.V1 qualified import Safe qualified import Utils (digits) import Prelude +import Cardano.CEM (Transition, CEMScript, transitionStage, State) +import Data.Data (Proxy(Proxy)) +import Data.Spine (getSpine, Spine) +import Data.Tuple (swap) +import Data.Bifunctor (first) newtype WithoutUnderscore a = MkWithoutUnderscore a deriving newtype (Generic) @@ -261,6 +267,28 @@ data Tx = MkTx makeLenses ''Tx makeLensesFor [("collateral", "txCollateral")] ''Tx + +-- --- + +type Event script = Spine (Transition script) + + +extractEvent :: forall script. (CEMScript script) => Tx -> Maybe (Event script) +extractEvent tx = do + let mOwnInput :: Maybe TxInput = undefined + let mSourceState :: Maybe (State script) = _ mOwnInput + let mSourceSpine :: Maybe (Spine (State script)) = getSpine <$> mSourceState + + let mOwnOutput :: Maybe TxInput = undefined + let mTargetState :: Maybe (State script) = _ mOwnInput + let mSourceSpine :: Maybe (Spine (State script)) = getSpine <$> mSourceState + + let transitions = first (\(_,b,c) -> (b,c)) . swap <$> Map.toList (transitionStage $ Proxy @script) + lookup (mSourceSpine, mSourceSpine) transitions + +-- --- + + data TxEvent = MkTxEvent { _parsed_tx :: Tx , _point :: String -- "Origin" @@ -369,3 +397,4 @@ plutusAddressToOuraAddress = . SerialiseRaw.serialiseToRawBytes . either error id . Address.plutusAddressToShelleyAddress Ledger.Mainnet +