Skip to content

Commit b9f25e3

Browse files
author
euonymos
committed
feat: transition tests for Auction example
1 parent f25405b commit b9f25e3

File tree

4 files changed

+106
-114
lines changed

4 files changed

+106
-114
lines changed

‎cem-script.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@ version: 0.1.0
44
synopsis: CEM Script - a Cardano dApp SDK
55
homepage: https://github.com/mlabs-haskell/cem-script
66
author: MLabs
7-
maintainer: gregory@mlabs.city
7+
maintainer: ilia@mlabs.city
88
data-files: README.md
99
tested-with: GHC ==9.6.3
1010

‎test/Auction.hs‎

Lines changed: 73 additions & 67 deletions
Original file line numberDiff line numberDiff line change
@@ -1,27 +1,23 @@
1+
{-# OPTIONS_GHC -Wno-name-shadowing #-}
2+
13
module Auction where
24

35
import Prelude
46

5-
import Control.Monad.Trans (MonadIO (..))
6-
import PlutusLedgerApi.V1.Value (assetClassValue)
7-
87
import Cardano.Api.NetworkId (toShelleyNetwork)
9-
108
import Cardano.CEM
119
import Cardano.CEM.Examples.Auction
1210
import Cardano.CEM.Examples.Compilation ()
1311
import Cardano.CEM.Monads
1412
import Cardano.CEM.OffChain
1513
import Cardano.Extras
16-
14+
import Control.Monad.Trans (MonadIO (..))
15+
import OuraFilters.Mock (IndexerEvent (Following, Initial), extractEvent, resolvedTxToOura)
16+
import PlutusLedgerApi.V1.Value (assetClassValue)
1717
import Test.Hspec (describe, it, shouldBe)
18-
1918
import TestNFT (testNftAssetClass)
2019
import Utils (execClb, mintTestTokens, submitAndCheck, submitCheckReturn)
2120

22-
import Data.Aeson (encode)
23-
import OuraFilters.Mock (extractEvent, resolvedTxToOura)
24-
2521
auctionSpec = describe "Auction" $ do
2622
it "Wrong transition resolution error" $ execClb $ do
2723
seller <- (!! 0) <$> getTestWalletSks
@@ -128,18 +124,12 @@ auctionSpec = describe "Auction" $ do
128124
]
129125
, specSigner = bidder1
130126
}
131-
-- ~( Left
132-
-- ( MkTransitionError
133-
-- _
134-
-- (StateMachineError "\"Incorrect state for transition\"")
135-
-- )
136-
-- ) <-
137-
-- return result
138127
(Left _) <- return result
139128

140129
return ()
141130

142131
it "Successful transition flow" $ execClb $ do
132+
network <- toShelleyNetwork <$> askNetworkId
143133
seller <- (!! 0) <$> getTestWalletSks
144134
bidder1 <- (!! 1) <$> getTestWalletSks
145135

@@ -161,16 +151,20 @@ auctionSpec = describe "Auction" $ do
161151

162152
Nothing <- queryScriptState auctionParams
163153

164-
submitAndCheck $
165-
MkTxSpec
166-
{ actions =
167-
[ MkSomeCEMAction $ MkCEMAction auctionParams Create
168-
]
169-
, specSigner = seller
170-
}
154+
(preBody, utxo) <-
155+
submitCheckReturn $
156+
MkTxSpec
157+
{ actions =
158+
[ MkSomeCEMAction $ MkCEMAction auctionParams Create
159+
]
160+
, specSigner = seller
161+
}
171162

172163
Just NotStarted <- queryScriptState auctionParams
173164

165+
mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo
166+
liftIO $ mEvent `shouldBe` Just (Initial CreateSpine)
167+
174168
let
175169
initBid =
176170
MkBet
@@ -182,32 +176,45 @@ auctionSpec = describe "Auction" $ do
182176
{ better = signingKeyToPKH bidder1
183177
, betAmount = 3_000_000
184178
}
179+
bid2 =
180+
MkBet
181+
{ better = signingKeyToPKH bidder1
182+
, betAmount = 4_000_000
183+
}
185184

