feat: build/parse Oura txs

Author: euonymos

src/Cardano/CEM/Examples/Auction.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoPolyKinds #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas -ddump-splices #-}
+
+-- {-# OPTIONS_GHC -Wno-unrecognised-pragmas -ddump-splices #-}
 
 module Cardano.CEM.Examples.Auction where
 

src/Cardano/CEM/Examples/Voting.hs

@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas -ddump-splices #-}
+-- {-# OPTIONS_GHC -Wno-unrecognised-pragmas -ddump-splices #-}
 
 {-# HLINT ignore "Use when" #-}
 

src/Cardano/CEM/Monads.hs

@@ -140,7 +140,9 @@ data TxResolutionError
 -- | Ability to send transaction to chain
 class (MonadQueryUtxo m) => MonadSubmitTx m where
   submitResolvedTx :: ResolvedTx -> m (Either TxSubmittingError TxId)
-  submitResolvedTxRet :: ResolvedTx -> m (Either TxSubmittingError (TxBody Era, TxInMode, UTxO Era))
+  submitResolvedTxRet ::
+    ResolvedTx ->
+    m (Either TxSubmittingError (TxBodyContent BuildTx Era, TxBody Era, TxInMode, UTxO Era))
 
 -- | Stuff needed to use monad for local testing
 class (MonadSubmitTx m) => MonadTest m where

src/Cardano/CEM/Monads/CLB.hs

@@ -91,20 +91,22 @@ instance (Monad m, MonadBlockchainParams (ClbT m)) => MonadQueryUtxo (ClbT m) wh
         ByTxIns txIns -> return $ \txIn _ -> txIn `elem` txIns
 
 instance (Monad m, MonadBlockchainParams (ClbT m)) => MonadSubmitTx (ClbT m) where
-  submitResolvedTxRet :: ResolvedTx -> ClbT m (Either TxSubmittingError (TxBody Era, TxInMode, UTxO Era))
+  submitResolvedTxRet ::
+    ResolvedTx ->
+    ClbT m (Either TxSubmittingError (TxBodyContent BuildTx Era, TxBody Era, TxInMode, UTxO Era))
   submitResolvedTxRet tx = do
     cardanoTxBodyFromResolvedTx tx >>= \case
-      Right (body, txInMode@(TxInMode ShelleyBasedEraBabbage tx'), utxo) -> do
+      Right (preBody, body, txInMode@(TxInMode ShelleyBasedEraBabbage tx'), utxo) -> do
         result <- sendTx tx'
         case result of
-          Success _ _ -> return $ Right (body, txInMode, utxo)
+          Success _ _ -> return $ Right (preBody, body, txInMode, utxo)
           Fail _ validationError ->
             return $ Left $ UnhandledNodeSubmissionError validationError
-      Right (_, _, _) -> fail "Unsupported tx format"
+      Right _ -> fail "Unsupported tx format"
       Left e -> return $ Left $ UnhandledAutobalanceError e
 
   submitResolvedTx :: ResolvedTx -> ClbT m (Either TxSubmittingError TxId)
-  submitResolvedTx tx = mapRight (getTxId . (\(a, _, _) -> a)) <$> submitResolvedTxRet tx
+  submitResolvedTx tx = mapRight (getTxId . (\(_, a, _, _) -> a)) <$> submitResolvedTxRet tx
 
 instance (Monad m, MonadBlockchainParams (ClbT m)) => MonadTest (ClbT m) where
   getTestWalletSks = return $ map intToCardanoSk [1 .. 10]

src/Cardano/CEM/Monads/L1.hs

@@ -103,7 +103,7 @@ instance MonadSubmitTx L1Runner where
   submitResolvedTx tx = do
     ci <- localNode <$> ask
     cardanoTxBodyFromResolvedTx tx >>= \case
-      Right (body, txInMode, _) ->
+      Right (_, body, txInMode, _) ->
         liftIO $
           submitTxToNodeLocal ci txInMode >>= \case
             SubmitSuccess ->

src/Cardano/CEM/Monads/L1Commons.hs

@@ -23,7 +23,7 @@ import Data.Maybe (mapMaybe)
 cardanoTxBodyFromResolvedTx ::
   (MonadQueryUtxo m, MonadBlockchainParams m) =>
   ResolvedTx ->
-  m (Either (TxBodyErrorAutoBalance Era) (TxBody Era, TxInMode, UTxO Era))
+  m (Either (TxBodyErrorAutoBalance Era) (TxBodyContent BuildTx Era, TxBody Era, TxInMode, UTxO Era))
 cardanoTxBodyFromResolvedTx (MkResolvedTx {..}) = do
   -- (lowerBound, upperBound) <- convertValidityBound validityBound
 
@@ -93,7 +93,7 @@ cardanoTxBodyFromResolvedTx (MkResolvedTx {..}) = do
 
     lift $ recordFee txInsUtxo body
 
-    return (body, txInMode, utxo)
+    return (preBody, body, txInMode, txInsUtxo)
   where
     recordFee txInsUtxo body@(TxBody content) = do
       case txFee content of

src/Cardano/CEM/OffChain.hs

@@ -237,11 +237,11 @@ resolveTxAndSubmit spec = do
 resolveTxAndSubmitRet ::
   (MonadQueryUtxo m, MonadSubmitTx m, MonadIO m) =>
   TxSpec ->
-  m (Either TxResolutionError (TxBody Era, TxInMode, UTxO Era))
+  m (Either TxResolutionError (TxBodyContent BuildTx Era, TxBody Era, TxInMode, UTxO Era))
 resolveTxAndSubmitRet spec = do
   result <- runExceptT $ do
     resolved <- ExceptT $ resolveTx spec
     let result = submitResolvedTxRet resolved
     ExceptT $ first UnhandledSubmittingError <$> result
-  logEvent $ SubmittedTxSpec spec (mapRight (getTxId . (\(a, _, _) -> a)) result)
+  logEvent $ SubmittedTxSpec spec (mapRight (getTxId . (\(_, a, _, _) -> a)) result)
   return result

test/Auction.hs

@@ -5,6 +5,8 @@ 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 ()
@@ -17,6 +19,9 @@ 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
@@ -202,7 +207,7 @@ auctionSpec = describe "Auction" $ do
     Just (CurrentBid currentBid) <- queryScriptState auctionParams
     liftIO $ currentBid `shouldBe` bid1
 
-    (tx, txInMode, utxo) <-
+    (preBody, tx, txInMode, utxo) <-
       submitCheckReturn $
         MkTxSpec
           { actions =
@@ -215,9 +220,20 @@ auctionSpec = describe "Auction" $ do
           , specSigner = bidder1
           }
 
-    -- liftIO $ print tx
+    liftIO $ print tx
+    liftIO $ putStrLn "---"
+
     -- liftIO $ print txInMode
     liftIO $ print utxo
+    liftIO $ putStrLn "---"
+
+    let otx = resolvedTxToOura preBody utxo
+    liftIO $ print $ encode otx
+    liftIO $ putStrLn "---"
+
+    network <- toShelleyNetwork <$> askNetworkId
+    mEvent <- liftIO $ extractEvent @SimpleAuction otx network
+    liftIO $ print mEvent
 
     submitAndCheck $
       MkTxSpec