diff --git a/.ghci b/.ghci new file mode 100644 index 0000000..e34911c --- /dev/null +++ b/.ghci @@ -0,0 +1,2 @@ +:set -Wunused-binds -Wunused-imports -Worphans +:set -isrc -itest diff --git a/.ghcid b/.ghcid new file mode 100644 index 0000000..d0cad17 --- /dev/null +++ b/.ghcid @@ -0,0 +1 @@ +--reload=cem-script.cabal --command="cabal repl test-suite:cem-sdk-test" -W -T ":main" diff --git a/.gitignore b/.gitignore index 4c9e245..037125f 100644 --- a/.gitignore +++ b/.gitignore @@ -21,3 +21,5 @@ cabal.project.local cabal.project.local~ .HTF/ .ghc.environment.* +devnet/db +haddocks diff --git a/cabal.project b/cabal.project index a77ed01..6a63a2e 100644 --- a/cabal.project +++ b/cabal.project @@ -14,6 +14,18 @@ index-state: , hackage.haskell.org 2023-12-24T05:49:51Z , cardano-haskell-packages 2023-12-24T05:54:15Z +source-repository-package + type: git + location: https://github.com/geniusyield/plutus-simple-model + tag: 0cb63af903a835c73aec662092eb67d228bba9b0 + --sha256: sha256-H56EyRFNdDvLDo9FVeGZyQZ92itQPG39TkMVyEC/xqM= + subdir: + cardano-simple + psm + tests: true +allow-newer: + cardano-ledger-shelley-ma:base + packages: . diff --git a/cem-script.cabal b/cem-script.cabal index 4247591..92b49ee 100644 --- a/cem-script.cabal +++ b/cem-script.cabal @@ -5,7 +5,9 @@ synopsis: Cardano DApp SDK homepage: https://github.com/cem-script author: MLabs maintainer: gregory@mlabs.city -data-files: README.md +data-files: + README.md + data/alonzo-params.json -- @todo #3 Reproduce `cabal repl` and HLS build on another (@adamczykm) computer tested-with: GHC ==9.6.3 @@ -21,10 +23,11 @@ common common-lang -- Options from MLabs styleguide ghc-options: - -Wall -Wcompat -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wredundant-constraints - -Wmissing-export-lists -Wmissing-deriving-strategies - -Wno-redundant-constraints + -- -Wall + -- -Wcompat -Wincomplete-record-updates + -- -Wincomplete-uni-patterns -Wredundant-constraints + -- -Wmissing-export-lists -Wmissing-deriving-strategies + -- -Wno-redundant-constraints if !flag(dev) ghc-options: -Werror @@ -76,6 +79,7 @@ common common-lang TypeOperators TypeSynonymInstances UndecidableInstances + NoPolyKinds if flag(dev) default-extensions: PartialTypeSignatures @@ -89,24 +93,41 @@ common common-onchain , plutus-ledger-api , plutus-tx , plutus-tx-plugin + , template-haskell >= 2.20 + , th-abstraction >= 0.6.0.0 - if flag(dev) - ghc-options: -fplugin-opt PlutusTx.Plugin:defer-errors + -- if flag(dev) + -- ghc-options: -fplugin-opt PlutusTx.Plugin:defer-errors -- Options for Plutus Tx compilations -- (some are enabled additionaly in individual modules) ghc-options: - -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 -fobject-code + -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 + -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-specialize -fno-unbox-small-strict-fields -fno-unbox-strict-fields + -fno-full-laziness + -fno-spec-constr + -fno-strictness + -fno-unbox-small-strict-fields common common-offchain import: common-lang build-depends: + , aeson , bytestring + , pretty-show + , retry , cardano-api + -- , cardano-cli + , cardano-ledger-core + , cardano-ledger-babbage + , cardano-ledger-alonzo + , cardano-ledger-shelley + , ouroboros-consensus-cardano + , cardano-crypto-class , containers , filepath , text @@ -117,16 +138,63 @@ common common-executable import: common-offchain ghc-options: -threaded -rtsopts -library cem-sdk +library data-spine + import: + common-lang + hs-source-dirs: src-lib/data-spine + build-depends: + template-haskell, + singletons, + exposed-modules: + Data.Spine + +library cardano-extras + import: + common-offchain, + common-onchain + hs-source-dirs: + src-lib/cardano-extras + build-depends: + template-haskell, + exposed-modules: + Plutus.Extras + Cardano.Extras + +library import: common-onchain, common-offchain - hs-source-dirs: src/ exposed-modules: Cardano.CEM + Cardano.CEM.Stages Cardano.CEM.Examples.Auction Cardano.CEM.Examples.Compilation + -- Cardano.CEM.Examples.Escrow Cardano.CEM.Examples.Voting Cardano.CEM.Monads + Cardano.CEM.Monads.L1 Cardano.CEM.OnChain + build-depends: + cem-script:data-spine, + cem-script:cardano-extras, + dependent-map, + singletons-th, + -- plutarch, + +test-suite cem-sdk-test + import: + common-onchain, + common-offchain, + type: exitcode-stdio-1.0 + build-depends: + hspec, + cem-script, + QuickCheck, + quickcheck-dynamic, + cem-script:data-spine, + cem-script:cardano-extras, + dependent-map, + random, + hs-source-dirs: test/ + main-is: Main.hs diff --git a/devnet/genesis-byron.json b/devnet/genesis-byron.json index bff40a8..d3246e3 100644 --- a/devnet/genesis-byron.json +++ b/devnet/genesis-byron.json @@ -3,7 +3,7 @@ "k": 2160, "protocolMagic": 42 }, - "startTime": 1706549850, + "startTime": 1708348608, "blockVersionData": { "scriptVersion": 0, "slotDuration": "250", diff --git a/devnet/genesis-byron.json.bak b/devnet/genesis-byron.json.bak deleted file mode 100644 index f6cd9d7..0000000 --- a/devnet/genesis-byron.json.bak +++ /dev/null @@ -1,36 +0,0 @@ -{ - "protocolConsts": { - "k": 2160, - "protocolMagic": 42 - }, - "startTime": 1706549840, - "blockVersionData": { - "scriptVersion": 0, - "slotDuration": "250", - "maxBlockSize": "2000000", - "maxHeaderSize": "2000000", - "maxTxSize": "4096", - "maxProposalSize": "700", - "mpcThd": "20000000000000", - "heavyDelThd": "300000000000", - "updateVoteThd": "1000000000000", - "updateProposalThd": "100000000000000", - "updateImplicit": "10000", - "softforkRule": { - "initThd": "900000000000000", - "minThd": "600000000000000", - "thdDecrement": "50000000000000" - }, - "txFeePolicy": { - "summand": "155381000000000", - "multiplier": "43000000000" - }, - "unlockStakeEpoch": "18446744073709551615" - }, - "bootStakeholders": { - "7a4519c93d7be4577dd85bd524c644e6b809e44eae0457b43128c1c7": 1 - }, - "heavyDelegation": {}, - "nonAvvmBalances": {}, - "avvmDistr": {} -} diff --git a/devnet/genesis-conway.json b/devnet/genesis-conway.json index 4525ef4..5bad6d5 100644 --- a/devnet/genesis-conway.json +++ b/devnet/genesis-conway.json @@ -1,3 +1,38 @@ { - "genDelegs": {} + "genDelegs": {}, + "poolVotingThresholds": { + "pvtCommitteeNormal": 0.51, + "pvtCommitteeNoConfidence": 0.51, + "pvtHardForkInitiation": 0.51, + "pvtMotionNoConfidence": 0.51 + }, + "dRepVotingThresholds": { + "dvtMotionNoConfidence": 0.51, + "dvtCommitteeNormal": 0.51, + "dvtCommitteeNoConfidence": 0.51, + "dvtUpdateToConstitution": 0.51, + "dvtHardForkInitiation": 0.51, + "dvtPPNetworkGroup": 0.51, + "dvtPPEconomicGroup": 0.51, + "dvtPPTechnicalGroup": 0.51, + "dvtPPGovGroup": 0.51, + "dvtTreasuryWithdrawal": 0.51 + }, + "committeeMinSize": 0, + "committeeMaxTermLength": 200, + "govActionLifetime": 10, + "govActionDeposit": 1000000000, + "dRepDeposit": 2000000, + "dRepActivity": 20, + "constitution": { + "anchor": { + "url": "", + "dataHash": "0000000000000000000000000000000000000000000000000000000000000000" + } + }, + "committee": { + "members": { + }, + "quorum": 0 + } } diff --git a/devnet/genesis-shelley.json b/devnet/genesis-shelley.json index af0330d..6944796 100644 --- a/devnet/genesis-shelley.json +++ b/devnet/genesis-shelley.json @@ -1,5 +1,5 @@ { - "epochLength": 432000, + "epochLength": 5, "activeSlotsCoeff": 1.0, "slotLength": 0.1, "securityParam": 2160, @@ -60,6 +60,6 @@ "074a515f7f32bf31a4f41c7417a8136e8152bfb42f06d71b389a6896": "8a219b698d3b6e034391ae84cee62f1d76b6fbc45ddfe4e31e0d4b60" } }, - "systemStart": "2024-01-29T17:37:30Z", + "systemStart": "2024-02-19T13:16:48Z", "updateQuorum": 2 } diff --git a/devnet/genesis-shelley.json.bak b/devnet/genesis-shelley.json.bak deleted file mode 100644 index e666978..0000000 --- a/devnet/genesis-shelley.json.bak +++ /dev/null @@ -1,65 +0,0 @@ -{ - "epochLength": 432000, - "activeSlotsCoeff": 1.0, - "slotLength": 0.1, - "securityParam": 2160, - "genDelegs": {}, - "initialFunds": { - "00813c32c92aad21770ff8001de0918f598df8c06775f77f8e8839d2a0074a515f7f32bf31a4f41c7417a8136e8152bfb42f06d71b389a6896": 900000000000, - "609783be7d3c54f11377966dfabc9284cd6c32fca1cd42ef0a4f1cc45b": 900000000000 - }, - "maxKESEvolutions": 60, - "maxLovelaceSupply": 2000000000000, - "networkId": "Testnet", - "networkMagic": 42, - "protocolParams": { - "a0": 0.0, - "decentralisationParam": 0, - "eMax": 18, - "extraEntropy": { - "tag": "NeutralNonce" - }, - "keyDeposit": 0, - "maxBlockBodySize": 65536, - "maxBlockHeaderSize": 1100, - "maxTxSize": 16384, - "minFeeA": 44, - "minFeeB": 155381, - "minPoolCost": 0, - "minUTxOValue": 0, - "nOpt": 100, - "poolDeposit": 0, - "protocolVersion": { - "major": 7, - "minor": 0 - }, - "rho": 0.1, - "tau": 0.1 - }, - "slotsPerKESPeriod": 129600, - "staking": { - "pools": { - "8a219b698d3b6e034391ae84cee62f1d76b6fbc45ddfe4e31e0d4b60": { - "cost": 0, - "margin": 0.0, - "metadata": null, - "owners": [], - "pledge": 0, - "publicKey": "8a219b698d3b6e034391ae84cee62f1d76b6fbc45ddfe4e31e0d4b60", - "relays": [], - "rewardAccount": { - "credential": { - "key hash": "b6ffb20cf821f9286802235841d4348a2c2bafd4f73092b7de6655ea" - }, - "network": "Testnet" - }, - "vrf": "fec17ed60cbf2ec5be3f061fb4de0b6ef1f20947cfbfce5fb2783d12f3f69ff5" - } - }, - "stake": { - "074a515f7f32bf31a4f41c7417a8136e8152bfb42f06d71b389a6896": "8a219b698d3b6e034391ae84cee62f1d76b6fbc45ddfe4e31e0d4b60" - } - }, - "systemStart": "2024-01-29T17:37:20Z", - "updateQuorum": 2 -} diff --git a/docker-compose.devnet.yaml b/docker-compose.devnet.yaml new file mode 100644 index 0000000..e8015ad --- /dev/null +++ b/docker-compose.devnet.yaml @@ -0,0 +1,20 @@ +services: + cardano-node-devnet: + image: ghcr.io/input-output-hk/cardano-node:8.7.3 + volumes: + - ./devnet:/devnet + environment: + - CARDANO_BLOCK_PRODUCER=true + - CARDANO_SOCKET_PATH=/devnet/node.socket # used by cardano-node + - CARDANO_NODE_SOCKET_PATH=/devnet/node.socket # used by cardano-cli + command: + [ "run" + , "--config", "/devnet/cardano-node.json" + , "--topology", "/devnet/topology.json" + , "--database-path", "/devnet/db" + , "--shelley-kes-key", "/devnet/kes.skey" + , "--shelley-vrf-key", "/devnet/vrf.skey" + , "--shelley-operational-certificate", "/devnet/opcert.cert" + , "--byron-delegation-certificate", "/devnet/byron-delegation.cert" + , "--byron-signing-key", "/devnet/byron-delegate.key" + ] diff --git a/docs/goals_and_soa.md b/docs/goals_and_soa.md index c8324af..547e83e 100644 --- a/docs/goals_and_soa.md +++ b/docs/goals_and_soa.md @@ -18,7 +18,7 @@ are covering our high-level goals. 1. DApp logic as whole (synced-by-construction) 2. Code is free from common security weaknesses by construction (secure-by-construction) -3. Seamplessly emulate and test anything (emulate-anything) +3. Seamlessly emulate and test anything (emulate-anything) 4. Declarativity close to informal specification and bridging lightweight formal methods (declarative-spec) 5. Generally production ready (production-ready) @@ -40,7 +40,7 @@ are covering our high-level goals. ## Reference apps Those are list of open-source DApps, -what we use to demonstrate problems in folloging: +what we use to demonstrate problems in folloving: * Audited production DApps * Agora @@ -167,6 +167,7 @@ real blockchain behaviour may lead to flacky test behaviour. Our script stages abstraction cover all those kind of problems. * @todo #3: document problems with slots + * https://github.com/mlabs-haskell/hydra-auction/issues/236 * @todo #3: bug example diff --git a/prepare-devnet.sh b/prepare-devnet.sh new file mode 100755 index 0000000..7c75e8b --- /dev/null +++ b/prepare-devnet.sh @@ -0,0 +1,4 @@ +TARGETDIR=devnet +sed -i "s/\"startTime\": [0-9]*/\"startTime\": $(date +%s)/" "$TARGETDIR/genesis-byron.json" && \ +sed -i "s/\"systemStart\": \".*\"/\"systemStart\": \"$(date -u +%FT%TZ)\"/" "$TARGETDIR/genesis-shelley.json" +sudo chown -R $USER:$USER ./devnet/ diff --git a/src-lib/cardano-extras/Cardano/Extras.hs b/src-lib/cardano-extras/Cardano/Extras.hs new file mode 100644 index 0000000..f69ccd9 --- /dev/null +++ b/src-lib/cardano-extras/Cardano/Extras.hs @@ -0,0 +1,221 @@ +{- | Various utils to cope with `cardano-api` types +Mainly stolen from `hydra-cardano-api` and some from `atlas` +-} +module Cardano.Extras where + +import Prelude + +import Data.Aeson qualified as Aeson +import Data.Word (Word64) + +import PlutusLedgerApi.V1.Address (Address (..), pubKeyHashAddress) +import PlutusLedgerApi.V1.Credential ( + Credential (..), + StakingCredential (..), + ) +import PlutusLedgerApi.V1.Crypto (PubKeyHash (..)) + +import Cardano.Api (AddressAny (..), AddressInEra (..), AddressTypeInEra (..), AsType (..), AssetId (..), AssetName (..), BabbageEra, BabbageEraOnwards (BabbageEraOnwardsBabbage, BabbageEraOnwardsConway), BuildTx, BuildTxWith (..), ConsensusModeParams (..), EpochSlots (EpochSlots), ExecutionUnits (..), HasTypeProxy (AsType), IsScriptWitnessInCtx (..), IsShelleyBasedEra (..), Key (..), KeyWitnessInCtx (..), NetworkId (..), PaymentKey, PlutusScript, PolicyId (..), Quantity (..), ScriptDatum (..), ScriptRedeemer, ScriptWitness (..), SigningKey (..), TextEnvelopeError (TextEnvelopeAesonDecodeError), TxIn, TxOut (..), TxOutDatum (..), UTxO (unUTxO), Value, WitCtxTxIn, Witness (..), deserialiseFromTextEnvelope, txOutValueToValue, unsafeHashableScriptData, valueFromList, verificationKeyHash) +import Cardano.Api qualified as Cardano +import Cardano.Api.Byron (Hash (..)) +import Cardano.Api.Ledger (StandardCrypto) +import Cardano.Api.Shelley (PlutusScriptOrReferenceInput (..), fromPlutusData, fromShelleyAddrIsSbe) +import Cardano.Crypto.Hash.Class qualified as CC +import Cardano.Ledger.Address qualified as Ledger +import Cardano.Ledger.Babbage qualified as Ledger +import Cardano.Ledger.BaseTypes qualified as Ledger +import Cardano.Ledger.Credential qualified as Ledger +import Cardano.Ledger.Hashes qualified as Ledger +import Cardano.Ledger.Keys qualified as Ledger +import Cardano.Ledger.Plutus.TxInfo qualified as Ledger +import Data.Bifunctor (Bifunctor (..)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Map (elems) +import PlutusLedgerApi.V1 qualified as Plutus +import PlutusLedgerApi.V1.Value (CurrencySymbol (..), TokenName (..), flattenValue) +import PlutusLedgerApi.V2 (ScriptHash (..), ToData (..), adaSymbol, adaToken, toData) +import PlutusTx.Builtins.Class (FromBuiltin (..)) + +-- Common + +type Era = BabbageEra +type LedgerEra = Ledger.BabbageEra StandardCrypto + +type PlutusLang = Cardano.PlutusScriptV2 + +plutusLang :: Cardano.PlutusScriptVersion PlutusLang +plutusLang = Cardano.PlutusScriptV2 + +plutusLangInEra :: + Cardano.ScriptLanguageInEra PlutusLang Era +plutusLangInEra = Cardano.PlutusScriptV2InBabbage + +-- | Parsing + +{- | Interpret some raw 'ByteString' as a particular 'Hash'. + +NOTE: This throws if byte string has a length different that the expected +target digest length. +-} +unsafeHashFromBytes :: + (CC.HashAlgorithm hash) => + ByteString -> + CC.Hash hash a +unsafeHashFromBytes bytes = + case CC.hashFromBytes bytes of + Nothing -> + error $ "unsafeHashFromBytes: failed to convert hash: " <> show bytes + Just h -> + h + +parseSigningKeyTE :: ByteString -> Maybe (SigningKey PaymentKey) +parseSigningKeyTE bs = do + let res = + first TextEnvelopeAesonDecodeError (Aeson.eitherDecodeStrict bs) + >>= deserialiseFromTextEnvelope asSigningKey + case res of + Left _ -> Nothing + Right key -> Just key + where + asSigningKey :: AsType (SigningKey PaymentKey) + asSigningKey = AsSigningKey AsPaymentKey + +-- | Conversions +toPlutusKeyHash :: Hash PaymentKey -> PubKeyHash +toPlutusKeyHash (PaymentKeyHash vkh) = Ledger.transKeyHash vkh + +signingKeyToPKH :: SigningKey PaymentKey -> PubKeyHash +signingKeyToPKH = toPlutusKeyHash . verificationKeyHash . getVerificationKey + +signingKeyToAddress :: SigningKey PaymentKey -> Address +signingKeyToAddress = pubKeyHashAddress . signingKeyToPKH + +fromPlutusAddress :: NetworkId -> Address -> AddressInEra Era +fromPlutusAddress networkId plutusAddress = + fromShelleyAddrIsSbe @Era shelleyBasedEra $ + case (addressCredential, addressStakingCredential) of + (cred, Just (StakingHash stakeCred)) -> + Ledger.Addr network (unsafeCredential cred) . Ledger.StakeRefBase $ unsafeCredential stakeCred + (cred, Just (StakingPtr slot txix certix)) -> + Ledger.Addr network (unsafeCredential cred) . Ledger.StakeRefPtr $ + Ledger.Ptr + (fromInteger slot) + (Ledger.TxIx $ fromInteger txix) + (Ledger.CertIx $ fromInteger certix) + (cred, Nothing) -> + Ledger.Addr network (unsafeCredential cred) Ledger.StakeRefNull + where + network = case networkId of + Testnet _ -> Ledger.Testnet + Mainnet -> Ledger.Mainnet + unsafeCredential = \case + PubKeyCredential (PubKeyHash h) -> + Ledger.KeyHashObj . Ledger.KeyHash . unsafeHashFromBytes $ fromBuiltin h + ScriptCredential (ScriptHash h) -> + Ledger.ScriptHashObj . Ledger.ScriptHash . unsafeHashFromBytes $ fromBuiltin h + + Address {addressCredential, addressStakingCredential} = plutusAddress + +addressInEraToAny :: AddressInEra Era -> AddressAny +addressInEraToAny (AddressInEra ByronAddressInAnyEra a) = AddressByron a +addressInEraToAny (AddressInEra (ShelleyAddressInEra _) a) = AddressShelley a + +{- | Unsafe wrap some bytes as a 'ScriptHash', relying on the fact that Plutus +is using Blake2b_224 for hashing data (according to 'cardano-ledger'). + +Pre-condition: the input bytestring MUST be of length 28. +-} +unsafeScriptHashFromBytes :: + ByteString -> + Cardano.ScriptHash +unsafeScriptHashFromBytes bytes + | BS.length bytes /= 28 = + error $ "unsafeScriptHashFromBytes: pre-condition failed: " <> show (BS.length bytes) <> " bytes." + | otherwise = + Cardano.ScriptHash + . Ledger.ScriptHash + $ unsafeHashFromBytes bytes + +-- | Convert a plutus 'CurrencySymbol' into a cardano-api 'PolicyId'. +fromPlutusCurrencySymbol :: CurrencySymbol -> PolicyId +fromPlutusCurrencySymbol = PolicyId . unsafeScriptHashFromBytes . fromBuiltin . unCurrencySymbol + +-- | Convert a plutus 'Value' into a cardano-api 'Value'. +fromPlutusValue :: Plutus.Value -> Value +fromPlutusValue plutusValue = + valueFromList $ map convertAsset $ flattenValue plutusValue + where + convertAsset (cs, tk, i) + | cs == adaSymbol && tk == adaToken = (AdaAssetId, Quantity i) + | otherwise = (AssetId (fromPlutusCurrencySymbol cs) (toAssetName tk), Quantity i) + + -- toAssetName :: Plutus.TokenName -> AssetName + toAssetName = AssetName . fromBuiltin . unTokenName + +-- | Tx and other stuff construction +type TxInWitness = BuildTxWith BuildTx (Witness WitCtxTxIn Era) + +-- | Attaching mark meaning "TxIn would be witnessed by signing key" +withKeyWitness :: + TxIn -> (TxIn, TxInWitness) +withKeyWitness txIn = + (txIn, BuildTxWith $ KeyWitness KeyWitnessForSpending) + +mkInlineDatum :: (ToData datum) => datum -> TxOutDatum ctx Era +mkInlineDatum x = + TxOutDatumInline BabbageEraOnwardsBabbage $ + unsafeHashableScriptData $ + fromPlutusData $ + toData $ + toBuiltinData x + +{- | Construct a full script witness from a datum, a redeemer and a full +'PlutusScript'. That witness has no execution budget. +-} +mkScriptWitness :: + forall ctx. + PlutusScript PlutusLang -> + ScriptDatum ctx -> + ScriptRedeemer -> + ScriptWitness ctx Era +mkScriptWitness script datum redeemer = + PlutusScriptWitness + plutusLangInEra + plutusLang + (PScript script) + datum + redeemer + (ExecutionUnits 0 0) + +mkInlinedDatumScriptWitness :: + (ToData a) => + PlutusScript PlutusLang -> + a -> + BuildTxWith BuildTx (Witness WitCtxTxIn Era) +mkInlinedDatumScriptWitness script redeemer = + BuildTxWith $ + ScriptWitness scriptWitnessInCtx $ + mkScriptWitness + script + InlineScriptDatum + (unsafeHashableScriptData $ fromPlutusData $ toData redeemer) + +-- | Fields +txOutValue :: TxOut ctx Era -> Value +txOutValue (TxOut _ value _ _) = txOutValueToValue value + +mTxOutDatum :: TxOut ctx Era -> Maybe _ +mTxOutDatum (TxOut _ _ (TxOutDatumInline _ d) _) = Just d +mTxOutDatum _ = Nothing + +utxoValue :: UTxO Era -> Value +utxoValue utxo = foldMap txOutValue $ elems $ unUTxO utxo + +-- | Constants +cardanoModeParams :: ConsensusModeParams +cardanoModeParams = CardanoModeParams $ EpochSlots defaultByronEpochSlots + where + -- NOTE(AB): extracted from Parsers in cardano-cli, this is needed to run in 'cardanoMode' which + -- is the default for cardano-cli + defaultByronEpochSlots = 21600 :: Word64 diff --git a/src-lib/cardano-extras/Plutus/Deriving.hs b/src-lib/cardano-extras/Plutus/Deriving.hs new file mode 100644 index 0000000..c97caab --- /dev/null +++ b/src-lib/cardano-extras/Plutus/Deriving.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +{- | + Module: PlutusTx.Deriving + Copyright: (C) MLabs 2021 + License: Apache 2.0 + Maintainer: Koz Ross + Portability: GHC only + Stability: Experimental + + Taken from here temporarily: + https://github.com/Liqwid-Labs/plutus-extra/blob/master/ + plutus-deriving/src/PlutusTx/Deriving.hs +-} +module Plutus.Deriving (deriveEq) where + +import Prelude + +import Control.Monad (replicateM) +import Language.Haskell.TH ( + Body (NormalB), + Clause (Clause), + Con ( + ForallC, + GadtC, + InfixC, + NormalC, + RecC, + RecGadtC + ), + Dec ( + DataD, + FunD, + InstanceD, + NewtypeD, + PragmaD + ), + Exp (ConE, UInfixE, VarE), + Info (TyConI), + Inline (Inlinable), + Name, + Pat (ConP, VarP, WildP), + Phases (AllPhases), + Pragma (InlineP), + Q, + RuleMatch (FunLike), + TyVarBndr (KindedTV, PlainTV), + Type (AppT, ConT, VarT), + nameBase, + newName, + reify, + ) +import PlutusTx.Prelude qualified as PTx + +{- | Generates a lawful 'PTx.Eq' instance for the type named by the input. This + instance will obey the following laws: + + * Reflexivity (for any @x@, @x == x = True@) + * Symmetry (for any @x, y@, @x == y = y PTx.== x@) + * Transitivity (for any @x, y, z@, if @x == y@ and @y == z@, then @x == z@) + * Substitution (for any @x, y@ and pure @f@, @x == y@ implies @f x == f y@) + + @since 1.0 +-} +deriveEq :: Name -> Q [Dec] +deriveEq name = do + info <- reify name + case info of + TyConI (DataD _ name' tyVars _ constructors _) -> + mkEq name' tyVars constructors + TyConI (NewtypeD _ name' tyVars _ constructor _) -> + mkEq name' tyVars [constructor] + _ -> error $ nameBase name <> " is not a data or newtype-defined type." + +-- Helpers + +mkEq :: Name -> [TyVarBndr _] -> [Con] -> Q [Dec] +mkEq name tyVars constructors = do + let namePreds = mkCtxVar <$> tyVars + let instanceType = mkInstanceType name (fst <$> namePreds) + method <- mkEqMethod constructors + pure [InstanceD Nothing (snd <$> namePreds) instanceType method] + +mkCtxVar :: TyVarBndr _ -> (Name, Type) +mkCtxVar = \case + PlainTV name -> (name, go name) + KindedTV name _ -> (name, go name) + where + go :: Name -> Type + go = AppT (ConT ''PTx.Eq) . VarT + +mkInstanceType :: Name -> [Name] -> Type +mkInstanceType typeName = AppT (ConT ''PTx.Eq) . foldr go (ConT typeName) + where + go :: Name -> Type -> Type + go varName acc = AppT acc (VarT varName) + +mkEqMethod :: [Con] -> Q [Dec] +mkEqMethod constructors = do + let methodInlineable = PragmaD . InlineP '(PTx.==) Inlinable FunLike $ AllPhases + funDef <- + FunD '(PTx.==) <$> case constructors of + [] -> error "Cannot generate Eq for a type with no constructors." + _ -> do + activeClauses <- traverse mkConstructorMatch constructors + let catchAllClause = + Clause + [WildP, WildP] + (NormalB . ConE $ 'PTx.False) + [] + pure $ activeClauses <> [catchAllClause] + pure [methodInlineable, funDef] + +mkConstructorMatch :: Con -> Q Clause +mkConstructorMatch = \case + NormalC name vars -> go name . length $ vars + RecC name vars -> go name . length $ vars + InfixC {} -> + error "Cannot generate Eq for types with infix constructors." + ForallC {} -> + error "Cannot generate Eq for types with existentials." + GadtC {} -> + error "Cannot generate Eq for GADTs." + RecGadtC {} -> + error "Cannot generate Eq for GADTs." + where + go :: Name -> Int -> Q Clause + go name count = do + namesLeft <- replicateM count (newName "x") + namesRight <- replicateM count (newName "y") + let leftPat = ConP name . fmap VarP $ namesLeft + let rightPat = ConP name . fmap VarP $ namesRight + let bod = NormalB $ case zip namesLeft namesRight of + [] -> ConE 'PTx.True + (lName, rName) : names -> + foldr + andEq + (UInfixE (VarE lName) (VarE '(PTx.==)) (VarE rName)) + names + pure . Clause [leftPat, rightPat] bod $ [] + +andEq :: (Name, Name) -> Exp -> Exp +andEq (lName, rName) = + UInfixE (UInfixE (VarE lName) (VarE '(PTx.==)) (VarE rName)) (VarE '(PTx.&&)) diff --git a/src-lib/cardano-extras/Plutus/Extras.hs b/src-lib/cardano-extras/Plutus/Extras.hs new file mode 100644 index 0000000..da11622 --- /dev/null +++ b/src-lib/cardano-extras/Plutus/Extras.hs @@ -0,0 +1,46 @@ +module Plutus.Extras where + +import PlutusTx.Prelude + +import Cardano.Api ( + PlutusScriptVersion (..), + Script (..), + SerialiseAsRawBytes (serialiseToRawBytes), + hashScript, + ) +import Cardano.Api.Shelley (PlutusScript (..)) +import PlutusLedgerApi.Common (SerialisedScript) +import PlutusLedgerApi.V2 (ScriptHash (..), UnsafeFromData (..)) + +import Cardano.Extras + +-- | Signature of an untyped validator script. +type ValidatorType = BuiltinData -> BuiltinData -> BuiltinData -> () + +{- | Wrap a typed validator to get the basic `ValidatorType` signature which can +be passed to `PlutusTx.compile`. +REVIEW: There might be better ways to name this than "wrap" +-} +wrapValidator :: + (UnsafeFromData datum, UnsafeFromData redeemer, UnsafeFromData context) => + (datum -> redeemer -> context -> Bool) -> + ValidatorType +wrapValidator f d r c = + check $ f datum redeemer context + where + datum = unsafeFromBuiltinData d + redeemer = unsafeFromBuiltinData r + context = unsafeFromBuiltinData c +{-# INLINEABLE wrapValidator #-} + +{- | Compute the on-chain 'ScriptHash' for a given serialised plutus script. Use +this to refer to another validator script. +-} +scriptValidatorHash :: SerialisedScript -> ScriptHash +scriptValidatorHash = + ScriptHash + . toBuiltin + . serialiseToRawBytes + . hashScript + . PlutusScript plutusLang + . PlutusScriptSerialised @PlutusLang diff --git a/src-lib/data-spine/Data/Spine.hs b/src-lib/data-spine/Data/Spine.hs new file mode 100644 index 0000000..b1bc50a --- /dev/null +++ b/src-lib/data-spine/Data/Spine.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE PolyKinds #-} + +module Data.Spine where + +import Prelude + +import Control.Monad +import Control.Monad.Reader (MonadReader (..)) +import GHC.Records +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Data.Singletons + +-- | Definitions + +{- | Spine is datatype, which tags constructors of ADT. +| TH deriving utility generates Spines, which are Enums, +| but one could introduce more complex Spine datatypes manually. +-} +class + ( Ord (Spine sop) + ) => + HasSpine sop + where + type Spine sop + getSpine :: sop -> Spine sop + +-- instance (SingI sop1, SingI sop2) => SingI (sop1, sop2) where + +instance (HasSpine sop1, HasSpine sop2) => HasSpine (sop1, sop2) where + type Spine (sop1, sop2) = (Spine sop1, Spine sop2) + getSpine (d1, d2) = (getSpine d1, getSpine d2) + +-- TODO: mkOfSpine, using Sing + +-- | Newtype encoding sop value of fixed known spine +newtype OfSpine (x :: Spine datatype) = UnsafeMkOfSpine {getValue :: datatype} + +-- matchOfSpine :: sop -> ... +-- matchOfSpineDMap :: sop -> DMap Spine (OfSpine -> a) +-- mkOfSpine :: sop -> Some .. OfSpine + +-- TODO: move to module + +{- | This class has same behaviour as `MonadReader` storing some record. +| The difference is that you may not have real record stored. +-} +class (Monad m) => MonadRecord record m where + askField :: forall label a. (HasField label record a) => m a + default askField :: + forall label a. + (MonadReader record m, HasField label record a) => + m a + askField = getField @label <$> ask @record + +-- | Deriving utils +addSuffix :: Name -> String -> Name +addSuffix (Name (OccName name) flavour) suffix = + Name (OccName $ name <> suffix) flavour + +reifyDatatype :: Name -> Q (Name, [Name]) +reifyDatatype ty = do + (TyConI tyCon) <- reify ty + (name, cs :: [Con]) <- + case tyCon of + DataD _ n _ _ cs _ -> pure (n, cs) + NewtypeD _ n _ _ cs _ -> pure (n, [cs]) + _ -> fail "deriveTags: only 'data' and 'newtype' are supported" + csNames <- mapM consName cs + return (name, csNames) + +consName :: (MonadFail m) => Con -> m Name +consName cons = + case cons of + NormalC n _ -> return n + RecC n _ -> return n + _ -> fail "deriveTags: constructor names must be NormalC or RecC (See https://hackage.haskell.org/package/template-haskell-2.20.0.0/docs/src/Language.Haskell.TH.Syntax.html#Con)" + +deriveTags :: Name -> String -> [Name] -> Q [Dec] +deriveTags ty suff classes = do + (tyName, csNames) <- reifyDatatype ty + -- XXX: Quasi-quote splice does not work for case matches list + let cs = map (\name -> NormalC (addSuffix name suff) []) csNames + v = + DataD [] (addSuffix tyName suff) [] Nothing cs [DerivClause (Just StockStrategy) (ConT <$> classes)] + pure [v] + +deriveMapping :: Name -> String -> Q Exp +deriveMapping ty suff = do + (tyName, csNames) <- reifyDatatype ty + -- XXX: Quasi-quote splice does not work for case matches list + let + matches = + map + (\name -> Match (RecP name []) (NormalB (ConE (addSuffix name suff))) []) + csNames + return $ LamCaseE matches + +{- | Derives `HasSpine` +| Usage: `$(deriveSpine ''HydraEvent)` +-} +deriveSpine :: Name -> Q [Dec] +deriveSpine name = do + info <- reify name + let + suffix = "Spine" + spineName = addSuffix name suffix + spineTypeQ = reifyType spineName + spineDec <- deriveTags name suffix [''Eq, ''Ord, ''Enum] + -- TODO: derive Sing + -- TODO: derive HasField (OfSpine ...) + + decls <- + [d| + instance HasSpine $(conT name) where + type Spine $(conT name) = $(conT spineName) + getSpine = $(deriveMapping name suffix) + |] + return $ spineDec <> decls diff --git a/src/Cardano/CEM.hs b/src/Cardano/CEM.hs index 478d132..185ac77 100644 --- a/src/Cardano/CEM.hs +++ b/src/Cardano/CEM.hs @@ -1,68 +1,161 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoPolyKinds #-} + module Cardano.CEM where -import Prelude +import PlutusTx.IsData (toData) +import PlutusTx.Prelude +import Prelude (Show) +import Prelude qualified + +import Data.Data (Proxy) +import Data.Map qualified as Map -import PlutusLedgerApi.V1.Address (Address) +import PlutusLedgerApi.V1.Address (Address, pubKeyHashAddress) import PlutusLedgerApi.V1.Crypto (PubKeyHash) import PlutusLedgerApi.V2 ( - BuiltinByteString, - Interval (..), - POSIXTime (..), + BuiltinData (..), + Data (..), + FromData (..), + ToData (..), Value, - always, + fromData, ) +import PlutusTx.Show.TH (deriveShow) --- Constraints and filters +import Cardano.CEM.Stages +import Data.Spine -data TxFanFilter script - = Anything - | BySameCEM (State script) - | ByAddress Address +data AddressSpec + = ByAddress Address | ByPubKey PubKeyHash - | ByDatum BuiltinByteString - | And [TxFanFilter script] - | Or [TxFanFilter script] + | BySameScript + deriving stock (Show, Prelude.Eq) + +addressSpecToAddress :: Address -> AddressSpec -> Address +addressSpecToAddress ownAddress addressSpec = case addressSpec of + ByAddress address -> address + ByPubKey pubKey -> pubKeyHashAddress pubKey + BySameScript -> ownAddress + +data TxFanFilter script = MkTxFanFilter + { address :: AddressSpec + , rest :: TxFanFilter' script + } + deriving stock (Show, Prelude.Eq) +data TxFanFilter' script + = Anything + | -- TODO + BySameCEM BuiltinData + | ByDatum BuiltinData + deriving stock (Show, Prelude.Eq) + +{-# INLINEABLE bySameCEM #-} +-- TODO: rename +bySameCEM :: + (ToData (State script), CEMScript script) => + State script -> + TxFanFilter' script +bySameCEM = BySameCEM . toBuiltinData + +-- TODO: use natural numbers data Quantor = Exist Integer | SumValueEq Value data TxFanKind = In | InRef | Out + deriving stock (Prelude.Eq, Prelude.Show) -data TxFanConstraint script - = MkTxFanC TxFanKind (TxFanFilter script) Quantor - --- Stages - --- This covers constraints on blockchain slot time, --- used by both on- and off-chain code -class Stages stage where - data StageParams stage - stageToOnChainInterval :: StageParams stage -> stage -> Interval POSIXTime - --- Common - -data SingleStage = Always - -instance Stages SingleStage where - data StageParams SingleStage = NoSingleStageParams - stageToOnChainInterval _ Always = always +data TxFanConstraint script = MkTxFanC + { txFanCKind :: TxFanKind + , txFanCFilter :: TxFanFilter script + , txFanCQuantor :: Quantor + } -- Main API -class (Stages (Stage script)) => CEMScript script where +class + ( HasSpine (Transition script) + , HasSpine (State script) + , Stages (Stage script) + ) => + CEMScript script + where + -- | `Params` is immutable part of script Datum, + -- | it should be used to encode all + type Params script = params | params -> script + + -- | `Stage` is datatype encoding all `Interval`s specified by script. + -- | `Stage` logic is encoded by separate `Stages` type class. + -- | It have separate `StageParams` datatype, + -- | which is stored immutable in script Datum as well. type Stage script - data Params script - -- This is in fact just a script Datum - data State script + -- | `State` is changing part of script Datum. + -- | It is in + type State script = params | params -> script + + -- | Transitions for deterministic CEM-machine + type Transition script = transtion | transtion -> script - -- Transitions for deterministic CEM-machine - data Transition script + -- | Each kind of Transition has statically associated Stage and State spine + transitionStage :: + Proxy script -> + Map.Map + (Spine (Transition script)) + (Stage script, Maybe (Spine (State script))) -- This functions define domain logic - transitionSpec :: Params script -> State script -> Transition script -> Either String (TransitionSpec script) + transitionSpec :: + Params script -> + Maybe (State script) -> + Transition script -> + Either BuiltinString (TransitionSpec script) data TransitionSpec script = MkTransitionSpec - { сonstraints :: [TxFanConstraint script] + { constraints :: [TxFanConstraint script] , signers :: [PubKeyHash] - , stage :: Stage script } + +data CEMParams script = MkCEMParams + { scriptParams :: Params script + , stagesParams :: StageParams (Stage script) + } + +deriving stock instance + ( Show (Params script) + , (Show (StageParams (Stage script))) + ) => + (Show (CEMParams script)) + +deriving stock instance + ( Prelude.Eq (Params script) + , (Prelude.Eq (StageParams (Stage script))) + ) => + (Prelude.Eq (CEMParams script)) + +-- TODO: doc +type CEMScriptDatum script = + (StageParams (Stage script), Params script, State script) + +-- Bunch of conditional `IsData` instances +-- Plutus TH utils does not work for that case + +instance + (ToData (Params script), ToData (StageParams (Stage script))) => + ToData (CEMParams script) + where + toBuiltinData (MkCEMParams {..}) = + BuiltinData $ List [toData scriptParams, toData stagesParams] + +instance + (FromData (Params script), FromData (StageParams (Stage script))) => + FromData (CEMParams script) + where + fromBuiltinData (BuiltinData (List [scriptParams, stagesParams])) = + MkCEMParams <$> fromData scriptParams <*> fromData stagesParams + fromBuiltinData _ = Nothing + +-- TH deriving done at end of file for GHC staging reasons + +deriveShow ''TxFanKind +deriveShow ''TxFanFilter' diff --git a/src/Cardano/CEM/Examples.hs b/src/Cardano/CEM/Examples.hs index b28b04f..e69de29 100644 --- a/src/Cardano/CEM/Examples.hs +++ b/src/Cardano/CEM/Examples.hs @@ -1,3 +0,0 @@ - - - diff --git a/src/Cardano/CEM/Examples/Auction.hs b/src/Cardano/CEM/Examples/Auction.hs index c141c2e..bf1c6d2 100644 --- a/src/Cardano/CEM/Examples/Auction.hs +++ b/src/Cardano/CEM/Examples/Auction.hs @@ -1,15 +1,24 @@ +{-# LANGUAGE NoPolyKinds #-} + module Cardano.CEM.Examples.Auction where -import PlutusTx.Prelude +import Prelude qualified -import Cardano.CEM -import Cardano.CEM.OnChain +import Data.Data (Proxy (..)) +import Data.Map qualified as Map import PlutusLedgerApi.V1.Crypto (PubKeyHash) -import PlutusLedgerApi.V1.Interval (always, from, to) +import PlutusLedgerApi.V1.Interval qualified as Interval import PlutusLedgerApi.V1.Time (POSIXTime) import PlutusLedgerApi.V1.Value (CurrencySymbol (..), TokenName (..), singleton) -import PlutusLedgerApi.V2 (Value) +import PlutusLedgerApi.V2 (Address, ToData, Value) +import PlutusTx qualified +import PlutusTx.Prelude +import PlutusTx.Show.TH (deriveShow) + +import Cardano.CEM +import Cardano.CEM.Stages +import Data.Spine -- Simple no-deposit auction @@ -19,88 +28,150 @@ data Bet = MkBet { better :: PubKeyHash , betAmount :: Integer } + deriving stock (Prelude.Eq, Prelude.Show) -data SimpleAuctionStages = Open | Closed +data SimpleAuctionStage = Open | Closed + deriving stock (Prelude.Eq, Prelude.Show) -instance Stages SimpleAuctionStages where - data StageParams SimpleAuctionStages - = NoControl - | CanCloseAt POSIXTime - stageToOnChainInterval NoControl _ = always +data SimpleAuctionStageParams + = NoControl + | CanCloseAt POSIXTime + deriving stock (Prelude.Eq, Prelude.Show) + +instance Stages SimpleAuctionStage where + type StageParams SimpleAuctionStage = SimpleAuctionStageParams + stageToOnChainInterval NoControl _ = Interval.always -- Example: logical error - stageToOnChainInterval (CanCloseAt time) Open = to time - stageToOnChainInterval (CanCloseAt time) Closed = from time + stageToOnChainInterval (CanCloseAt time) Open = Interval.to time + stageToOnChainInterval (CanCloseAt time) Closed = Interval.from time + +data SimpleAuctionState + = NotStarted + | CurrentBet Bet + | Winner Bet + deriving stock (Prelude.Eq, Prelude.Show) + +data SimpleAuctionParams = MkAuctionParams + { seller :: PubKeyHash + , lot :: Value + } + deriving stock (Prelude.Eq, Prelude.Show) + +data SimpleAuctionTransition + = Create + | Start + | MakeBet Bet + | Close + | -- TODO: discuss detirminancy + Buyout {payingFrom :: Address} + deriving stock (Prelude.Eq, Prelude.Show) + +PlutusTx.unstableMakeIsData ''Bet +PlutusTx.unstableMakeIsData 'MkAuctionParams +PlutusTx.unstableMakeIsData 'NotStarted +PlutusTx.unstableMakeIsData 'MakeBet +PlutusTx.unstableMakeIsData ''SimpleAuctionStage +PlutusTx.unstableMakeIsData ''SimpleAuctionStageParams +deriveShow ''SimpleAuction + +deriveSpine ''SimpleAuctionTransition +deriveSpine ''SimpleAuctionState instance CEMScript SimpleAuction where - type Stage SimpleAuction = SimpleAuctionStages - data Params SimpleAuction = MkVotingParams - { seller :: PubKeyHash - , lot :: Value - } - data State SimpleAuction - = NotStarted - | CurrentBet Bet - | Winner Bet - data Transition SimpleAuction - = Start - | MakeBet Bet - | Close - | Buyout + type Stage SimpleAuction = SimpleAuctionStage + type Params SimpleAuction = SimpleAuctionParams + + type State SimpleAuction = SimpleAuctionState + + type Transition SimpleAuction = SimpleAuctionTransition + + transitionStage Proxy = + Map.fromList + [ (CreateSpine, (Open, Nothing)) + , (StartSpine, (Open, Just NotStartedSpine)) + , (MakeBetSpine, (Open, Just CurrentBetSpine)) + , (CloseSpine, (Closed, Just CurrentBetSpine)) + , (BuyoutSpine, (Closed, Just WinnerSpine)) + ] + {-# INLINEABLE transitionSpec #-} transitionSpec params state transition = case (state, transition) of - (NotStarted, Start) -> + (Nothing, Create) -> + Right + $ MkTransitionSpec + { constraints = + [ MkTxFanC In (MkTxFanFilter (ByPubKey $ seller params) Anything) (SumValueEq $ lot params) + , MkTxFanC Out (MkTxFanFilter BySameScript (bySameCEM NotStarted)) (SumValueEq $ lot params) + ] + , signers = [seller params] + } + (Just NotStarted, Start) -> Right $ MkTransitionSpec - { stage = Open - , сonstraints = - [ MkTxFanC In (ByPubKey (seller params)) (SumValueEq $ lot params) - , MkTxFanC Out (BySameCEM (CurrentBet initialBet)) (Exist 1) + { constraints = + [ MkTxFanC + In + (MkTxFanFilter (ByPubKey (seller params)) Anything) + (SumValueEq $ lot params) + , MkTxFanC + Out + (MkTxFanFilter BySameScript (bySameCEM (CurrentBet initialBet))) + (Exist 1) ] , signers = [seller params] } - (CurrentBet currentBet, MakeBet newBet) -> + (Just (CurrentBet currentBet), MakeBet newBet) -> -- Example: could be parametrized with param or typeclass if betAmount newBet > betAmount currentBet then Right $ MkTransitionSpec - { stage = Open - , сonstraints = - saveLotConstraints - <> [ MkTxFanC Out (BySameCEM (CurrentBet newBet)) (Exist 1) - ] + { constraints = + [ MkTxFanC + Out + (MkTxFanFilter BySameScript (bySameCEM (CurrentBet newBet))) + (SumValueEq $ lot params) + ] , signers = [better newBet] } else Left "Wrong bet amount" - (CurrentBet currentBet, Close) -> + (Just (CurrentBet currentBet), Close) -> Right $ MkTransitionSpec - { stage = Closed - , сonstraints = + { constraints = saveLotConstraints - <> [ MkTxFanC Out (BySameCEM (Winner currentBet)) (Exist 1) + <> [ MkTxFanC Out (MkTxFanFilter BySameScript (bySameCEM (Winner currentBet))) (Exist 1) ] , signers = [seller params] } - (Winner winnerBet, Buyout) -> + (Just (Winner winnerBet), Buyout {payingFrom}) -> Right $ MkTransitionSpec - { stage = Closed - , сonstraints = + { constraints = [ -- Example: In constraints redundant for on-chain - MkTxFanC In Anything (SumValueEq $ lot params) - , MkTxFanC Out (ByPubKey (better winnerBet)) (SumValueEq $ lot params) - , MkTxFanC In (ByPubKey (better winnerBet)) (SumValueEq $ betAdaValue winnerBet) - , MkTxFanC Out (ByPubKey (seller params)) (SumValueEq $ betAdaValue winnerBet) + MkTxFanC + Out + (MkTxFanFilter (ByPubKey (better winnerBet)) Anything) + (SumValueEq $ lot params) + , MkTxFanC + In + (MkTxFanFilter (ByPubKey (better winnerBet)) Anything) + (SumValueEq $ betAdaValue winnerBet) + , MkTxFanC + Out + (MkTxFanFilter (ByPubKey (seller params)) Anything) + (SumValueEq $ betAdaValue winnerBet) ] , signers = [better winnerBet] } - _ -> Left "Incorrect stage for transition" + _ -> Left "Incorrect state for transition" where initialBet = MkBet (seller params) 0 saveLotConstraints = - [ MkTxFanC In Anything (SumValueEq $ lot params) - , MkTxFanC Out Anything (SumValueEq $ lot params) + [ MkTxFanC + Out + (MkTxFanFilter BySameScript Anything) + (SumValueEq $ lot params) ] betAdaValue = adaValue . betAmount adaValue = diff --git a/src/Cardano/CEM/Examples/Compilation.hs b/src/Cardano/CEM/Examples/Compilation.hs new file mode 100644 index 0000000..909bf57 --- /dev/null +++ b/src/Cardano/CEM/Examples/Compilation.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE NoPolyKinds #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.CEM.Examples.Compilation where + +import PlutusTx qualified + +import Data.Proxy (Proxy (..)) + +import PlutusLedgerApi.V2 (ScriptContext (ScriptContext), serialiseCompiledCode) + +import Cardano.Api (PlutusScript) +import Cardano.CEM +import Cardano.CEM.Examples.Auction +import Cardano.CEM.Examples.Voting +import Cardano.CEM.OnChain (CEMScriptCompiled (..), genericCEMScript) +import Cardano.CEM.Stages (SingleStage) +import Plutus.Extras + +compiledAuction = $(PlutusTx.compileUntyped (genericCEMScript ''SimpleAuction ''SimpleAuctionStage)) + +instance CEMScriptCompiled SimpleAuction where + {-# INLINEABLE cemScriptCompiled #-} + cemScriptCompiled Proxy = + serialiseCompiledCode compiledAuction + +compiledVoting = $(PlutusTx.compileUntyped (genericCEMScript ''SimpleVoting ''SingleStage)) + +instance CEMScriptCompiled SimpleVoting where + {-# INLINEABLE cemScriptCompiled #-} + cemScriptCompiled Proxy = + serialiseCompiledCode compiledVoting diff --git a/src/Cardano/CEM/Examples/Escrow.hs b/src/Cardano/CEM/Examples/Escrow.hs index 9f62ce2..35ca781 100644 --- a/src/Cardano/CEM/Examples/Escrow.hs +++ b/src/Cardano/CEM/Examples/Escrow.hs @@ -1,75 +1,173 @@ -module Cardano.CEM.Examples where +module Cardano.CEM.Examples.Escrow where -import Prelude +import PlutusTx qualified +import PlutusTx.Prelude -import Data.Proxy +import PlutusLedgerApi.V1 (Address, Value) +import PlutusLedgerApi.V1.Crypto (PubKeyHash) import Cardano.CEM - +import Cardano.CEM.Stages +import Cardano.CEM.OnChain (CEMScriptIsData, IsData) +import PlutusLedgerApi.V1.Value (AssetClass, assetClassValue) +import PlutusTx.IsData (FromData, ToData) +import qualified PlutusTx as Plutus -- Generic escrows -class Escrow script where - data EscrowLockedState script - data EscrowUnlock script - unlockConstraints :: - EscrowLockedState script -> EscrowUnlock script -> Maybe [TxFanConstraint] - -instance Escrow script => CEMScript script where - type Stage script = SingleStage - data State script = Locked (EscrowLockedState script) - data Transition script = UnLock (EscrowUnlock script) - - transitionSpec transition = case transition of - UnLock escrowState -> MkTransitionSpec { - transitionStates = (Locked, Nothing), - сonstraints = unlockConstraints escrowState, - transitionStage = Single - } +-- TODO: move to Commons +class Escrow escrow where + data EscrowParams escrow + data EscrowUnlock escrow + unlockConstraints :: + EscrowParams escrow -> + EscrowUnlock escrow -> + Either BuiltinString (TransitionSpec (EscrowScript escrow)) + +newtype EscrowScript escrow = MkEscrowScript escrow + +instance + (Escrow escrow, IsData (EscrowUnlock escrow)) => + CEMScript (EscrowScript escrow) + where + type Stage (EscrowScript escrow) = SingleStage + data Params (EscrowScript escrow) = MkEscrowParams (EscrowParams escrow) + data State (EscrowScript escrow) = Locked + data Transition (EscrowScript escrow) = UnLock (EscrowUnlock escrow) + + transitionSpec (MkEscrowParams params) (Just Locked) (UnLock unlock) = + unlockConstraints params unlock + + +-- TODO +instance FromData (EscrowParams escrow) => FromData (Params (EscrowScript escrow)) where +instance ToData (EscrowParams escrow) => ToData (Params (EscrowScript escrow)) where +Plutus.unstableMakeIsData 'Locked +-- Plutus.unstableMakeIsData 'UnLock -- Specific escrows data UnboundedEscrow instance Escrow UnboundedEscrow where - data EscrowUnlock UnboundedEscrow - unlockConstraints _ = [] + data EscrowParams UnboundedEscrow = MkUnboundedEscrowParams + data EscrowUnlock UnboundedEscrow = UnboundedEscrowUnlock + unlockConstraints _ _ = + Right $ + MkTransitionSpec + { constraints = [] + , signers = [] + , stage = Always + } data UserLockedEscrow instance Escrow UserLockedEscrow where - data EscrowUnlock UserLockedEscrow - unlockConstraints _ = [TxSigned "TODO_USER_PARAM"] + data EscrowParams UserLockedEscrow = MkUserLockedState + { unlockingUser :: PubKeyHash + } + data EscrowUnlock UserLockedEscrow = MkUserUnlock + unlockConstraints state _ = + Right $ + MkTransitionSpec + { constraints = [] + , signers = [unlockingUser state] + , stage = Always + } -data TokenLockedEscrow +PlutusTx.unstableMakeIsData 'MkUserLockedState +PlutusTx.unstableMakeIsData 'MkUserUnlock -{- +data TokenLockedEscrow instance Escrow TokenLockedEscrow where - data EscrowUnlock TokenLockedEscrow = NoData - unlockConstraints _ = [TxInC kind "TODO_TOKEN_PARAM"] - where - kind = InRef - - --} + data EscrowParams TokenLockedEscrow = MkTokenLockedState + { unlockingToken :: AssetClass + } + data EscrowUnlock TokenLockedEscrow = MkTokenUnlock + { unlocker :: PubKeyHash + } + unlockConstraints params (MkTokenUnlock {unlocker}) = + Right $ + MkTransitionSpec + { constraints = + [ MkTxFanC + InRef + (MkTxFanFilter (ByPubKey unlocker) Anything) + (SumValueEq singleToken) + -- TODO: unlocker? + ] + , signers = [unlocker] + , stage = Always + } + where + singleToken = assetClassValue (unlockingToken params) 1 data HashLockedEscrow -{- - instance Escrow HashLockedEscrow where - data EscrowUnlock UnboundedEscrow = NoData - unlockConstraints _ = [] + data EscrowParams HashLockedEscrow = MkHashLockedState + { secretHash :: BuiltinByteString + } + data EscrowUnlock HashLockedEscrow = MkHashLockedUnlock + { secretValue :: BuiltinByteString + } + unlockConstraints state unlock = + if blake2b_256 (secretValue unlock) == secretHash state + then + Right $ + MkTransitionSpec + { constraints = [] + , signers = [] + , stage = Always + } + else Left "Wrong hash" + +data FixedSwapEscrow + +instance Escrow FixedSwapEscrow where + data EscrowParams FixedSwapEscrow = MkSwapState + { creator :: Address + , lockedValue :: Value + , toSwapValue :: Value + } + data EscrowUnlock FixedSwapEscrow = FixedSwapUnlock + { swappingActor :: Address + } + unlockConstraints state unlock = + Right $ + MkTransitionSpec + { constraints = + [ -- TODO: balance, need to sign? + MkTxFanC Out (MkTxFanFilter (ByAddress (creator state)) Anything) (SumValueEq (toSwapValue state)) + , MkTxFanC Out (MkTxFanFilter (ByAddress (swappingActor unlock)) Anything) (SumValueEq (lockedValue state)) + ] + , signers = [] + , stage = Always + } --} +data FeeDistributionEscrow -data SwapEscrow +instance Escrow FeeDistributionEscrow where + data EscrowParams FeeDistributionEscrow = MkFeeDistributionParams + { feeReceivers :: [Address] + } -{- -instance Escrow SwapEscrow where - data EscrowUnlock SwapEscrow = NoData - unlockConstraints _ = [ - TxInC In "TODO_TOKEN_PARAM" - ] --} + -- TODO: explain + data EscrowUnlock FeeDistributionEscrow = MkFeeDistributionUnlock + { amountPerFeeReceiver :: Value + } + + unlockConstraints params unlock = + Right $ + MkTransitionSpec + { constraints = map receiverConstraint $ feeReceivers params + , signers = [] + , stage = Always + } + where + receiverConstraint address = + MkTxFanC + Out + (MkTxFanFilter (ByAddress address) Anything) + (SumValueEq $ amountPerFeeReceiver unlock) diff --git a/src/Cardano/CEM/Examples/Voting.hs b/src/Cardano/CEM/Examples/Voting.hs index 2d26a1f..70cc479 100644 --- a/src/Cardano/CEM/Examples/Voting.hs +++ b/src/Cardano/CEM/Examples/Voting.hs @@ -1,61 +1,107 @@ +{-# OPTIONS_GHC -Wno-overlapping-patterns #-} + module Cardano.CEM.Examples.Voting where -import Prelude +import PlutusTx.Prelude +import Prelude qualified -import Cardano.CEM -import Cardano.CEM.OnChain +import Data.Map qualified as Map import PlutusLedgerApi.V1.Crypto (PubKeyHash) import PlutusLedgerApi.V2 (Value) +import PlutusTx qualified +import PlutusTx.Show.TH (deriveShow) + +import Cardano.Api.Ledger (Vote) +import Cardano.CEM +import Cardano.CEM.Stages +import Data.Spine (deriveSpine) -- Voting data SimpleVoting -data VoteValue = Yes | No | Abstain deriving stock (Eq) +data VoteValue = Yes | No | Abstain + +instance Eq VoteValue where + Yes == Yes = True + No == No = True + Abstain == Abstain = True + _ == _ = False + +-- TODO data JuryPolicy = Anyone | FixedJuryList [PubKeyHash] | WithToken Value -- Stub -data VoteStorage + +data VoteStorage = MkVoteStorage + emptyVoteStorage :: VoteStorage -emptyVoteStorage = error "Implementation is not important for example" -addVote :: PubKeyHash -> VoteValue -> VoteStorage -> Either String VoteStorage -addVote = error "Implementation is not important for example" +emptyVoteStorage = MkVoteStorage + +addVote :: PubKeyHash -> VoteValue -> VoteStorage -> Either BuiltinString VoteStorage +addVote = traceError "Implementation is not important for example" + countVotes :: VoteStorage -> VoteValue -countVotes = error "Implementation is not important for example" +countVotes = traceError "Implementation is not important for example" + +data SimpleVotingParams = MkVotingParams + { disputeDescription :: BuiltinByteString + , creator :: PubKeyHash + , juryPolicy :: JuryPolicy + , abstainAllowed :: Bool + } + +data SimpleVotingState + = NotStarted + | InProgress VoteStorage + | Finalized VoteValue + +data SimpleVotingTransition + = Start + | Vote PubKeyHash VoteValue + | Finalize + +PlutusTx.unstableMakeIsData ''VoteStorage +PlutusTx.unstableMakeIsData ''VoteValue +PlutusTx.unstableMakeIsData ''JuryPolicy +PlutusTx.unstableMakeIsData ''SimpleVotingState +PlutusTx.unstableMakeIsData ''SimpleVotingParams +PlutusTx.unstableMakeIsData ''SimpleVotingTransition + +deriveShow ''SimpleVoting + +deriveSpine ''SimpleVotingTransition +deriveSpine ''SimpleVotingState instance CEMScript SimpleVoting where type Stage SimpleVoting = SingleStage - data Params SimpleVoting = MkVotingParams - { disputeDescription :: String - , creator :: PubKeyHash - , juryPolicy :: JuryPolicy - , abstainAllowed :: Bool - } - data State SimpleVoting - = NotStarted - | InProgress VoteStorage - | Finalized VoteValue - data Transition SimpleVoting - = Start - | Vote PubKeyHash VoteValue - | Finalize + type Params SimpleVoting = SimpleVotingParams + type State SimpleVoting = SimpleVotingState + type Transition SimpleVoting = SimpleVotingTransition + + transitionStage _ = + Map.fromList + [ (StartSpine, (Always, Just NotStartedSpine)) + , (VoteSpine, (Always, Just InProgressSpine)) + , (FinalizeSpine, (Always, Just InProgressSpine)) + ] + {-# INLINEABLE transitionSpec #-} transitionSpec params state transition = case (state, transition) of - (NotStarted, Start) -> - Right $ - MkTransitionSpec - { stage = Always - , сonstraints = + (Just NotStarted, Start) -> + Right + $ MkTransitionSpec + { constraints = [ MkTxFanC Out - (BySameCEM $ InProgress emptyVoteStorage) + (MkTxFanFilter BySameScript (bySameCEM $ InProgress emptyVoteStorage)) (Exist 1) ] , signers = [creator params] } - (InProgress votes, Vote jury vote) -> do + (Just (InProgress votes), Vote jury vote) -> do -- Check if you can vote case juryPolicy params of FixedJuryList allowedJury -> @@ -70,31 +116,35 @@ instance CEMScript SimpleVoting where let allowedToVoteConstraints = case juryPolicy params of WithToken value -> - [ MkTxFanC InRef (ByPubKey jury) (SumValueEq value) + [ MkTxFanC + InRef + (MkTxFanFilter (ByPubKey jury) Anything) + (SumValueEq value) ] _ -> [] -- Update state newVoteStorage <- addVote jury vote votes - Right $ - MkTransitionSpec - { stage = Always - , сonstraints = + Right + $ MkTransitionSpec + { constraints = [ MkTxFanC Out - (BySameCEM $ InProgress newVoteStorage) + (MkTxFanFilter BySameScript (bySameCEM $ InProgress newVoteStorage)) (Exist 1) ] ++ allowedToVoteConstraints , signers = [jury] } - (InProgress votes, Finalize) -> - Right $ - MkTransitionSpec - { stage = Always - , сonstraints = - [ MkTxFanC Out (BySameCEM $ Finalized (countVotes votes)) (Exist 1) + (Just (InProgress votes), Finalize) -> + Right + $ MkTransitionSpec + { constraints = + [ MkTxFanC + Out + (MkTxFanFilter BySameScript (bySameCEM $ Finalized (countVotes votes))) + (Exist 1) ] , signers = [creator params] } - _ -> Left "Wrong state transition" + _ -> Left "Wrong state transition" where diff --git a/src/Cardano/CEM/Monads.hs b/src/Cardano/CEM/Monads.hs index 7cf9945..827a9b6 100644 --- a/src/Cardano/CEM/Monads.hs +++ b/src/Cardano/CEM/Monads.hs @@ -2,76 +2,346 @@ module Cardano.CEM.Monads where import Prelude +import Control.Concurrent (threadDelay) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Data (Proxy (..)) +import Data.Map qualified as Map +import Data.Set (Set) + +-- import Control.Monad.Trans.Either (EitherT(..)) + import PlutusLedgerApi.V1.Address (Address) +import PlutusLedgerApi.V2 ( + Interval (..), + POSIXTime (..), + UnsafeFromData (..), + always, + fromData, + ) -import Cardano.Api hiding (Address) +import Cardano.Api hiding (Address, In, Out, queryUtxo, txIns) +import Cardano.Api.Shelley (PlutusScript (..), PoolId, ReferenceScript (..), fromPlutusData, toMaryValue, toPlutusData) +import Cardano.Ledger.Core (PParams) import Cardano.CEM +import Cardano.CEM.OnChain +import Cardano.Extras +import Control.Monad.Except (ExceptT (..), MonadError (..), runExceptT) +import Control.Monad.Trans (MonadTrans (..)) +import Data.List (find) +import Data.Maybe (listToMaybe) +import Data.Spine (HasSpine (..)) +import Debug.Trace (trace, traceM) +import Text.Show.Pretty (ppShow) --- Common +-- MonadBlockchainParams -type Era = BabbageEra +-- @todo #13: Derive stock classes for cardano-api --- MonadBlockchainParams +-- | Params of blockchain required for transaction-building +data BlockchainParams = MkBlockchainParams + { protocolParameters :: PParams LedgerEra + , systemStart :: SystemStart + , eraHistory :: EraHistory + , stakePools :: Set PoolId + } {- | This monad gives access to all information about Cardano params, | which is various kind of Ledger params and ValidityBound/Slots semantics -} --- @todo #13: Add rest of MonadBlockchainParams interface --- @todo #13: Implement PSM for MonadBlockchainParams -class (Monad m) => MonadBlockchainParams m where +-- @todo #13: Implement PSM for `MonadBlockchainParams` (task for Michal) +class (MonadFail m) => MonadBlockchainParams m where askNetworkId :: m NetworkId queryCurrentSlot :: m SlotNo + queryBlockchainParams :: m BlockchainParams --- @todo #12: copy `fromPlutusAddressInMonad` from Hydra +fromPlutusAddressInMonad :: + (MonadBlockchainParams m) => Address -> m (AddressInEra Era) +fromPlutusAddressInMonad address = do + networkId <- askNetworkId + return $ fromPlutusAddress networkId address -- MonadQuery data UtxoQuery - = ByAddress Address + = ByAddresses [Address] | ByTxIns [TxIn] + deriving stock (Show, Eq) class (MonadBlockchainParams m) => MonadQueryUtxo m where queryUtxo :: UtxoQuery -> m (UTxO Era) --- MonadQuery +queryByFanFilter :: (MonadQueryUtxo m) => TxFanFilter script -> m (UTxO Era) +queryByFanFilter query = return $ error "TODO" + +checkTxIdExists :: (MonadQueryUtxo m) => TxId -> m Bool +checkTxIdExists txId = do + result <- queryUtxo $ ByTxIns [TxIn txId (TxIx 0)] + return $ not $ Map.null $ unUTxO result + +awaitTx :: forall m. (MonadIO m, MonadQueryUtxo m) => TxId -> m () +awaitTx txId = do + go 5 + where + go :: Integer -> m () + go 0 = liftIO $ fail "Tx was not awaited." -- TODO + go n = do + exists <- checkTxIdExists txId + liftIO $ threadDelay 1_000_000 + if exists + then return () + else go $ n - 1 --- @todo #12: specify ResolvedTx and TxResolutionStrategy -data ResolvedTx +-- MonadSubmit + +-- TODO: refactor +deriving instance (Eq (SigningKey PaymentKey)) + +data ResolvedTx = MkResolvedTx + { txIns :: [(TxIn, TxInWitness)] + , txInsReference :: [TxIn] + , txOuts :: [TxOut CtxTx Era] + , toMint :: TxMintValue BuildTx Era + , interval :: Interval POSIXTime + , signors :: [SigningKey PaymentKey] + } + deriving stock (Show, Eq) data WrongSlotKind = Early | Late + deriving stock (Show, Eq) data TxSubmittingError = WrongSlot WrongSlotKind Integer | TxInOutdated [TxIn] | UnhandledNodeError String + deriving stock (Show, Eq) class (MonadQueryUtxo m) => MonadSubmitTx m where submitResolvedTx :: ResolvedTx -> m (Either TxSubmittingError TxId) -data TxResolutionStrategy - data TxSigner = MkTxSigner - { signerAddress :: Address + { signerKey :: SigningKey PaymentKey , allowTxInSpending :: Bool , allowFeeCovering :: Bool } + deriving stock (Show, Eq) + +mkMainSigner :: SigningKey PaymentKey -> TxSigner +mkMainSigner signerKey = + MkTxSigner + { signerKey + , allowTxInSpending = True + , allowFeeCovering = True + } + +data CEMAction script + = MkCEMAction (CEMParams script) (Transition script) + +deriving stock instance + ( Show (CEMParams script) + , Show (State script) + , Show (Transition script) + ) => + Show (CEMAction script) + +-- deriving instance +-- ( Eq (State script) +-- , Eq (CEMParams script) +-- , Eq (Transition script) +-- ) => +-- Eq (CEMAction script) -data SomeTransitionSpec where - MkSomeTransitionSpec :: - forall spec. (CEMScript spec) => TransitionSpec spec -> SomeTransitionSpec +data SomeCEMAction where + MkSomeCEMAction :: + forall script. + ( CEMScriptCompiled script + , Show (CEMAction script) + , Show (State script) + , Show (Transition script) + , Eq (CEMParams script) + ) => + CEMAction script -> + SomeCEMAction + +instance Show SomeCEMAction where + -- TODO: show script name + show :: SomeCEMAction -> String + show (MkSomeCEMAction action) = show action data TxSpec = MkTxSpec - { transitionSpec :: [SomeTransitionSpec] - , signers :: [TxSigner] - , changeAddress :: Address + { actions :: [SomeCEMAction] + , specSigners :: [TxSigner] } + deriving stock (Show) + +data TransitionError + = StateMachineError + { errorMessage :: String + } + | MissingTransitionInputh + deriving stock (Show, Eq) data TxResolutionError = TxSpecIsIncorrect + | MkTransitionError SomeCEMAction TransitionError | UnhandledSubmittingError TxSubmittingError + deriving stock (Show) + +failLeft :: (MonadFail m, Show s) => Either s a -> m a +failLeft (Left errorMsg) = fail $ show errorMsg +failLeft (Right value) = return value + +-- TODO: use regular CEMScript +cemTxOutDatum :: (CEMScriptCompiled script) => TxOut ctx Era -> Maybe (CEMScriptDatum script) +cemTxOutDatum txOut = + fromData =<< toPlutusData <$> getScriptData <$> mTxOutDatum txOut + +cemTxOutState :: (CEMScriptCompiled script) => TxOut ctx Era -> Maybe (State script) +cemTxOutState txOut = + let + getState (_, _, state) = state + in + getState <$> cemTxOutDatum txOut + +queryScriptTxInOut :: + forall m script. + ( MonadQueryUtxo m + , CEMScriptCompiled script + , Eq (CEMParams script) + ) => + CEMParams script -> + m (Maybe (TxIn, TxOut CtxUTxO Era)) +queryScriptTxInOut params = do + utxo <- queryUtxo $ ByAddresses [scriptAddress] + let mScriptTxIn = + case Map.assocs $ unUTxO utxo of + [] -> Nothing + pairs -> find hasSameParams pairs + hasSameParams (txIn, txOut) = + case cemTxOutDatum txOut of + Just (p1, p2, _) -> params == MkCEMParams p2 p1 + Nothing -> False -- May happen in case of changed Datum encoding + return mScriptTxIn + where + scriptAddress = cemScriptAddress (Proxy :: Proxy script) + +queryScriptState :: + forall m script. + ( MonadQueryUtxo m + , CEMScriptCompiled script + , Eq (CEMParams script) + ) => + CEMParams script -> + m (Maybe (State script)) +queryScriptState params = do + mTxInOut <- queryScriptTxInOut params + return (cemTxOutState . snd =<< mTxInOut) + +resolveAction :: + forall m. + (MonadQueryUtxo m, MonadSubmitTx m) => + SomeCEMAction -> + m (Either TxResolutionError ResolvedTx) +resolveAction + someAction@(MkSomeCEMAction @script (MkCEMAction params transition)) = + runExceptT $ do + mScriptTxIn' <- lift $ queryScriptTxInOut params + + let + -- TODO + mScriptTxIn = case transitionStage (Proxy :: Proxy script) Map.! getSpine transition of + (_, Nothing) -> Nothing + _ -> mScriptTxIn' + mState = cemTxOutState =<< snd <$> mScriptTxIn + witnesedScriptTxIns = + case mScriptTxIn of + Just (txIn, _) -> + let + scriptWitness = + mkInlinedDatumScriptWitness + (PlutusScriptSerialised @PlutusLang script) + transition + in + [(txIn, scriptWitness)] + Nothing -> [] + + scriptTransition <- case transitionSpec (scriptParams params) mState transition of + Left errorMessage -> + throwError $ + MkTransitionError someAction (StateMachineError $ show errorMessage) + Right result -> return result + + let + byKind kind = + filter (\x -> txFanCKind x == kind) $ + constraints scriptTransition + + txIns <- concat <$> mapM resolveTxIn (byKind In) + txOuts <- concat <$> mapM compileTxConstraint (byKind Out) + + return $ + MkResolvedTx + { txIns = witnesedScriptTxIns ++ txIns + , txInsReference = [] + , txOuts + , toMint = TxMintNone + , signors = [] + , interval = always + } + where + script = cemScriptCompiled (Proxy :: Proxy script) + scriptAddress = cemScriptAddress (Proxy :: Proxy script) + resolveTxIn (MkTxFanC _ (MkTxFanFilter addressSpec filterSpec) quantor) = do + utxo <- lift $ queryUtxo $ ByAddresses [address] + return $ map withKeyWitness $ Map.keys $ unUTxO utxo + where + address = addressSpecToAddress scriptAddress addressSpec + compileTxConstraint + (MkTxFanC _ (MkTxFanFilter addressSpec filterSpec) quantor) = do + address' <- lift $ fromPlutusAddressInMonad address + let compiledTxOut value = + TxOut address' value datum ReferenceScriptNone + return $ case quantor of + Exist n -> replicate (fromInteger n) $ compiledTxOut minUtxoValue + SumValueEq value -> [compiledTxOut $ convertTxOut $ fromPlutusValue value] + where + datum = case filterSpec of + Anything -> TxOutDatumNone + ByDatum datum' -> mkInlineDatum datum' + BySameCEM newState -> + let + datum :: CEMScriptDatum script + datum = (stagesParams params, scriptParams params, unsafeFromBuiltinData newState) + in + mkInlineDatum datum + address = addressSpecToAddress scriptAddress addressSpec + -- TODO: protocol params + -- calculateMinimumUTxO era txout bpp + minUtxoValue = convertTxOut $ lovelaceToValue $ Lovelace 2_000_000 + -- TODO + convertTxOut x = + TxOutValueShelleyBased shelleyBasedEra $ toMaryValue x resolveTxAndSubmit :: - TxSpec -> TxResolutionStrategy -> Either TxResolutionError TxId -resolveTxAndSubmit = error "TODO" + (MonadQueryUtxo m, MonadSubmitTx m, MonadIO m) => + TxSpec -> + m (Either TxResolutionError TxId) +resolveTxAndSubmit spec = runExceptT $ do + -- Get specs + actionsSpecs <- mapM (ExceptT . resolveAction) $ actions spec + + -- Merge specs + let + mergedSpec' = head actionsSpecs + mergedSpec = mergedSpec' {signors = map signerKey $ specSigners spec} + + -- TODO + utxo <- lift $ queryUtxo $ ByAddresses [signingKeyToAddress $ head $ signors mergedSpec] + let ins = + map withKeyWitness $ Map.keys $ unUTxO utxo + + result <- lift $ submitResolvedTx $ mergedSpec {txIns = (txIns mergedSpec) ++ ins} + case result of + Right txId -> return txId + Left resolveError -> throwError $ UnhandledSubmittingError resolveError diff --git a/src/Cardano/CEM/Monads/L1.hs b/src/Cardano/CEM/Monads/L1.hs index 725052f..b7d09aa 100644 --- a/src/Cardano/CEM/Monads/L1.hs +++ b/src/Cardano/CEM/Monads/L1.hs @@ -1,21 +1,231 @@ +{-# LANGUAGE RecordWildCards #-} + module Cardano.CEM.Monads.L1 where +import Prelude + +import Text.Show.Pretty + +import Control.Monad.Reader (MonadReader (..), ReaderT (..)) +import Control.Monad.Trans (MonadIO (..)) +import Data.Set qualified as Set +import Unsafe.Coerce (unsafeCoerce) + +import Data.Aeson + -- Cardano imports -import Cardano.Api.UTxO qualified as UTxO +-- import Cardano.Ledger.Chain (PredicateFailure) +-- import Cardano.Ledger.Shelley.API () +-- import Ouroboros.Consensus.Shelley.Ledger (ApplyTxError (..)) +-- import Cardano.Ledger.Alonzo.TxInfo (ExtendedUTxO, TranslationError) +import Cardano.Api hiding (queryUtxo) +import Cardano.Api.Shelley (LedgerProtocolParameters (..)) + +-- CEM imports + +import Cardano.CEM +import Cardano.CEM.Monads +import Cardano.Extras +import Control.Exception (throwIO) +import Data.Bifunctor (Bifunctor (..)) +import Data.Map qualified as Map + +data ExecutionContext = MkExecutionContext + { localNode :: LocalNodeConnectInfo + } + +newtype L1Runner a = MkL1Runner + { unL1Runner :: ReaderT ExecutionContext IO a + } + deriving newtype + ( Functor + , Applicative + , Monad + , MonadIO + , MonadFail + , MonadReader ExecutionContext + ) + +-- Monad implementations + +instance MonadBlockchainParams L1Runner where + askNetworkId = localNodeNetworkId . localNode <$> ask + queryCurrentSlot = do + node <- localNode <$> ask + tip <- liftIO $ getLocalChainTip node + case tip of + ChainTipAtGenesis -> pure 0 + ChainTip slotNo _ _ -> pure slotNo + + queryBlockchainParams = do + MkBlockchainParams + <$> queryCardanoNode (convertEra QueryProtocolParameters) + <*> queryCardanoNode (convertEra QuerySystemStart) + <*> queryCardanoNode (convertEra QueryEraHistory) + <*> queryCardanoNode (convertEra QueryStakePools) + where + -- TODO + convertEra = unsafeCoerce + +-- TODO: cardano-api-extras +-- Design inspired by `Hydra.Chain.CardanoClient` helpers +queryCardanoNode :: + QueryInShelleyBasedEra Era b -> L1Runner b +queryCardanoNode query = do + node <- localNode <$> ask + result <- liftIO $ queryNodeLocalState node Nothing cardanoQuery + return $ case result of + -- TODO: better handling of wrong-era exceptions + Right (Right x) -> x + _ -> error "Unhandled Cardano API error" + where + cardanoQuery = + QueryInEra $ QueryInShelleyBasedEra ShelleyBasedEraBabbage query + +instance MonadQueryUtxo L1Runner where + queryUtxo query = do + utxoQuery <- case query of + ByTxIns txIns -> + return $ QueryUTxOByTxIn (Set.fromList txIns) + ByAddresses addresses -> do + cardanoAdresses <- + map addressInEraToAny <$> mapM fromPlutusAddressInMonad addresses + return $ QueryUTxOByAddress (Set.fromList cardanoAdresses) + queryCardanoNode $ QueryUTxO utxoQuery + +instance MonadSubmitTx L1Runner where + submitResolvedTx :: ResolvedTx -> L1Runner (Either TxSubmittingError TxId) + submitResolvedTx MkResolvedTx {..} = do + -- (lowerBound, upperBound) <- convertValidityBound validityBound + -- TODO + let keyWitnessedTxIns = [fst $ last txIns] + MkBlockchainParams {protocolParameters} <- queryBlockchainParams + let preBody = + TxBodyContent + { txIns = txIns + , txInsCollateral = + TxInsCollateral AlonzoEraOnwardsBabbage keyWitnessedTxIns + , txInsReference = + TxInsReference BabbageEraOnwardsBabbage txInsReference + , txOuts + , txMintValue = toMint + , txExtraKeyWits = + TxExtraKeyWitnesses AlonzoEraOnwardsBabbage $ + fmap (verificationKeyHash . getVerificationKey) signors + , txProtocolParams = + BuildTxWith $ + Just $ + LedgerProtocolParameters protocolParameters + , txValidityLowerBound = + TxValidityNoLowerBound + , txValidityUpperBound = + TxValidityUpperBound ShelleyBasedEraBabbage Nothing + , -- Fee stubs + txTotalCollateral = TxTotalCollateralNone + , txReturnCollateral = TxReturnCollateralNone + , txFee = TxFeeExplicit ShelleyBasedEraBabbage 0 + , -- Not supported fatures + txMetadata = TxMetadataNone + , txAuxScripts = TxAuxScriptsNone + , txWithdrawals = TxWithdrawalsNone + , txCertificates = TxCertificatesNone + , txUpdateProposal = TxUpdateProposalNone + , txScriptValidity = TxScriptValidityNone + , txProposalProcedures = Nothing + , txVotingProcedures = Nothing + } + + let + mainSignor = signors !! 0 + mainAddress' = signingKeyToAddress mainSignor + + mainAddress <- fromPlutusAddressInMonad mainAddress' + utxo <- queryUtxo $ ByTxIns $ map fst txIns + + -- liftIO $ pPrint preBody + -- liftIO $ pPrint utxo + + body <- + either (\x -> fail $ "Autobalance error: " <> show x) return + =<< callBodyAutoBalance + preBody + utxo + mainAddress + + let + tx = makeSignedTransactionWithKeys signors body + txInMode = TxInMode ShelleyBasedEraBabbage tx + + -- liftIO $ pPrint tx + ci <- localNode <$> ask + liftIO $ + submitTxToNodeLocal ci txInMode >>= \case + SubmitSuccess -> + return $ Right $ getTxId body + SubmitFail e -> + return $ Left $ UnhandledNodeError $ show e + -- case parseError e of + -- ApplyTxError x -> + -- return $ Left $ UnhandledNodeError $ show x + where + +-- parseError wrapper = case wrapper of +-- TxValidationErrorInCardanoMode error -> +-- fromJSON (toJSON error .: "error") :: ApplyTxError _ + +-- Utils --- Hydra imports +makeSignedTransactionWithKeys :: + [SigningKey PaymentKey] -> + TxBody Era -> + Tx Era +makeSignedTransactionWithKeys keys txBody = + makeSignedTransaction keyWitnesses txBody + where + createWitness key = makeShelleyKeyWitness shelleyBasedEra txBody (WitnessPaymentKey key) + keyWitnesses = fmap createWitness keys -import Data.Maybe (listToMaybe) -import Cardano.Api ( - CtxUTxO, - TxOut, - UTxO, - UTxO' (UTxO), - getScriptData, - toPlutusData, - toPlutusTxOut, - txOutDatum, - pattern TxOutDatumInline, - ) +callBodyAutoBalance :: + (MonadBlockchainParams m) => + TxBodyContent BuildTx Era -> + UTxO Era -> + AddressInEra Era -> + m (Either TxBodyErrorAutoBalance (TxBody Era)) +callBodyAutoBalance + preBody + utxo + changeAddress = do + MkBlockchainParams {protocolParameters, systemStart, eraHistory, stakePools} <- + queryBlockchainParams + let result = + makeTransactionBodyAutoBalance @Era + shelleyBasedEra + systemStart + (toLedgerEpochInfo eraHistory) + (LedgerProtocolParameters protocolParameters) + stakePools + Map.empty -- Stake credentials + Map.empty -- Some other DRep stuff + utxo + preBody + changeAddress + Nothing + return $ fmap balancedTxBody result + where + balancedTxBody (BalancedTxBody _ txBody _ _) = txBody +localDevnetNetworkId :: NetworkId +localDevnetNetworkId = Testnet $ NetworkMagic 42 +execOnLocalDevnet :: L1Runner a -> IO a +execOnLocalDevnet action = + runReaderT (unL1Runner action) localNodeContext + where + localNodeContext = + MkExecutionContext + { localNode = + LocalNodeConnectInfo + cardanoModeParams + localDevnetNetworkId + "./devnet/node.socket" + } diff --git a/src/Cardano/CEM/OnChain.hs b/src/Cardano/CEM/OnChain.hs index e5249e4..1e79b9c 100644 --- a/src/Cardano/CEM/OnChain.hs +++ b/src/Cardano/CEM/OnChain.hs @@ -1,12 +1,18 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE NoPolyKinds #-} + module Cardano.CEM.OnChain where import PlutusTx.Prelude +import Prelude qualified import Data.Proxy import PlutusLedgerApi.Common (SerialisedScript) -import PlutusLedgerApi.V1.Address (Address, pubKeyHashAddress) -import PlutusLedgerApi.V1.Interval (contains) +import PlutusLedgerApi.V1.Address (Address, pubKeyHashAddress, scriptHashAddress) +import PlutusLedgerApi.V1.Interval (always, contains) +import PlutusLedgerApi.V1.Scripts (Datum (..)) +import PlutusLedgerApi.V1.Value (geq) import PlutusLedgerApi.V2.Contexts ( ScriptContext, TxInInfo (..), @@ -15,84 +21,144 @@ import PlutusLedgerApi.V2.Contexts ( findOwnInput, scriptContextTxInfo, ) +import PlutusLedgerApi.V2.Tx (OutputDatum (..)) +import PlutusTx.IsData (FromData, ToData (toBuiltinData), UnsafeFromData (..)) +import PlutusTx.Show (Show (..)) -import Cardano.CEM +import Plutus.Extras -data CEMScriptDatum script = MkCEMScriptDatum - { stageParams :: StageParams (Stage script) - , params :: Params script - , state :: State script - } +import Cardano.CEM +import Cardano.CEM.Examples.Auction +import Cardano.CEM.Stages +import Cardano.Ledger.Babbage.TxBody (getEitherAddrBabbageTxOut) +import Language.Haskell.TH (Code, conT, unsafe) +import Language.Haskell.TH.Syntax (Dec, Exp, Name, Q, Type) -class (CEMScript script) => CEMScriptCompiled script where +class (CEMScript script, CEMScriptIsData script) => CEMScriptCompiled script where cemScriptCompiled :: Proxy script -> SerialisedScript -cemScriptAddress :: (CEMScriptCompiled script) => Proxy script -> Address -cemScriptAddress _ = traceError "TODO" +{-# INLINEABLE cemScriptAddress #-} +cemScriptAddress :: + forall script. (CEMScriptCompiled script) => Proxy script -> Address +cemScriptAddress = + scriptHashAddress . scriptValidatorHash . cemScriptCompiled + +type IsData x = (UnsafeFromData x, FromData x, ToData x) +type CEMScriptIsData script = + ( UnsafeFromData (Transition script) + , IsData (StageParams (Stage script)) + , IsData (Params script) + , IsData (Transition script) + , IsData (State script) + ) + +-- TODO: document hacks +-- Typed quasiquotes do not allow type splicing, so we need use untyped +-- Fields bug - https://gitlab.haskell.org/ghc/ghc/-/merge_requests/8686 +-- Data famlily - not suported - +-- https://github.com/IntersectMBO/plutus/issues/5768 +-- Type familiy mentioning: https://github.com/IntersectMBO/plutus/issues/5769 + +{-# INLINEABLE genericCEMScript #-} genericCEMScript :: - forall script. - (CEMScript script) => - CEMScriptDatum script -> - Transition script -> - ScriptContext -> - Bool -genericCEMScript datum transition context = - case transitionSpec (params datum) (state datum) transition of - Right spec -> - -- do transition - (and $ map (checkConstraint ownAddress datum info) (сonstraints spec)) - -- check signers - && ( traceIfFalse "Wrong signers list" - $ (signers spec) - `isSubSetOf` txInfoSignatories info - ) - -- check stage - && let - expectedInterval = - stageToOnChainInterval (stageParams datum) (stage spec) - in - traceIfFalse "Wrong interval for transition stage" - $ expectedInterval - `contains` txInfoValidRange info - Left _ -> traceError "TODO" - where - info = scriptContextTxInfo context - ownAddress = case findOwnInput context of - Just x -> txOutAddress $ txInInfoResolved x - Nothing -> traceError "Impossible happened" + Name -> + Name -> + Q Exp +genericCEMScript script scriptStage = + [| + \datum' redeemer' context' -> + let + checkTxFan' ownDatum filterSpec' fan = + case filterSpec' of + Anything -> True + BySameCEM stateData -> + let + state = unsafeFromBuiltinData stateData :: State $(conT script) + (p1, p2, _) = ownDatum + stateChangeDatum = (p1, p2, state) + stateChangeDatumBS = toBuiltinData stateChangeDatum + in + checkTxFan' ownDatum (ByDatum stateChangeDatumBS) fan + ByDatum expecedDatum -> + let + TxOut _ _ datum _ = fan + in + case datum of + OutputDatum datum -> getDatum datum == expecedDatum + OutputDatumHash _ -> traceError "Hash datum not supported" + _ -> False + checkConstraint ownDatum ownAddress info (MkTxFanC fanKind filterSpec quantifier) = + traceIfFalse ("Checking constraint " <> show fanKind <> " " <> show datumSpec) + $ checkQuantifier + $ filter checkTxFan fans + where + MkTxFanFilter addressSpec datumSpec = filterSpec + checkTxFan fan = + checkTxFanAddress ownAddress addressSpec fan + && checkTxFan' ownDatum datumSpec fan + fans = case fanKind of + In -> map txInInfoResolved $ txInfoInputs info + InRef -> map txInInfoResolved $ txInfoReferenceInputs info + Out -> txInfoOutputs info + checkQuantifier txFans = + case quantifier of + SumValueEq value -> + foldMap txOutValue txFans `geq` value + Exist n -> length txFans == n + + params :: Params $(conT script) + stageParams :: StageParams ($(conT scriptStage)) + datum :: CEMScriptDatum $(conT script) + datum = unsafeFromBuiltinData datum' + (stageParams, params, state) = datum + transition :: Transition $(conT script) + transition = unsafeFromBuiltinData redeemer' + context = unsafeFromBuiltinData context' + info = scriptContextTxInfo context + ownAddress = case findOwnInput context of + Just x -> txOutAddress $ txInInfoResolved x + Nothing -> traceError "Impossible happened" + transitionSpec' :: + Params $(conT script) -> _ -> _ -> Either BuiltinString (TransitionSpec $(conT script)) + transitionSpec' = transitionSpec @($(conT script)) + stageToOnChainInterval' :: StageParams $(conT scriptStage) -> $(conT scriptStage) -> _ + stageToOnChainInterval' = stageToOnChainInterval @($(conT scriptStage)) + result = + case transitionSpec' params (Just state) transition of + Right (MkTransitionSpec @($(conT script)) constraints signers) -> + -- do transition + traceIfFalse + "Some constraint not matching" + ( all (checkConstraint datum ownAddress info) constraints + ) + -- check signers + && traceIfFalse + "Wrong signers list" + ( signers + `isSubSetOf` txInfoSignatories info + ) + -- check stage + && let + expectedInterval = + always + -- stageToOnChainInterval' stageParams (traceError "TODO") + in + traceIfFalse "Wrong interval for transition stage" + $ expectedInterval + `contains` txInfoValidRange info + Left _ -> traceIfFalse "Wrong transition" False + in + if result + then () + else error () + |] -checkConstraint :: - Address -> CEMScriptDatum script -> TxInfo -> TxFanConstraint script -> Bool -checkConstraint ownAddress ownDatum info (MkTxFanC fanKind filterSpec quantifier) = - checkQuantifier $ filter (predFan filterSpec) fans - where - fans = case fanKind of - In -> map txInInfoResolved $ txInfoInputs info - InRef -> map txInInfoResolved $ txInfoReferenceInputs info - Out -> txInfoOutputs info - predFan filterSpec' fan = case filterSpec' of - Anything -> True - ByAddress address -> txOutAddress fan == address - BySameCEM state -> - let - stateChangeDatum = ownDatum {state = state} - stateChangeDatumBS = traceError "TODO" - cemChangeConstraint = - And [ByAddress ownAddress, ByDatum stateChangeDatumBS] - in - predFan cemChangeConstraint fan - ByPubKey pubKey -> predFan (ByAddress $ pubKeyHashAddress pubKey) fan - ByDatum datum -> retrieveFanDatum fan == Just datum - And subSpecs -> and $ predOnSubSpecs subSpecs - Or subSpecs -> or $ predOnSubSpecs subSpecs - where - predOnSubSpecs = map (flip predFan fan) - checkQuantifier txFans = case quantifier of - SumValueEq value -> (foldMap txOutValue txFans) == value - -- TODO: use natural numbers - Exist n -> length txFans == n - retrieveFanDatum fan = traceError "TODO" +{-# INLINEABLE checkTxFanAddress #-} +checkTxFanAddress :: Address -> AddressSpec -> TxOut -> Bool +checkTxFanAddress ownAddress addressSpec fan = + txOutAddress fan == addressSpecToAddress ownAddress addressSpec +{-# INLINEABLE isSubSetOf #-} isSubSetOf :: (Eq a) => [a] -> [a] -> Bool -isSubSetOf xs ys = and $ map (`elem` ys) xs +isSubSetOf xs ys = all (`elem` ys) xs diff --git a/src/Cardano/CEM/Stages.hs b/src/Cardano/CEM/Stages.hs new file mode 100644 index 0000000..1669625 --- /dev/null +++ b/src/Cardano/CEM/Stages.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE NoPolyKinds #-} + +module Cardano.CEM.Stages where + +import PlutusTx qualified + +import PlutusLedgerApi.V2 ( + Interval (..), + POSIXTime (..), + always, + ) + +-- Stages + +-- This covers constraints on blockchain slot time, +-- used by both on- and off-chain code +class Stages stage where + type StageParams stage = params | params -> stage + stageToOnChainInterval :: + StageParams stage -> stage -> Interval POSIXTime + +-- Common + +-- TODO: rename +data SingleStage = Always + +data SingleStageParams + = NoSingleStageParams + | AllowedInterval (Interval POSIXTime) + +instance Stages SingleStage where + type StageParams SingleStage = SingleStageParams + + stageToOnChainInterval NoSingleStageParams Always = always + stageToOnChainInterval (AllowedInterval interval) Always = interval + +PlutusTx.unstableMakeIsData ''SingleStage +PlutusTx.unstableMakeIsData 'NoSingleStageParams diff --git a/src/Plutus/Extras.hs b/src/Plutus/Extras.hs deleted file mode 100644 index e715b04..0000000 --- a/src/Plutus/Extras.hs +++ /dev/null @@ -1,62 +0,0 @@ -module Plutus.Extras where - -import PlutusTx.Prelude - -import Cardano.Api ( - SerialiseAsRawBytes (serialiseToRawBytes), - fromPlutusScript, - hashScript, - pattern PlutusScript, - ) -import PlutusLedgerApi.V1.Api (Script, UnsafeFromData (unsafeFromBuiltinData), ValidatorHash (ValidatorHash)) -import PlutusTx (BuiltinData) - --- * Vendored from plutus-ledger - --- | Signature of an untyped validator script. -type ValidatorType = BuiltinData -> BuiltinData -> BuiltinData -> () - --- | Wrap a typed validator to get the basic `ValidatorType` signature which can --- be passed to `PlutusTx.compile`. --- REVIEW: There might be better ways to name this than "wrap" -wrapValidator :: - (UnsafeFromData datum, UnsafeFromData redeemer, UnsafeFromData context) => - (datum -> redeemer -> context -> Bool) -> - ValidatorType -wrapValidator f d r c = - check $ f datum redeemer context - where - datum = unsafeFromBuiltinData d - redeemer = unsafeFromBuiltinData r - context = unsafeFromBuiltinData c -{-# INLINEABLE wrapValidator #-} - --- | Signature of an untyped minting policy script. -type MintingPolicyType = BuiltinData -> BuiltinData -> () - --- | Wrap a typed minting policy to get the basic `MintingPolicyType` signature --- which can be passed to `PlutusTx.compile`. -wrapMintingPolicy :: - (UnsafeFromData redeemer, UnsafeFromData context) => - (redeemer -> context -> Bool) -> - MintingPolicyType -wrapMintingPolicy f r c = - check $ f redeemer context - where - redeemer = unsafeFromBuiltinData r - context = unsafeFromBuiltinData c -{-# INLINEABLE wrapMintingPolicy #-} - --- * Similar utilities as plutus-ledger - --- | Compute the 'ValidatorHash' for a given plutus 'Script'. --- --- NOTE: Implemented using hydra-cardano-api (PlutusScript pattern) -scriptValidatorHash :: Script -> ValidatorHash -scriptValidatorHash = - ValidatorHash - . toBuiltin - . serialiseToRawBytes - . hashScript - . PlutusScript - . fromPlutusScript diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..6a1c59f --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,332 @@ +module Main (main) where + +import Prelude hiding (readFile) + +import Control.Monad.Trans +import Data.ByteString (putStr, readFile) +import System.Random + +import Text.Show.Pretty + +import Cardano.Api hiding (queryUtxo) +import Cardano.Api.Shelley (ReferenceScript (..), toMaryValue) + +import Cardano.CEM +import Cardano.CEM.Examples.Compilation + +-- import Cardano.CEM.Examples.Escrow +import Cardano.CEM.Monads +import Cardano.CEM.Monads.L1 +import Cardano.CEM.Stages +import Cardano.Extras + +import Cardano.CEM.Examples.Auction +import Cardano.Ledger.Val (adaOnly) +import Data.Map (elems, keys) +import PlutusLedgerApi.V1.Address (pubKeyHashAddress) +import PlutusLedgerApi.V1.Interval (always) +import PlutusLedgerApi.V1.Value (adaSymbol, adaToken, assetClass, assetClassValue) +import Test.Hspec (around, describe, hspec, it, shouldBe, shouldSatisfy) +import Unsafe.Coerce (unsafeCoerce) +import Cardano.CEM.Monads (queryScriptState) +import Cardano.CEM.Examples.Auction (SimpleAuctionState(NotStarted, CurrentBet)) + +data TestContext = MkTestContext + { testEnvKeys :: [SigningKey PaymentKey] + } + +keysPaths = + [ "./devnet/credentials/faucet.sk" + , "./devnet/credentials/bob.sk" + , "./devnet/credentials/carol.sk" + ] + +readTestContext :: IO (TestContext) +readTestContext = do + testEnvKeys <- mapM readKey keysPaths + return (MkTestContext {testEnvKeys}) + where + readKey path = do + Just key <- liftIO $ parseSigningKeyTE <$> readFile path + return key + +withContext :: (TestContext -> IO ()) -> IO () +withContext action = do + context <- readTestContext + action context + +checkTxCreated :: + (MonadQueryUtxo m, MonadIO m) => TxId -> m () +checkTxCreated txId = do + -- TODO: better out checks + awaitTx txId + let + txIn = TxIn txId (TxIx 0) + someValue = lovelaceToValue $ fromInteger 0 + utxo <- queryUtxo $ ByTxIns [txIn] + liftIO $ shouldSatisfy (utxoValue utxo) (/= someValue) + +submitAndCheck spec = do + case head $ actions spec of + MkSomeCEMAction (MkCEMAction _ transition) -> + liftIO $ putStrLn $ "Doing " <> show transition + result <- resolveTxAndSubmit spec + case result of + Right txId -> do + awaitTx txId + liftIO $ putStrLn $ "Awaited " <> show txId + Left error -> fail $ show error + +main :: IO () +main = hspec $ around withContext $ do + describe "Checking monad works" $ do + it "Asking NetworkId works" $ \_context -> execOnLocalDevnet $ do + networkId <- askNetworkId + liftIO $ networkId `shouldBe` localDevnetNetworkId + it "Querying blockchain params works" $ \_context -> execOnLocalDevnet $ do + _slotNo <- queryCurrentSlot + _blockchainParams <- queryBlockchainParams + return () + it "Querying UTxO works" $ \context -> execOnLocalDevnet $ do + utxo <- + queryUtxo $ + ByAddresses + [ signingKeyToAddress $ testEnvKeys context !! 0 + ] + return () + it "Sending transaction works" $ \context -> execOnLocalDevnet $ do + utxo <- + queryUtxo $ + ByAddresses + [ signingKeyToAddress $ testEnvKeys context !! 0 + ] + + user1Address <- + fromPlutusAddressInMonad $ signingKeyToAddress $ testEnvKeys context !! 0 + user2Address <- + fromPlutusAddressInMonad $ signingKeyToAddress $ testEnvKeys context !! 1 + let + user1TxIns = keys $ unUTxO utxo + Just value = valueToLovelace $ utxoValue utxo + convert x = + TxOutValueShelleyBased shelleyBasedEra $ + toMaryValue x + out userAddress = + TxOut + userAddress + (convert $ lovelaceToValue $ fromInteger 10_000_000) + TxOutDatumNone + ReferenceScriptNone + tx = + MkResolvedTx + { txIns = map withKeyWitness user1TxIns + , txInsReference = [] + , txOuts = + [ out user1Address + , out user2Address + ] + , toMint = TxMintNone + , interval = always + , signors = [testEnvKeys context !! 0] + } + Right txId <- submitResolvedTx tx + checkTxCreated txId + + return () + + describe "SimpleAuction usecase" $ do + it "Wrong transition resolution error" $ \context -> execOnLocalDevnet $ do + let + seller = testEnvKeys context !! 0 + bidder1 = testEnvKeys context !! 1 + auctionParams = + MkCEMParams + { scriptParams = + MkAuctionParams + { seller = signingKeyToPKH seller + , lot = + assetClassValue + (assetClass adaSymbol adaToken) + 10_000_000 + } + , stagesParams = NoControl + } + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ MkCEMAction auctionParams Create + ] + , specSigners = [mkMainSigner seller] + } + + let + bid1 = + MkBet + { better = signingKeyToPKH bidder1 + , betAmount = 1_000_000 + } + + result <- + resolveTxAndSubmit $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams (MakeBet bid1) + ] + , specSigners = [mkMainSigner bidder1] + } + Left + ( MkTransitionError + _ + (StateMachineError "\"Incorrect state for transition\"") + ) <- + return result + + return () + + it "Wrong bid resolution error" $ \context -> execOnLocalDevnet $ do + let + seller = testEnvKeys context !! 0 + bidder1 = testEnvKeys context !! 1 + auctionParams = + MkCEMParams + { scriptParams = + MkAuctionParams + { seller = signingKeyToPKH seller + , lot = + assetClassValue + (assetClass adaSymbol adaToken) + 10_000_000 + } + , stagesParams = NoControl + } + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ MkCEMAction auctionParams Create + ] + , specSigners = [mkMainSigner seller] + } + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams Start + ] + , specSigners = [mkMainSigner seller] + } + + let + bid1 = + MkBet + { better = signingKeyToPKH bidder1 + , betAmount = 0 + } + + result <- + resolveTxAndSubmit $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams (MakeBet bid1) + ] + , specSigners = [mkMainSigner bidder1] + } + Left + ( MkTransitionError + _ + (StateMachineError "\"Incorrect state for transition\"") + ) <- + return result + + return () + + it "Successful transition flow" $ \context -> execOnLocalDevnet $ do + -- XXX: blockchain state is reused, so we need to differentiate Utxos + paramJitter <- liftIO $ getStdRandom (randomR (0, 1_000_000)) + let + seller = testEnvKeys context !! 0 + bidder1 = testEnvKeys context !! 1 + auctionParams = + MkCEMParams + { scriptParams = + MkAuctionParams + { seller = signingKeyToPKH seller + , lot = + assetClassValue + (assetClass adaSymbol adaToken) + (10_000_000 + paramJitter) + } + , stagesParams = NoControl + } + + Nothing <- queryScriptState auctionParams + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ MkCEMAction auctionParams Create + ] + , specSigners = [mkMainSigner seller] + } + + Just NotStarted <- queryScriptState auctionParams + + let + initBid = + MkBet + { better = signingKeyToPKH seller + , betAmount = 0 + } + bid1 = + MkBet + { better = signingKeyToPKH bidder1 + , betAmount = 3_000_000 + } + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams Start + ] + , specSigners = [mkMainSigner seller] + } + + Just (CurrentBet currentBid') <- queryScriptState auctionParams + liftIO $ currentBid' `shouldBe` initBid + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams (MakeBet bid1) + ] + , specSigners = [mkMainSigner bidder1] + } + + + Just (CurrentBet currentBid) <- queryScriptState auctionParams + liftIO $ currentBid `shouldBe` bid1 + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams Close + ] + , specSigners = [mkMainSigner seller] + } + + + submitAndCheck $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams (Buyout $ signingKeyToAddress bidder1) + ] + , specSigners = [mkMainSigner bidder1] + }