feat: transition tests for Auction example

mlabs-haskell · Dec 5, 2024 · b9f25e3 · b9f25e3
1 parent f25405b
commit b9f25e3
Show file tree

Hide file tree

Showing 4 changed files with 106 additions and 114 deletions.
diff --git a/cem-script.cabal b/cem-script.cabal
@@ -4,7 +4,7 @@ version:       0.1.0
 synopsis:      CEM Script - a Cardano dApp SDK
 homepage:      https://github.com/mlabs-haskell/cem-script
 author:        MLabs
-maintainer:    gregory@mlabs.city
+maintainer:    ilia@mlabs.city
 data-files:    README.md
 tested-with:   GHC ==9.6.3
 

diff --git a/test/Auction.hs b/test/Auction.hs
@@ -1,27 +1,23 @@
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+
 module Auction where
 
 import Prelude
 
-import Control.Monad.Trans (MonadIO (..))
-import PlutusLedgerApi.V1.Value (assetClassValue)
-
 import Cardano.Api.NetworkId (toShelleyNetwork)
-
 import Cardano.CEM
 import Cardano.CEM.Examples.Auction
 import Cardano.CEM.Examples.Compilation ()
 import Cardano.CEM.Monads
 import Cardano.CEM.OffChain
 import Cardano.Extras
-
+import Control.Monad.Trans (MonadIO (..))
+import OuraFilters.Mock (IndexerEvent (Following, Initial), extractEvent, resolvedTxToOura)
+import PlutusLedgerApi.V1.Value (assetClassValue)
 import Test.Hspec (describe, it, shouldBe)
-
 import TestNFT (testNftAssetClass)
 import Utils (execClb, mintTestTokens, submitAndCheck, submitCheckReturn)
 
-import Data.Aeson (encode)
-import OuraFilters.Mock (extractEvent, resolvedTxToOura)
-
 auctionSpec = describe "Auction" $ do
   it "Wrong transition resolution error" $ execClb $ do
     seller <- (!! 0) <$> getTestWalletSks
@@ -128,18 +124,12 @@ auctionSpec = describe "Auction" $ do
               ]
           , specSigner = bidder1
           }
-    -- ~( Left
-    --     ( MkTransitionError
-    --         _
-    --         (StateMachineError "\"Incorrect state for transition\"")
-    --       )
-    --   ) <-
-    --   return result
     (Left _) <- return result
 
     return ()
 
   it "Successful transition flow" $ execClb $ do
+    network <- toShelleyNetwork <$> askNetworkId
     seller <- (!! 0) <$> getTestWalletSks
     bidder1 <- (!! 1) <$> getTestWalletSks
 
@@ -161,16 +151,20 @@ auctionSpec = describe "Auction" $ do
 
     Nothing <- queryScriptState auctionParams
 
-    submitAndCheck $
-      MkTxSpec
-        { actions =
-            [ MkSomeCEMAction $ MkCEMAction auctionParams Create
-            ]
-        , specSigner = seller
-        }
+    (preBody, utxo) <-
+      submitCheckReturn $
+        MkTxSpec
+          { actions =
+              [ MkSomeCEMAction $ MkCEMAction auctionParams Create
+              ]
+          , specSigner = seller
+          }
 
     Just NotStarted <- queryScriptState auctionParams
 
+    mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo
+    liftIO $ mEvent `shouldBe` Just (Initial CreateSpine)
+
     let
       initBid =
         MkBet
@@ -182,32 +176,45 @@ auctionSpec = describe "Auction" $ do
           { better = signingKeyToPKH bidder1
           , betAmount = 3_000_000
           }
+      bid2 =
+        MkBet
+          { better = signingKeyToPKH bidder1
+          , betAmount = 4_000_000
+          }
 
