Skip to content

Commit 3d7e90a

Browse files
author
euonymos
committed
feat: return txs on submission WIP
1 parent e3c5c63 commit 3d7e90a

File tree

17 files changed

+274
-88
lines changed

17 files changed

+274
-88
lines changed

‎cem-script.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ common common-lang
2828

2929
build-depends:
3030
, base
31+
, extra
3132
, mtl
3233
, transformers
3334

‎src-lib/data-spine/Data/Spine.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -12,9 +12,9 @@ import Language.Haskell.TH.Syntax
1212

1313
-- | Definitions
1414

15-
{- | Spine is datatype, which tags constructors of ADT.
16-
| TH deriving utility generates Spines, which are Enums,
17-
| but one could introduce more complex Spine datatypes manually.
15+
{- | Spine is datatype, which tags only constructors of ADT skipping their content.
16+
TH deriving utility generates Spines which are Enums but one could introduce
17+
more complex Spine datatypes manually.
1818
-}
1919
class
2020
( Ord (Spine sop)

‎src/Cardano/CEM/Address.hs‎

Lines changed: 15 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
module Cardano.CEM.Address (
2-
cardanoAddressBech32,
2+
scriptCredential,
33
scriptCardanoAddress,
4+
cardanoAddressBech32,
45
plutusAddressToShelleyAddress,
56
AddressBech32 (MkAddressBech32, unAddressBech32),
67
) where
@@ -14,7 +15,7 @@ import Cardano.Ledger.BaseTypes qualified as Ledger
1415
import Cardano.Ledger.Credential qualified as Cred
1516
import Cardano.Ledger.Hashes qualified
1617
import Cardano.Ledger.Keys qualified as Ledger.Keys
17-
import Data.Data (Proxy (Proxy))
18+
import Data.Proxy (Proxy)
1819
import Data.String (IsString)
1920
import Data.Text qualified as T
2021
import Plutus.Extras qualified
@@ -33,13 +34,22 @@ scriptCardanoAddress ::
3334
Proxy script ->
3435
Cardano.Api.Ledger.Network ->
3536
Either String (Cardano.Api.Address Cardano.Api.ShelleyAddr)
36-
scriptCardanoAddress _ network =
37+
scriptCardanoAddress p network =
3738
plutusAddressToShelleyAddress network
3839
. flip PlutusLedgerApi.V1.Address Nothing
39-
. PlutusLedgerApi.V1.ScriptCredential
40+
. scriptCredential
41+
$ p
42+
43+
scriptCredential ::
44+
forall script.
45+
(Compiled.CEMScriptCompiled script) =>
46+
Proxy script ->
47+
PlutusLedgerApi.V1.Credential
48+
scriptCredential p =
49+
PlutusLedgerApi.V1.ScriptCredential
4050
. Plutus.Extras.scriptValidatorHash
4151
. Compiled.cemScriptCompiled
42-
$ Proxy @script
52+
$ p
4353

4454
plutusAddressToShelleyAddress ::
4555
Cardano.Api.Ledger.Network ->

‎src/Cardano/CEM/Examples/Auction.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
1-
{-# OPTIONS_GHC -Wno-unrecognised-pragmas -ddump-splices #-}
21
{-# LANGUAGE NoPolyKinds #-}
2+
{-# OPTIONS_GHC -Wno-unrecognised-pragmas -ddump-splices #-}
33

44
module Cardano.CEM.Examples.Auction where
55

@@ -37,7 +37,6 @@ data SimpleAuctionStageParams
3737
| CanCloseAt POSIXTime
3838
deriving stock (Prelude.Eq, Prelude.Show)
3939

40-
4140
instance Stages SimpleAuctionStage where
4241
type StageParams SimpleAuctionStage = SimpleAuctionStageParams
4342
stageToOnChainInterval NoControl _ = Interval.always

‎src/Cardano/CEM/Monads.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -109,8 +109,7 @@ data ResolvedTx = MkResolvedTx
109109
, toMint :: TxMintValue BuildTx Era
110110
, interval :: Interval POSIXTime
111111
, additionalSigners :: [PubKeyHash]
112-
, -- FIXME
113-
signer :: ~(SigningKey PaymentKey)
112+
, signer :: ~(SigningKey PaymentKey)
114113
}
115114
deriving stock (Show, Eq)
116115

@@ -141,6 +140,7 @@ data TxResolutionError
141140
-- | Ability to send transaction to chain
142141
class (MonadQueryUtxo m) => MonadSubmitTx m where
143142
submitResolvedTx :: ResolvedTx -> m (Either TxSubmittingError TxId)
143+
submitResolvedTxRet :: ResolvedTx -> m (Either TxSubmittingError (TxBody Era, TxInMode, UTxO Era))
144144

145145
-- | Stuff needed to use monad for local testing
146146
class (MonadSubmitTx m) => MonadTest m where

‎src/Cardano/CEM/Monads/CLB.hs‎

Lines changed: 11 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,9 @@ import Cardano.CEM.Monads.L1Commons
3737
import Cardano.CEM.OffChain (fromPlutusAddressInMonad)
3838
import Control.Monad.Reader (MonadReader (..), ReaderT (..))
3939

40+
import Cardano.Extras (Era)
41+
import Data.Either.Extra (mapRight)
42+
4043
instance (MonadReader r m) => MonadReader r (ClbT m) where
4144
ask = lift ask
4245
local f action = ClbT $ local f $ unwrapClbT action
@@ -88,18 +91,21 @@ instance (Monad m, MonadBlockchainParams (ClbT m)) => MonadQueryUtxo (ClbT m) wh
8891
ByTxIns txIns -> return $ \txIn _ -> txIn `elem` txIns
8992

9093
instance (Monad m, MonadBlockchainParams (ClbT m)) => MonadSubmitTx (ClbT m) where
91-
submitResolvedTx :: ResolvedTx -> ClbT m (Either TxSubmittingError TxId)
92-
submitResolvedTx tx = do
94+
submitResolvedTxRet :: ResolvedTx -> ClbT m (Either TxSubmittingError (TxBody Era, TxInMode, UTxO Era))
95+
submitResolvedTxRet tx = do
9396
cardanoTxBodyFromResolvedTx tx >>= \case
94-
Right (body, TxInMode ShelleyBasedEraBabbage tx') -> do
97+
Right (body, txInMode@(TxInMode ShelleyBasedEraBabbage tx'), utxo) -> do
9598
result <- sendTx tx'
9699
case result of
97-
Success _ _ -> return $ Right $ getTxId body
100+
Success _ _ -> return $ Right (body, txInMode, utxo)
98101
Fail _ validationError ->
99102
return $ Left $ UnhandledNodeSubmissionError validationError
100-
Right (_, _) -> fail "Unsupported tx format"
103+
Right (_, _, _) -> fail "Unsupported tx format"
101104
Left e -> return $ Left $ UnhandledAutobalanceError e
102105

106+
submitResolvedTx :: ResolvedTx -> ClbT m (Either TxSubmittingError TxId)
107+
submitResolvedTx tx = mapRight (getTxId . (\(a, _, _) -> a)) <$> submitResolvedTxRet tx
108+
103109
instance (Monad m, MonadBlockchainParams (ClbT m)) => MonadTest (ClbT m) where
104110
getTestWalletSks = return $ map intToCardanoSk [1 .. 10]
105111

‎src/Cardano/CEM/Monads/L1.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -103,7 +103,7 @@ instance MonadSubmitTx L1Runner where
103103
submitResolvedTx tx = do
104104
ci <- localNode <$> ask
105105
cardanoTxBodyFromResolvedTx tx >>= \case
106-
Right (body, txInMode) ->
106+
Right (body, txInMode, _) ->
107107
liftIO $
108108
submitTxToNodeLocal ci txInMode >>= \case
109109
SubmitSuccess ->

‎src/Cardano/CEM/Monads/L1Commons.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,7 @@ import Data.Maybe (mapMaybe)
2323
cardanoTxBodyFromResolvedTx ::
2424
(MonadQueryUtxo m, MonadBlockchainParams m) =>
2525
ResolvedTx ->
26-
m (Either (TxBodyErrorAutoBalance Era) (TxBody Era, TxInMode))
26+
m (Either (TxBodyErrorAutoBalance Era) (TxBody Era, TxInMode, UTxO Era))
2727
cardanoTxBodyFromResolvedTx (MkResolvedTx {..}) = do
2828
-- (lowerBound, upperBound) <- convertValidityBound validityBound
2929

@@ -93,7 +93,7 @@ cardanoTxBodyFromResolvedTx (MkResolvedTx {..}) = do
9393

9494
lift $ recordFee txInsUtxo body
9595

96-
return (body, txInMode)
96+
return (body, txInMode, utxo)
9797
where
9898
recordFee txInsUtxo body@(TxBody content) = do
9999
case txFee content of

‎src/Cardano/CEM/OffChain.hs‎

Lines changed: 22 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,7 @@ import Cardano.CEM
3333
import Cardano.CEM.Monads
3434
import Cardano.CEM.OnChain (CEMScriptCompiled (..), cemScriptAddress)
3535
import Cardano.Extras
36+
import Data.Either.Extra (mapRight)
3637
import Data.Spine (HasSpine (getSpine))
3738

3839
fromPlutusAddressInMonad ::
@@ -65,8 +66,7 @@ failLeft (Right value) = return value
6566

6667
-- TODO: use regular CEMScript
6768
cemTxOutDatum :: (CEMScriptCompiled script) => TxOut ctx Era -> Maybe (CEMScriptDatum script)
68-
cemTxOutDatum txOut =
69-
fromData =<< toPlutusData <$> getScriptData <$> mTxOutDatum txOut
69+
cemTxOutDatum txOut = fromData . (toPlutusData <$> getScriptData) =<< mTxOutDatum txOut
7070

7171
cemTxOutState :: (CEMScriptCompiled script) => TxOut ctx Era -> Maybe (State script)
7272
cemTxOutState txOut =
@@ -124,7 +124,7 @@ resolveAction
124124
mScriptTxIn = case transitionStage (Proxy :: Proxy script) Map.! getSpine transition of
125125
(_, Nothing, _) -> Nothing
126126
_ -> mScriptTxIn'
127-
mState = cemTxOutState =<< snd <$> mScriptTxIn
127+
mState = cemTxOutState . snd =<< mScriptTxIn
128128
witnesedScriptTxIns =
129129
case mScriptTxIn of
130130
Just (txIn, _) ->
@@ -168,7 +168,7 @@ resolveAction
168168
scriptAddress = cemScriptAddress (Proxy :: Proxy script)
169169
resolveTxIn (MkTxFansC _ (MkTxFanFilter addressSpec _) _) = do
170170
utxo <- lift $ queryUtxo $ ByAddresses [address]
171-
return $ map (\(x, y) -> (withKeyWitness x, y)) $ Map.toList $ unUTxO utxo
171+
return $ map (first withKeyWitness) $ Map.toList $ unUTxO utxo
172172
where
173173
address = addressSpecToAddress scriptAddress addressSpec
174174
compileTxConstraint
@@ -178,7 +178,8 @@ resolveAction
178178
TxOut address' value datum ReferenceScriptNone
179179
return $ case quantor of
180180
ExactlyNFans n -> replicate (fromInteger n) $ compiledTxOut minUtxoValue
181-
FansWithTotalValueOfAtLeast value -> [compiledTxOut $ (convertTxOut $ fromPlutusValue value) <> minUtxoValue]
181+
FansWithTotalValueOfAtLeast value ->
182+
[compiledTxOut $ convertTxOut (fromPlutusValue value) <> minUtxoValue]
182183
where
183184
datum = case filterSpec of
184185
AnyDatum -> TxOutDatumNone
@@ -215,6 +216,10 @@ resolveTx spec = runExceptT $ do
215216
mergedSpec' = head actionsSpecs
216217
mergedSpec = (mergedSpec' :: ResolvedTx) {signer = specSigner spec}
217218

219+
-- liftIO $ do
220+
-- putStr "Resolved spec: "
221+
-- print mergedSpec
222+
218223
return mergedSpec
219224

220225
resolveTxAndSubmit ::
@@ -228,3 +233,15 @@ resolveTxAndSubmit spec = do
228233
ExceptT $ first UnhandledSubmittingError <$> result
229234
logEvent $ SubmittedTxSpec spec result
230235
return result
236+
237+
resolveTxAndSubmitRet ::
238+
(MonadQueryUtxo m, MonadSubmitTx m, MonadIO m) =>
239+
TxSpec ->
240+
m (Either TxResolutionError (TxBody Era, TxInMode, UTxO Era))
241+
resolveTxAndSubmitRet spec = do
242+
result <- runExceptT $ do
243+
resolved <- ExceptT $ resolveTx spec
244+
let result = submitResolvedTxRet resolved
245+
ExceptT $ first UnhandledSubmittingError <$> result
246+
logEvent $ SubmittedTxSpec spec (mapRight (getTxId . (\(a, _, _) -> a)) result)
247+
return result

‎src/Cardano/CEM/OnChain.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@
77

88
module Cardano.CEM.OnChain (
99
CEMScriptCompiled (..),
10+
CEMScriptIsData,
1011
cemScriptAddress,
1112
genericCEMScript,
1213
) where

0 commit comments

Comments
 (0)