186-
submitAndCheck $
187-
MkTxSpec
188-
{ actions =
189-
[ MkSomeCEMAction $
190-
MkCEMAction auctionParams Start
191-
]
192-
, specSigner = seller
193-
}
185+
(preBody, utxo) <-
186+
submitCheckReturn $
187+
MkTxSpec
188+
{ actions =
189+
[ MkSomeCEMAction $
190+
MkCEMAction auctionParams Start
191+
]
192+
, specSigner = seller
193+
}
194194

195195
Just (CurrentBid currentBid') <- queryScriptState auctionParams
196196
liftIO $ currentBid' `shouldBe` initBid
197197

198-
submitAndCheck $
199-
MkTxSpec
200-
{ actions =
201-
[ MkSomeCEMAction $
202-
MkCEMAction auctionParams (MakeBid bid1)
203-
]
204-
, specSigner = bidder1
205-
}
198+
mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo
199+
liftIO $ mEvent `shouldBe` Just (Following StartSpine)
200+
201+
(preBody, utxo) <-
202+
submitCheckReturn $
203+
MkTxSpec
204+
{ actions =
205+
[ MkSomeCEMAction $
206+
MkCEMAction auctionParams (MakeBid bid1)
207+
]
208+
, specSigner = bidder1
209+
}
206210

207211
Just (CurrentBid currentBid) <- queryScriptState auctionParams
208212
liftIO $ currentBid `shouldBe` bid1
209213

210-
(preBody, tx, txInMode, utxo) <-
214+
mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo
215+
liftIO $ mEvent `shouldBe` Just (Following MakeBidSpine)
216+
217+
(preBody, utxo) <-
211218
submitCheckReturn $
212219
MkTxSpec
213220
{ actions =
@@ -220,35 +227,34 @@ auctionSpec = describe "Auction" $ do
220227
, specSigner = bidder1
221228
}
222229

223-
liftIO $ print tx
224-
liftIO $ putStrLn "---"
230+
Just (CurrentBid currentBid) <- queryScriptState auctionParams
231+
liftIO $ currentBid `shouldBe` bid2
225232

226-
-- liftIO $ print txInMode
227-
liftIO $ print utxo
228-
liftIO $ putStrLn "---"
233+
mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo
234+
liftIO $ mEvent `shouldBe` Just (Following MakeBidSpine)
229235

230-
let otx = resolvedTxToOura preBody utxo
231-
liftIO $ print $ encode otx
232-
liftIO $ putStrLn "---"
236+
(preBody, utxo) <-
237+
submitCheckReturn $
238+
MkTxSpec
239+
{ actions =
240+
[ MkSomeCEMAction $
241+
MkCEMAction auctionParams Close
242+
]
243+
, specSigner = seller
244+
}
233245

234-
network <- toShelleyNetwork <$> askNetworkId
235-
mEvent <- liftIO $ extractEvent @SimpleAuction otx network
236-
liftIO $ print mEvent
246+
mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo
247+
liftIO $ mEvent `shouldBe` Just (Following CloseSpine)
237248

238-
submitAndCheck $
239-
MkTxSpec
240-
{ actions =
241-
[ MkSomeCEMAction $
242-
MkCEMAction auctionParams Close
243-
]
244-
, specSigner = seller
245-
}
249+
(preBody, utxo) <-
250+
submitCheckReturn $
251+
MkTxSpec
252+
{ actions =
253+
[ MkSomeCEMAction $
254+
MkCEMAction auctionParams Buyout
255+
]
256+
, specSigner = bidder1
257+
}
246258

247-
submitAndCheck $
248-
MkTxSpec
249-
{ actions =
250-
[ MkSomeCEMAction $
251-
MkCEMAction auctionParams Buyout
252-
]
253-
, specSigner = bidder1
254-
}
259+
mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo
260+
liftIO $ mEvent `shouldBe` Just (Following BuyoutSpine)

‎test/OuraFilters/Mock.hs‎

Lines changed: 20 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -9,20 +9,18 @@ module OuraFilters.Mock where
99
import Cardano.Api qualified as C
1010

1111
-- import Cardano.Api.Address qualified as C
12-
import Cardano.Api (TxBody, TxIn, UTxO)
12+
import Cardano.Api (TxIn, UTxO)
1313
import Cardano.Api.Address qualified as C (Address (..))
1414
import Cardano.Api.ScriptData qualified as C
1515
import Cardano.Api.SerialiseRaw qualified as SerialiseRaw
1616
import Cardano.CEM (CEMScript, CEMScriptDatum, State, Transition, transitionStage)
1717
import Cardano.CEM.Address qualified as Address
18-
import Cardano.CEM.Monads (ResolvedTx (..))
1918
import Cardano.CEM.OnChain (CEMScriptCompiled, CEMScriptIsData)
20-
import Cardano.Extras (Era, TxInWitness)
19+
import Cardano.Extras (Era)
2120
import Cardano.Ledger.BaseTypes qualified as Ledger
22-
import Control.Lens (preview, view, (^.))
21+
import Control.Lens (view, (^.))
2322
import Control.Lens.TH (makeLenses, makeLensesFor)
2423
import Control.Monad ((<=<))
25-
import Control.Monad.Extra (join)
2624
import Data.Aeson (KeyValue ((.=)))
2725
import Data.Aeson qualified as Aeson
2826
import Data.Base16.Types qualified as Base16
@@ -33,29 +31,24 @@ import Data.Bifunctor (first)
3331
import Data.ByteString qualified as BS
3432
import Data.ByteString.Base16 qualified as Base16
3533
import Data.ByteString.Base64 qualified as Base64
36-
import Data.ByteString.Base64.URL qualified as B64
3734
import Data.ByteString.Lazy qualified as LBS
3835
import Data.Data (Proxy (Proxy))
39-
import Data.Either (fromRight)
4036
import Data.Either.Extra (eitherToMaybe)
4137
import Data.Function ((&))
4238
import Data.Functor ((<&>))
4339
import Data.List (find)
4440
import Data.Map.Strict qualified as Map
45-
import Data.Maybe (fromJust, fromMaybe, mapMaybe)
41+
import Data.Maybe (fromJust, mapMaybe)
4642
import Data.Spine (Spine, getSpine)
4743
import Data.Text qualified as T
4844
import Data.Text.Encoding (encodeUtf8)
4945
import Data.Tuple (swap)
5046
import Data.Vector qualified as Vec
51-
import Debug.Trace (trace, traceShowId)
5247
import GHC.Generics (Generic (Rep))
5348
import GHC.Stack.Types (HasCallStack)
54-
import PlutusLedgerApi.V1 (Credential, FromData, ToData)
49+
import PlutusLedgerApi.V1 (FromData)
5550
import PlutusLedgerApi.V1 qualified
5651
import Safe qualified
57-
import System.Process.Internals (ProcRetHandles (hStdOutput))
58-
import Test.QuickCheck (Result (output))
5952
import Utils (digits)
6053
import Prelude
6154

@@ -324,7 +317,12 @@ data IndexerEvent script
324317
-- | FIXME: Open an issue in Oura's repository
325318
Following (Spine (Transition script)) -- (Transition script)
326319

327-
deriving stock instance (Show (Spine (Transition script))) => (Show (IndexerEvent script))
320+
deriving stock instance
321+
(Show (Spine (Transition script))) =>
322+
(Show (IndexerEvent script))
323+
deriving stock instance
324+
(Eq (Spine (Transition script))) =>
325+
(Eq (IndexerEvent script))
328326

329327
-- For testing: build a tx in the Oura format from a Cardano tx.
330328
-- We populate only fields we use, use with cautious.
@@ -367,7 +365,7 @@ toOuraTxOutput (C.TxOut addr _ dat _) =
367365
toOuraDatum :: C.TxOutDatum ctx Era -> Maybe Datum
368366
toOuraDatum = \case
369367
(C.TxOutDatumInline _ hsd) ->
370-
let bs = traceShowId $ C.serialiseToCBOR hsd
368+
let bs = C.serialiseToCBOR hsd
371369
in Just $
372370
MkDatum
373371
{ _payload = MkPlutusData Aeson.Null
@@ -391,35 +389,33 @@ toOuraAddrress (C.AddressInEra _ addr) =
391389
. Base16.encodeBase16
392390
. SerialiseRaw.serialiseToRawBytes
393391

394-
-- The core function, that extracts an Event out of a Oura transaction.
392+
{- | The core function, that extracts an Event out of a Oura transaction.
393+
It might be a pure function, IO here was used mostly to simplify debugging
394+
during its development.
395+
-}
395396
extractEvent ::
396397
forall script.
397398
( CEMScript script
398399
, CEMScriptIsData script
399400
, CEMScriptCompiled script
400401
) =>
401-
Tx ->
402402
Ledger.Network ->
403+
Tx ->
403404
IO (Maybe (IndexerEvent script))
404-
extractEvent tx network = do
405+
extractEvent network tx = do
405406
-- Script payemnt credential based predicate
406407
let (Right scriptAddr) = Address.scriptCardanoAddress (Proxy @script) network
407408
let cPred = hasAddr scriptAddr
408-
print scriptAddr
409409

410410
-- Source state
411411
let mOwnInput :: Maybe TxInput = find (cPred . view as_output) (tx ^. inputs)
412412
let mSourceState :: Maybe (State script) = (extractState . view as_output) =<< mOwnInput
413413
let mSourceSpine :: Maybe (Spine (State script)) = getSpine <$> mSourceState
414-
putStr "Source state: "
415-
print mSourceSpine
416414

417415
-- Target state
418416
let mOwnOutput :: Maybe TxOutput = find cPred $ tx ^. outputs
419417
let mTargetState :: Maybe (State script) = extractState =<< mOwnOutput
420418
let mTargetSpine :: Maybe (Spine (State script)) = getSpine <$> mTargetState
421-
putStr "Target state: "
422-
print mTargetSpine
423419

424420
-- Look up the transition
425421
let transitions =
@@ -449,7 +445,7 @@ extractState MkTxOutput {_datum = mDtm} =
449445
Just dtm -> do
450446
let MkDatum _ _ cbor = dtm
451447
let datumAsData :: PlutusLedgerApi.V1.Data =
452-
traceShowId cbor
448+
cbor
453449
& C.toPlutusData
454450
. C.getScriptData
455451
. fromJust
@@ -463,17 +459,14 @@ extractState MkTxOutput {_datum = mDtm} =
463459
hasAddr :: C.Address C.ShelleyAddr -> TxOutput -> Bool
464460
hasAddr addr' output =
465461
let addr = output ^. address
466-
in traceShowId (fromOuraAddress addr) == addr'
462+
in fromOuraAddress addr == addr'
467463

468464
fromOuraAddress :: Address -> C.Address C.ShelleyAddr
469465
fromOuraAddress (MkAddressAsBase64 addr) =
470466
addr
471467
& fromJust
472468
. eitherToMaybe
473469
. SerialiseRaw.deserialiseFromRawBytes (C.AsAddress C.AsShelleyAddr)
474-
-- . fromJust
475-
-- . eitherToMaybe
476-
-- . B64.decodeBase64PaddedUntyped
477470
. Base16.decodeBase16Lenient
478471
. encodeUtf8
479472

0 commit comments

Comments
 (0)