-    submitAndCheck $
-      MkTxSpec
-        { actions =
-            [ MkSomeCEMAction $
-                MkCEMAction auctionParams Start
-            ]
-        , specSigner = seller
-        }
+    (preBody, utxo) <-
+      submitCheckReturn $
+        MkTxSpec
+          { actions =
+              [ MkSomeCEMAction $
+                  MkCEMAction auctionParams Start
+              ]
+          , specSigner = seller
+          }
 
     Just (CurrentBid currentBid') <- queryScriptState auctionParams
     liftIO $ currentBid' `shouldBe` initBid
 
-    submitAndCheck $
-      MkTxSpec
-        { actions =
-            [ MkSomeCEMAction $
-                MkCEMAction auctionParams (MakeBid bid1)
-            ]
-        , specSigner = bidder1
-        }
+    mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo
+    liftIO $ mEvent `shouldBe` Just (Following StartSpine)
+
+    (preBody, utxo) <-
+      submitCheckReturn $
+        MkTxSpec
+          { actions =
+              [ MkSomeCEMAction $
+                  MkCEMAction auctionParams (MakeBid bid1)
+              ]
+          , specSigner = bidder1
+          }
 
     Just (CurrentBid currentBid) <- queryScriptState auctionParams
     liftIO $ currentBid `shouldBe` bid1
 
-    (preBody, tx, txInMode, utxo) <-
+    mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo
+    liftIO $ mEvent `shouldBe` Just (Following MakeBidSpine)
+
+    (preBody, utxo) <-
       submitCheckReturn $
         MkTxSpec
           { actions =
@@ -220,35 +227,34 @@ auctionSpec = describe "Auction" $ do
           , specSigner = bidder1
           }
 
-    liftIO $ print tx
-    liftIO $ putStrLn "---"
+    Just (CurrentBid currentBid) <- queryScriptState auctionParams
+    liftIO $ currentBid `shouldBe` bid2
 
-    -- liftIO $ print txInMode
-    liftIO $ print utxo
-    liftIO $ putStrLn "---"
+    mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo
+    liftIO $ mEvent `shouldBe` Just (Following MakeBidSpine)
 
-    let otx = resolvedTxToOura preBody utxo
-    liftIO $ print $ encode otx
-    liftIO $ putStrLn "---"
+    (preBody, utxo) <-
+      submitCheckReturn $
+        MkTxSpec
+          { actions =
+              [ MkSomeCEMAction $
+                  MkCEMAction auctionParams Close
+              ]
+          , specSigner = seller
+          }
 
-    network <- toShelleyNetwork <$> askNetworkId
-    mEvent <- liftIO $ extractEvent @SimpleAuction otx network
-    liftIO $ print mEvent
+    mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo
+    liftIO $ mEvent `shouldBe` Just (Following CloseSpine)
 
-    submitAndCheck $
-      MkTxSpec
-        { actions =
-            [ MkSomeCEMAction $
-                MkCEMAction auctionParams Close
-            ]
-        , specSigner = seller
-        }
+    (preBody, utxo) <-
+      submitCheckReturn $
+        MkTxSpec
+          { actions =
+              [ MkSomeCEMAction $
+                  MkCEMAction auctionParams Buyout
+              ]
+          , specSigner = bidder1
+          }
 
-    submitAndCheck $
-      MkTxSpec
-        { actions =
-            [ MkSomeCEMAction $
-                MkCEMAction auctionParams Buyout
-            ]
-        , specSigner = bidder1
-        }
+    mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo
+    liftIO $ mEvent `shouldBe` Just (Following BuyoutSpine)
diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs
@@ -9,20 +9,18 @@ module OuraFilters.Mock where
 import Cardano.Api qualified as C
 
 -- import Cardano.Api.Address qualified as C
-import Cardano.Api (TxBody, TxIn, UTxO)
+import Cardano.Api (TxIn, UTxO)
 import Cardano.Api.Address qualified as C (Address (..))
 import Cardano.Api.ScriptData qualified as C
 import Cardano.Api.SerialiseRaw qualified as SerialiseRaw
 import Cardano.CEM (CEMScript, CEMScriptDatum, State, Transition, transitionStage)
 import Cardano.CEM.Address qualified as Address
-import Cardano.CEM.Monads (ResolvedTx (..))
 import Cardano.CEM.OnChain (CEMScriptCompiled, CEMScriptIsData)
-import Cardano.Extras (Era, TxInWitness)
+import Cardano.Extras (Era)
 import Cardano.Ledger.BaseTypes qualified as Ledger
-import Control.Lens (preview, view, (^.))
+import Control.Lens (view, (^.))
 import Control.Lens.TH (makeLenses, makeLensesFor)
 import Control.Monad ((<=<))
-import Control.Monad.Extra (join)
 import Data.Aeson (KeyValue ((.=)))
 import Data.Aeson qualified as Aeson
 import Data.Base16.Types qualified as Base16
@@ -33,29 +31,24 @@ import Data.Bifunctor (first)
 import Data.ByteString qualified as BS
 import Data.ByteString.Base16 qualified as Base16
 import Data.ByteString.Base64 qualified as Base64
-import Data.ByteString.Base64.URL qualified as B64
 import Data.ByteString.Lazy qualified as LBS
 import Data.Data (Proxy (Proxy))
-import Data.Either (fromRight)
 import Data.Either.Extra (eitherToMaybe)
 import Data.Function ((&))
 import Data.Functor ((<&>))
 import Data.List (find)
 import Data.Map.Strict qualified as Map
-import Data.Maybe (fromJust, fromMaybe, mapMaybe)
+import Data.Maybe (fromJust, mapMaybe)
 import Data.Spine (Spine, getSpine)
 import Data.Text qualified as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Tuple (swap)
 import Data.Vector qualified as Vec
-import Debug.Trace (trace, traceShowId)
 import GHC.Generics (Generic (Rep))
 import GHC.Stack.Types (HasCallStack)
-import PlutusLedgerApi.V1 (Credential, FromData, ToData)
+import PlutusLedgerApi.V1 (FromData)
 import PlutusLedgerApi.V1 qualified
 import Safe qualified
-import System.Process.Internals (ProcRetHandles (hStdOutput))
-import Test.QuickCheck (Result (output))
 import Utils (digits)
 import Prelude
 
@@ -324,7 +317,12 @@ data IndexerEvent script
     -- | FIXME: Open an issue in Oura's repository
     Following (Spine (Transition script)) -- (Transition script)
 
-deriving stock instance (Show (Spine (Transition script))) => (Show (IndexerEvent script))
+deriving stock instance
+  (Show (Spine (Transition script))) =>
+  (Show (IndexerEvent script))
+deriving stock instance
+  (Eq (Spine (Transition script))) =>
+  (Eq (IndexerEvent script))
 
 -- For testing: build a tx in the Oura format from a Cardano tx.
 -- We populate only fields we use, use with cautious.
@@ -367,7 +365,7 @@ toOuraTxOutput (C.TxOut addr _ dat _) =
 toOuraDatum :: C.TxOutDatum ctx Era -> Maybe Datum
 toOuraDatum = \case
   (C.TxOutDatumInline _ hsd) ->
-    let bs = traceShowId $ C.serialiseToCBOR hsd
+    let bs = C.serialiseToCBOR hsd
      in Just $
           MkDatum
             { _payload = MkPlutusData Aeson.Null
@@ -391,35 +389,33 @@ toOuraAddrress (C.AddressInEra _ addr) =
           . Base16.encodeBase16
           . SerialiseRaw.serialiseToRawBytes
 
--- The core function, that extracts an Event out of a Oura transaction.
+{- | The core function, that extracts an Event out of a Oura transaction.
+It might be a pure function, IO here was used mostly to simplify debugging
+during its development.
+-}
 extractEvent ::
   forall script.
   ( CEMScript script
   , CEMScriptIsData script
   , CEMScriptCompiled script
   ) =>
-  Tx ->
   Ledger.Network ->
+  Tx ->
   IO (Maybe (IndexerEvent script))
-extractEvent tx network = do
+extractEvent network tx = do
   -- Script payemnt credential based predicate
   let (Right scriptAddr) = Address.scriptCardanoAddress (Proxy @script) network
   let cPred = hasAddr scriptAddr
-  print scriptAddr
 
   -- Source state
   let mOwnInput :: Maybe TxInput = find (cPred . view as_output) (tx ^. inputs)
   let mSourceState :: Maybe (State script) = (extractState . view as_output) =<< mOwnInput
   let mSourceSpine :: Maybe (Spine (State script)) = getSpine <$> mSourceState
-  putStr "Source state: "
-  print mSourceSpine
 
   -- Target state
   let mOwnOutput :: Maybe TxOutput = find cPred $ tx ^. outputs
   let mTargetState :: Maybe (State script) = extractState =<< mOwnOutput
   let mTargetSpine :: Maybe (Spine (State script)) = getSpine <$> mTargetState
-  putStr "Target state: "
-  print mTargetSpine
 
   -- Look up the transition
   let transitions =
@@ -449,7 +445,7 @@ extractState MkTxOutput {_datum = mDtm} =
     Just dtm -> do
       let MkDatum _ _ cbor = dtm
       let datumAsData :: PlutusLedgerApi.V1.Data =
-            traceShowId cbor
+            cbor
               & C.toPlutusData
                 . C.getScriptData
                 . fromJust
@@ -463,17 +459,14 @@ extractState MkTxOutput {_datum = mDtm} =
 hasAddr :: C.Address C.ShelleyAddr -> TxOutput -> Bool
 hasAddr addr' output =
   let addr = output ^. address
-   in traceShowId (fromOuraAddress addr) == addr'
+   in fromOuraAddress addr == addr'
 
 fromOuraAddress :: Address -> C.Address C.ShelleyAddr
 fromOuraAddress (MkAddressAsBase64 addr) =
   addr
     & fromJust
       . eitherToMaybe
       . SerialiseRaw.deserialiseFromRawBytes (C.AsAddress C.AsShelleyAddr)
-      --  . fromJust
-      --  . eitherToMaybe
-      --  . B64.decodeBase64PaddedUntyped
       . Base16.decodeBase16Lenient
       . encodeUtf8