diff --git a/app/delegate-server/HydraNodeApi/Http.purs b/app/delegate-server/HydraNodeApi/Http.purs index 2dff0d4..568203c 100644 --- a/app/delegate-server/HydraNodeApi/Http.purs +++ b/app/delegate-server/HydraNodeApi/Http.purs @@ -18,7 +18,7 @@ import Data.Either (Either(Left, Right)) import Data.HTTP.Method (Method(POST)) import Data.Maybe (Maybe(Just)) import Data.Newtype (wrap) -import DelegateServer.HydraNodeApi.Types.DraftCommitTx (DraftCommitTx, draftCommitTxCodec) +import DelegateServer.Types.HydraDraftCommitTx (DraftCommitTx, draftCommitTxCodec) import Effect.Aff (Aff) import HydraAuctionOffchain.Lib.Json (caDecodeString) import HydraAuctionOffchain.Service.Common diff --git a/app/delegate-server/HydraNodeApi/Types/Commit.purs b/app/delegate-server/HydraNodeApi/Types/Commit.purs deleted file mode 100644 index 6ac0dda..0000000 --- a/app/delegate-server/HydraNodeApi/Types/Commit.purs +++ /dev/null @@ -1,174 +0,0 @@ -module DelegateServer.HydraNodeApi.Types.Commit - ( CommitUtxoMap(CommitUtxoMap) - , PlutusV2Script - , PlutusV2ScriptType(PlutusScriptV2) - , ScriptWitness - , TxOutWithWitness - , mkCollateralCommit - , mkStandingBidCommit - ) where - -import Prelude - -import Contract.Address (Address) -import Contract.Hashing (datumHash) -import Contract.PlutusData (PlutusData, toData) -import Contract.Prim.ByteArray (ByteArray, byteLength, hexToByteArrayUnsafe) -import Contract.Scripts (Validator) -import Contract.Transaction (TransactionInput, outputDatumDatum) -import Ctl.Internal.Serialization (toBytes) -import Ctl.Internal.Serialization.PlutusData (convertPlutusData) -import Data.Argonaut (class EncodeJson, Json, fromObject) -import Data.Bifunctor (bimap) -import Data.Codec.Argonaut (JsonCodec, encode, json, object, string) as CA -import Data.Codec.Argonaut.Compat (maybe) as CA -import Data.Codec.Argonaut.Generic (nullarySum) as CAG -import Data.Codec.Argonaut.Record (record) as CAR -import Data.Generic.Rep (class Generic) -import Data.Int (hexadecimal, toStringAs) -import Data.Maybe (Maybe(Just, Nothing)) -import Data.Newtype (class Newtype, unwrap, wrap) -import Data.Tuple (fst) -import Data.Tuple.Nested (type (/\), (/\)) -import DelegateServer.Helpers (printOref) -import DelegateServer.Types.HydraUtxoMap (addressCodec, encodePlutusData, encodeValue) -import Foreign.Object (fromFoldable) as Obj -import HydraAuctionOffchain.Codec (byteArrayCodec) -import HydraAuctionOffchain.Contract.Types (StandingBidRedeemer(MoveToHydraRedeemer), Utxo) - -newtype CommitUtxoMap = CommitUtxoMap (Array (TransactionInput /\ TxOutWithWitness)) - -derive instance Generic CommitUtxoMap _ -derive instance Newtype CommitUtxoMap _ -derive newtype instance Semigroup CommitUtxoMap -derive newtype instance Monoid CommitUtxoMap - -instance EncodeJson CommitUtxoMap where - encodeJson = - fromObject - <<< Obj.fromFoldable - <<< map (bimap printOref (CA.encode txOutWithWitnessCodec)) - <<< unwrap - -commitUtxoMapSingleton :: TransactionInput -> TxOutWithWitness -> CommitUtxoMap -commitUtxoMapSingleton oref txOutWithWitness = - wrap [ oref /\ txOutWithWitness ] - --- - -mkCollateralCommit :: Utxo -> CommitUtxoMap -mkCollateralCommit (oref /\ txOut) = - let - rec = unwrap $ (unwrap txOut).output - in - commitUtxoMapSingleton oref - { address: rec.address - , value: encodeValue rec.amount - , referenceScript: Nothing - , datumhash: Nothing - , inlineDatum: Nothing - , inlineDatumhash: Nothing - , datum: Nothing - , witness: Nothing - } - -mkStandingBidCommit :: Utxo -> Validator -> Maybe CommitUtxoMap -mkStandingBidCommit (oref /\ txOut) standingBidValidator = do - let - rec = unwrap $ (unwrap txOut).output - validatorBytes = fst $ unwrap $ unwrap standingBidValidator - datum <- outputDatumDatum rec.datum - pure $ commitUtxoMapSingleton oref - { address: rec.address - , value: encodeValue rec.amount - , referenceScript: Nothing - , datumhash: Nothing - , inlineDatum: Just $ encodePlutusData $ unwrap datum - , inlineDatumhash: Just $ unwrap $ datumHash datum - , datum: Nothing - , witness: - Just - { plutusV2Script: - { cborHex: bytesToCbor validatorBytes - , description: "Standing bid validator" - , "type": PlutusScriptV2 - } - , datum: Nothing - , redeemer: plutusDataToCbor $ toData MoveToHydraRedeemer - } - } - -bytesToCbor :: ByteArray -> ByteArray -bytesToCbor ba = - hexToByteArrayUnsafe ("59" <> toStringAs hexadecimal (byteLength ba)) - <> ba - -plutusDataToCbor :: PlutusData -> ByteArray -plutusDataToCbor = unwrap <<< toBytes <<< convertPlutusData - --- - -type TxOutWithWitness = - { address :: Address - , value :: Json - , referenceScript :: Maybe Json - , datumhash :: Maybe ByteArray - , inlineDatum :: Maybe Json - , inlineDatumhash :: Maybe ByteArray - , datum :: Maybe ByteArray - , witness :: Maybe ScriptWitness - } - -txOutWithWitnessCodec :: CA.JsonCodec TxOutWithWitness -txOutWithWitnessCodec = - CA.object "TxOutWithWitness" $ CAR.record - { address: addressCodec - , value: CA.json - , referenceScript: CA.maybe CA.json - , datumhash: CA.maybe byteArrayCodec - , inlineDatum: CA.maybe CA.json - , inlineDatumhash: CA.maybe byteArrayCodec - , datum: CA.maybe byteArrayCodec - , witness: CA.maybe scriptWitnessCodec - } - --- - -type ScriptWitness = - { plutusV2Script :: PlutusV2Script - , datum :: Maybe ByteArray - , redeemer :: ByteArray - } - -scriptWitnessCodec :: CA.JsonCodec ScriptWitness -scriptWitnessCodec = - CA.object "ScriptWitness" $ CAR.record - { plutusV2Script: plutusV2ScriptCodec - , datum: CA.maybe byteArrayCodec - , redeemer: byteArrayCodec - } - --- - -type PlutusV2Script = - { cborHex :: ByteArray - , description :: String - , "type" :: PlutusV2ScriptType - } - -plutusV2ScriptCodec :: CA.JsonCodec PlutusV2Script -plutusV2ScriptCodec = - CA.object "PlutusV2Script" $ CAR.record - { cborHex: byteArrayCodec - , description: CA.string - , "type": plutusV2ScriptTypeCodec - } - --- - -data PlutusV2ScriptType = PlutusScriptV2 - -derive instance Generic PlutusV2ScriptType _ - -plutusV2ScriptTypeCodec :: CA.JsonCodec PlutusV2ScriptType -plutusV2ScriptTypeCodec = CAG.nullarySum "PlutusV2ScriptType" diff --git a/app/delegate-server/HydraNodeApi/WebSocket.purs b/app/delegate-server/HydraNodeApi/WebSocket.purs index 48c2c9c..64558ff 100644 --- a/app/delegate-server/HydraNodeApi/WebSocket.purs +++ b/app/delegate-server/HydraNodeApi/WebSocket.purs @@ -22,7 +22,7 @@ import DelegateServer.App (AppM, getAppEffRunner) import DelegateServer.Config (AppConfig'(AppConfig)) import DelegateServer.Contract.Commit (commitCollateral, commitStandingBid) import DelegateServer.Contract.StandingBid (queryStandingBidL2) -import DelegateServer.HydraNodeApi.Types.Message +import DelegateServer.Types.HydraNodeApiMessage ( CommittedMessage , GreetingsMessage , HeadClosedMessage diff --git a/app/delegate-server/HydraNodeApi/Types/DraftCommitTx.purs b/app/delegate-server/Types/HydraDraftCommitTx.purs similarity index 91% rename from app/delegate-server/HydraNodeApi/Types/DraftCommitTx.purs rename to app/delegate-server/Types/HydraDraftCommitTx.purs index d526a38..8f06a95 100644 --- a/app/delegate-server/HydraNodeApi/Types/DraftCommitTx.purs +++ b/app/delegate-server/Types/HydraDraftCommitTx.purs @@ -1,4 +1,4 @@ -module DelegateServer.HydraNodeApi.Types.DraftCommitTx +module DelegateServer.Types.HydraDraftCommitTx ( DraftCommitTx , draftCommitTxCodec ) where diff --git a/app/delegate-server/HydraNodeApi/Types/Message.purs b/app/delegate-server/Types/HydraNodeApiMessage.purs similarity index 99% rename from app/delegate-server/HydraNodeApi/Types/Message.purs rename to app/delegate-server/Types/HydraNodeApiMessage.purs index 5ccd1d8..f2368d1 100644 --- a/app/delegate-server/HydraNodeApi/Types/Message.purs +++ b/app/delegate-server/Types/HydraNodeApiMessage.purs @@ -1,4 +1,4 @@ -module DelegateServer.HydraNodeApi.Types.Message +module DelegateServer.Types.HydraNodeApiMessage ( CommittedMessage , GreetingsMessage , HeadClosedMessage diff --git a/test/DelegateServer/Cluster.purs b/test/DelegateServer/Cluster.purs index 7892bf7..84fae84 100644 --- a/test/DelegateServer/Cluster.purs +++ b/test/DelegateServer/Cluster.purs @@ -8,10 +8,10 @@ import Prelude import Contract.Address (PubKeyHash) import Contract.Config (NetworkId(MainnetId), mkCtlBackendParams) import Contract.Hashing (publicKeyHash) -import Contract.Monad (Contract, ContractEnv, liftContractM, runContractInEnv) +import Contract.Monad (Contract, ContractEnv, liftContractM, liftedE, runContractInEnv) import Contract.Test (class UtxoDistribution, ContractTest(ContractTest)) import Contract.Test.Plutip (PlutipConfig) -import Contract.Transaction (TransactionInput) +import Contract.Transaction (Language(PlutusV2), TransactionInput) import Contract.Wallet (PrivatePaymentKey) import Contract.Wallet.Key (publicKeyFromPrivateKey) import Contract.Wallet.KeyFile (privatePaymentKeyToFile) @@ -21,15 +21,19 @@ import Control.Parallel (parTraverse, parTraverse_) import Ctl.Internal.Helpers (concatPaths, (<>)) import Ctl.Internal.Plutip.Types (ClusterStartupParameters) import Ctl.Internal.Plutip.Utils (tmpdir) +import Ctl.Internal.Types.Int (fromInt) import Ctl.Internal.Wallet.Key (KeyWallet(KeyWallet)) import Data.Array (concat, deleteAt, replicate) import Data.Array.NonEmpty (NonEmptyArray) import Data.Array.NonEmpty (fromArray, head, toArray) as NEArray +import Data.Codec.Argonaut (JsonCodec, array, int, object) as CA +import Data.Codec.Argonaut.Record (record) as CAR import Data.Foldable (length) import Data.Int (decimal, toStringAs) import Data.Log.Level (LogLevel(Info)) +import Data.Map (singleton) as Map import Data.Maybe (Maybe) -import Data.Newtype (unwrap, wrap) +import Data.Newtype (modify, unwrap, wrap) import Data.TraversableWithIndex (traverseWithIndex) import Data.Tuple (snd) import Data.Tuple.Nested (type (/\), (/\)) @@ -52,6 +56,7 @@ import Effect.Class (class MonadEffect, liftEffect) import Effect.Console (log) import Effect.Exception (error) import Effect.Unsafe (unsafePerformEffect) +import HydraAuctionOffchain.Codec (bigIntCodecNum) import HydraAuctionOffchain.Contract.Types ( AuctionInfoExtended , BidTerms @@ -59,13 +64,13 @@ import HydraAuctionOffchain.Contract.Types , bidTermsCodec ) import HydraAuctionOffchain.Helpers (fromJustWithErr, randomElem) -import HydraAuctionOffchain.Lib.Json (caEncodeString) +import HydraAuctionOffchain.Lib.Json (caDecodeFile, caEncodeString) +import JS.BigInt (BigInt) import Node.Buffer (toString) as Buffer import Node.ChildProcess (defaultExecSyncOptions, execSync) import Node.Encoding (Encoding(UTF8)) as Encoding import Node.FS.Sync (rm') as FSSync import Node.Path (FilePath) -import Test.DelegateServer.PlaceBid.Suite (patchContractEnv) import Test.Helpers ( chunksOf2 , defDistribution @@ -324,3 +329,47 @@ publishHydraScripts nodeSocket cardanoSk = <> cardanoSk Buffer.toString Encoding.UTF8 =<< execSync cmd defaultExecSyncOptions + +patchContractEnv :: forall (a :: Type). NetworkId -> Contract ContractEnv +patchContractEnv network = do + pparams <- pparamsSlice + ask <#> \env -> env + { networkId = network + , ledgerConstants = + env.ledgerConstants + { pparams = + env.ledgerConstants.pparams # modify _ + { costModels = + wrap $ Map.singleton PlutusV2 + (wrap $ fromInt <$> pparams.costModels."PlutusV2") + , maxTxExUnits = + { mem: pparams.maxTxExecutionUnits.memory + , steps: pparams.maxTxExecutionUnits.steps + } + } + } + } + +pparamsSlice :: Contract PParamsSlice +pparamsSlice = + liftedE $ liftEffect $ + caDecodeFile pparamsSliceCodec "protocol-parameters.json" + +type PParamsSlice = + { maxTxExecutionUnits :: { memory :: BigInt, steps :: BigInt } + , costModels :: { "PlutusV2" :: Array Int } + } + +pparamsSliceCodec :: CA.JsonCodec PParamsSlice +pparamsSliceCodec = + CA.object "PParamsSlice" $ CAR.record + { maxTxExecutionUnits: + CA.object "PParamsSlice:ExUnits" $ CAR.record + { memory: bigIntCodecNum + , steps: bigIntCodecNum + } + , costModels: + CA.object "PParamsSlice:CostModels" $ CAR.record + { "PlutusV2": CA.array CA.int + } + } diff --git a/test/DelegateServer/PlaceBid/Fixtures.purs b/test/DelegateServer/PlaceBid/Fixtures.purs deleted file mode 100644 index a7fe2ba..0000000 --- a/test/DelegateServer/PlaceBid/Fixtures.purs +++ /dev/null @@ -1,212 +0,0 @@ -module Test.DelegateServer.PlaceBid.Fixtures - ( auctionInfoFixture - , bidFixture0 - , bidFixture1 - , commitUtxoMapFixture0 - , commitUtxoMapFixture1 - ) where - -import Prelude - -import Contract.Address (scriptHashAddress) -import Contract.Monad (Contract, liftedE) -import Contract.PlutusData (OutputDatum(NoOutputDatum, OutputDatum), toData) -import Contract.Prim.ByteArray (hexToByteArrayUnsafe) -import Contract.Scripts (validatorHash) -import Contract.Time (POSIXTime) -import Contract.Transaction (TransactionInput, TransactionOutput) -import Contract.Value (CurrencySymbol) -import Contract.Value (lovelaceValueOf, singleton) as Value -import Control.Monad.Except (runExceptT) -import Data.Maybe (Maybe(Just, Nothing)) -import Data.Newtype (unwrap, wrap) -import Data.Time.Duration (Days(Days)) -import Data.Tuple.Nested (type (/\), (/\)) -import DelegateServer.Const (appConst) as DelegateServer -import DelegateServer.Types.HydraUtxoMap (HydraUtxoMap) -import HydraAuctionOffchain.Contract.MintingPolicies (standingBidTokenName) -import HydraAuctionOffchain.Contract.Types - ( AuctionInfo(AuctionInfo) - , AuctionTerms - , BidTerms - , StandingBidState(StandingBidState) - ) -import HydraAuctionOffchain.Contract.Validators (mkAuctionValidators) -import HydraAuctionOffchain.Helpers (mkPosixTimeUnsafe) -import JS.BigInt (BigInt) -import JS.BigInt (fromInt) as BigInt -import Test.Helpers - ( mkAddressUnsafe - , mkCurrencySymbolUnsafe - , mkOrefUnsafe - , mkPubKeyHashUnsafe - , mkTokenNameUnsafe - , mkVerificationKeyUnsafe - ) - -bidFixture1 :: BidTerms -bidFixture1 = wrap - { bidder: wrap - { bidderAddress: - mkAddressUnsafe - "addr_test1qpsjljwwefv553ly43alu97cd5wtjvfdvqk9f76la7gejgw5p2hj0e0fx5lp95vk3055zcm\ - \y8edf63uwpe37zhcnjvrsev08p0" - , bidderVk: - mkVerificationKeyUnsafe - "c059d4c74359ffe1b8326e03065ab08b0b8c2579cc32e29cf087257b59ec79e9" - } - , price: BigInt.fromInt 15_000_000 - , bidderSignature: - hexToByteArrayUnsafe - "04d80101455aac2d81890f41e7a3e8c1c76691061428dc4138e01488c592aa88752187556676f29d12aaf\ - \2d8ce27c536612cf43a6394ce5a472c1e9e93c4a50d" - , sellerSignature: - hexToByteArrayUnsafe - "ec1066a6ea9476f7628ac2eeb90fb93a0da09d86e597115b666d18fcc3925801afddcd39e89b768d49cc1\ - \872d44427145d3c0adfc5c45a2f520319c63a93240e" - } - -bidFixture0 :: BidTerms -bidFixture0 = wrap - { bidder: wrap - { bidderAddress: - mkAddressUnsafe - "addr_test1qpsjljwwefv553ly43alu97cd5wtjvfdvqk9f76la7gejgw5p2hj0e0fx5lp95vk3055zcm\ - \y8edf63uwpe37zhcnjvrsev08p0" - , bidderVk: - mkVerificationKeyUnsafe - "c059d4c74359ffe1b8326e03065ab08b0b8c2579cc32e29cf087257b59ec79e9" - } - , price: BigInt.fromInt 10_000_000 - , bidderSignature: - hexToByteArrayUnsafe - "f2009f85f65812afdc8a9a51c081533b49378de06e642e60e95694fa3f7ded5b05b000c47ad961385152a\ - \d10a349aeb71eed2e0fbb270b27a6281769c2df1b07" - , sellerSignature: - hexToByteArrayUnsafe - "ec1066a6ea9476f7628ac2eeb90fb93a0da09d86e597115b666d18fcc3925801afddcd39e89b768d49cc1\ - \872d44427145d3c0adfc5c45a2f520319c63a93240e" - } - -commitUtxoMapFixture0 :: AuctionInfo -> HydraUtxoMap -commitUtxoMapFixture0 auctionInfo = - wrap - [ bidUtxoFixture0 auctionInfo - , collateralUtxoFixture DelegateServer.appConst.collateralLovelace - ] - -commitUtxoMapFixture1 :: AuctionInfo -> HydraUtxoMap -commitUtxoMapFixture1 auctionInfo = - wrap - [ bidUtxoFixture1 auctionInfo - , collateralUtxoFixture $ BigInt.fromInt 8_870_780 - ] - -collateralUtxoFixture :: BigInt -> TransactionInput /\ TransactionOutput -collateralUtxoFixture lovelace = - oref /\ - ( wrap - { address: - mkAddressUnsafe - "addr_test1vzcnxhr5u6ej3jzecxsef9pgr4g8nf0lxv92p53qluxdmjqtlwpvx" - , amount: Value.lovelaceValueOf lovelace - , datum: NoOutputDatum - , referenceScript: Nothing - } - ) - where - oref :: TransactionInput - oref = - mkOrefUnsafe - "3c55b6ce414f79ca8aacff50f12a006ca3a2abea746418ab6fcffa28fe372243" - -bidUtxoFixture0 :: AuctionInfo -> TransactionInput /\ TransactionOutput -bidUtxoFixture0 (AuctionInfo auctionInfo) = - oref /\ - ( wrap - { address: auctionInfo.standingBidAddr - , amount: - Value.lovelaceValueOf (BigInt.fromInt 1_099_050) - <> Value.singleton auctionCsFixture standingBidTokenName one - , datum: OutputDatum $ wrap $ toData $ StandingBidState Nothing - , referenceScript: Nothing - } - ) - where - oref :: TransactionInput - oref = - mkOrefUnsafe - "c4ed299e233d356731df46951744f46f3b6eff703a72aa12200a6c4517671d28" - -bidUtxoFixture1 :: AuctionInfo -> TransactionInput /\ TransactionOutput -bidUtxoFixture1 (AuctionInfo auctionInfo) = - oref /\ - ( wrap - { address: auctionInfo.standingBidAddr - , amount: - Value.lovelaceValueOf (BigInt.fromInt 2_228_270) - <> Value.singleton auctionCsFixture standingBidTokenName one - , datum: - OutputDatum $ wrap $ toData $ - StandingBidState (Just bidFixture0) - , referenceScript: Nothing - } - ) - where - oref :: TransactionInput - oref = - mkOrefUnsafe - "21f1a833c6a1f996332db62092f9c78455a55a85b501d035dd2e7d6250fba0dd" - -auctionInfoFixture :: POSIXTime -> Contract AuctionInfo -auctionInfoFixture biddingStart = do - let auctionTerms = auctionTermsFixture biddingStart - validators <- - liftedE $ runExceptT $ - mkAuctionValidators auctionCsFixture auctionTerms - let - validatorHashes = validatorHash <$> validators - validatorAddresses = unwrap $ flip scriptHashAddress Nothing <$> validatorHashes - auctionInfo = wrap - { auctionId: auctionCsFixture - , auctionTerms - , delegateInfo: Nothing - , auctionEscrowAddr: validatorAddresses.auctionEscrow - , bidderDepositAddr: validatorAddresses.bidderDeposit - , feeEscrowAddr: validatorAddresses.feeEscrow - , standingBidAddr: validatorAddresses.standingBid - } - pure auctionInfo - -auctionCsFixture :: CurrencySymbol -auctionCsFixture = - mkCurrencySymbolUnsafe - "2143328cbadfa6089c30c45089a6e4048c4ff05620c0ada52ee8d518" - -auctionTermsFixture :: POSIXTime -> AuctionTerms -auctionTermsFixture nowTime = wrap - { auctionLot: - Value.singleton - (mkCurrencySymbolUnsafe "c0f8644a01a6bf5db02f4afe30d604975e63dd274f1098a1738e561d") - (mkTokenNameUnsafe "4d6f6e614c697361") - one - , sellerAddress: - mkAddressUnsafe - "addr_test1qpsjljwwefv553ly43alu97cd5wtjvfdvqk9f76la7gejgw5p2hj0e0fx5lp95vk3055zcmy8ed\ - \f63uwpe37zhcnjvrsev08p0" - , sellerVk: - mkVerificationKeyUnsafe - "c059d4c74359ffe1b8326e03065ab08b0b8c2579cc32e29cf087257b59ec79e9" - , delegates: - [ mkPubKeyHashUnsafe - "ac55de689702d745e77050ce83b77ff9619383bb802e40fb90aa3be4" - ] - , biddingStart: zero - , biddingEnd: nowTime + mkPosixTimeUnsafe (Days one) - , purchaseDeadline: nowTime + mkPosixTimeUnsafe (Days 2.0) - , cleanup: nowTime + mkPosixTimeUnsafe (Days 3.0) - , auctionFeePerDelegate: BigInt.fromInt 3_000_000 - , startingBid: BigInt.fromInt 8_000_000 - , minBidIncrement: BigInt.fromInt 1_000_000 - , minDepositAmount: BigInt.fromInt 3_000_000 - } diff --git a/test/DelegateServer/PlaceBid/Suite.purs b/test/DelegateServer/PlaceBid/Suite.purs deleted file mode 100644 index 905a2ee..0000000 --- a/test/DelegateServer/PlaceBid/Suite.purs +++ /dev/null @@ -1,349 +0,0 @@ -module Test.DelegateServer.PlaceBid.Suite - ( patchContractEnv - , suite - ) where - -import Prelude - -import Contract.Config (NetworkId(TestnetId)) -import Contract.Monad (Contract, ContractEnv, liftedE) -import Contract.Test (ContractTest, noWallet) -import Contract.Test.Mote (TestPlanM) -import Contract.Time (POSIXTime) -import Contract.Transaction (Language(PlutusV2), Transaction) -import Control.Monad.Except (runExceptT) -import Control.Monad.Reader (ask, local) -import Ctl.Internal.Helpers ((<>)) -import Ctl.Internal.Plutip.Utils (tmpdir) -import Ctl.Internal.Types.Int (fromInt) -import Data.Codec.Argonaut (JsonCodec, array, encode, int, object) as CA -import Data.Codec.Argonaut.Record (record) as CAR -import Data.Either (Either(Left, Right), either) -import Data.Generic.Rep (class Generic) -import Data.Map (singleton) as Map -import Data.Maybe (Maybe(Just, Nothing)) -import Data.Newtype (modify, unwrap, wrap) -import Data.Posix.Signal (Signal(SIGINT)) -import Data.Show.Generic (genericShow) -import Data.String (Pattern(Pattern)) -import Data.String (contains) as String -import Data.Time.Duration (Minutes(Minutes)) -import Data.Tuple (fst, snd) -import Data.Tuple.Nested (type (/\), (/\)) -import Data.UInt (fromInt, toString) as UInt -import Data.UUID (genUUID, toString) as UUID -import DelegateServer.Contract.PlaceBid (PlaceBidL2ContractError, placeBidL2') -import DelegateServer.HydraNodeApi.Types.Message - ( HydraNodeApi_InMessage(In_HeadIsOpen, In_SnapshotConfirmed, In_TxInvalid) - , HydraNodeApi_OutMessage(Out_NewTx) - , hydraNodeApiInMessageCodec - , hydraNodeApiOutMessageCodec - ) -import DelegateServer.Lib.Contract (runContractNullCostsAff) -import DelegateServer.Lib.Wallet (withWallet) -import DelegateServer.Types.HydraUtxoMap (HydraUtxoMap, toUtxoMapWithoutRefScripts) -import DelegateServer.WebSocket (WebSocket, mkWebSocket) -import Effect (Effect) -import Effect.AVar (AVar) -import Effect.AVar (tryPut) as AVarSync -import Effect.Aff (Aff, launchAff, try) -import Effect.Aff.AVar (empty, take, tryPut) as AVar -import Effect.Aff.Class (liftAff) -import Effect.Class (liftEffect) -import Effect.Exception (Error, throw, throwException) -import Foreign.Object (insert) as Obj -import HydraAuctionOffchain.Codec (bigIntCodecNum, sysStartCodec) -import HydraAuctionOffchain.Contract.QueryUtxo (findStandingBidUtxo) -import HydraAuctionOffchain.Contract.Types (AuctionInfo, BidTerms, StandingBidState) -import HydraAuctionOffchain.Helpers (dateTimeFromPosixTimeUnsafe, mkPosixTimeUnsafe, nowPosix) -import HydraAuctionOffchain.Lib.Json (caDecodeFile, readJsonFromFile, writeJsonToFile) -import HydraAuctionOffchain.Types.HostPort (HostPort) -import JS.BigInt (BigInt) -import Mote (group, test) -import Node.ChildProcess (ChildProcess, defaultSpawnOptions, kill, spawn, stdout) -import Node.Encoding (Encoding(UTF8)) as Encoding -import Node.FS.Sync (exists, mkdir, rm') as FSSync -import Node.Path (FilePath) -import Node.Stream (onDataString) -import Test.DelegateServer.PlaceBid.Fixtures - ( auctionInfoFixture - , bidFixture0 - , bidFixture1 - , commitUtxoMapFixture0 - , commitUtxoMapFixture1 - ) -import Test.Spec.Assertions (fail, shouldEqual) - -suite :: TestPlanM ContractTest Unit -suite = - group "place-bid" do - test "valid transition from empty standing bid" do - runTest commitUtxoMapFixture0 bidFixture0 - mustSucceed - test "valid transition from non-empty standing bid" do - runTest commitUtxoMapFixture1 bidFixture1 - mustSucceed - ----------------------------------------------------------------------- --- Test - -data TestResult - = ContractError PlaceBidL2ContractError - | TxInvalid - | SnapshotConfirmed (Maybe StandingBidState) - -derive instance Generic TestResult _ -derive instance Eq TestResult - -instance Show TestResult where - show = genericShow - -mustSucceed :: BidTerms -> TestResult -> Aff Unit -mustSucceed bidTerms = case _ of - ContractError err -> - fail $ "PlaceBidL2 contract error: " <> show err <> "." - TxInvalid -> - fail $ "PlaceBidL2 tx invalid." - SnapshotConfirmed Nothing -> - fail $ "Could not find target standing bid in confirmed snapshot." - SnapshotConfirmed (Just standingBid) -> - shouldEqual standingBid $ wrap $ Just bidTerms - -runTest - :: (AuctionInfo -> HydraUtxoMap) - -> BidTerms - -> (BidTerms -> TestResult -> Aff Unit) - -> ContractTest -runTest mkCommitUtxoMap bidTerms callback = - noWallet $ withWallet appConfig.walletSk $ patchContractEnv' do - nowTime <- nowPosix - auctionInfo <- auctionInfoFixture nowTime - let initUtxoMap = mkCommitUtxoMap auctionInfo - (testResultReceivedSem :: AVar (Either Error Unit)) <- liftAff AVar.empty - contractEnv <- ask - let - testParams = - { auctionInfo - , bidTerms - , contractEnv - , callback: \res -> do - res' <- try $ callback bidTerms res - void $ AVar.tryPut res' testResultReceivedSem - } - (apiServerStartedSem :: AVar Unit) <- liftAff AVar.empty - hydraNodeProcess /\ workdir <- liftEffect $ runHydraNodeOfflineMode initUtxoMap - apiServerStartedSem - nowTime - liftAff $ AVar.take apiServerStartedSem - ws <- liftEffect $ mkHydraNodeApiWebSocket testParams - let - cleanupHandler = do - ws.baseWs.close - kill SIGINT hydraNodeProcess - FSSync.rm' workdir - { force: true - , maxRetries: zero - , recursive: true - , retryDelay: zero - } - res <- liftAff $ AVar.take testResultReceivedSem - liftEffect $ cleanupHandler - either (liftEffect <<< throwException) (const (pure unit)) res - ----------------------------------------------------------------------- --- Config - -type AppConfigTest = - { hydraNode :: HostPort - , hydraNodeApi :: HostPort - , hydraSk :: FilePath - , cardanoSk :: FilePath - , walletSk :: FilePath - , pparams :: FilePath - , genesisTemplate :: FilePath - } - -appConfig :: AppConfigTest -appConfig = - { hydraNode: { host: "127.0.0.1", port: UInt.fromInt 7050 } - , hydraNodeApi: { host: "127.0.0.1", port: UInt.fromInt 7051 } - , hydraSk: "test/data/keys/hydra.sk" - , cardanoSk: "test/data/keys/cardano.sk" - , walletSk: "test/data/keys/wallet.sk" - , pparams: "protocol-parameters.json" - , genesisTemplate: "test/data/genesis-template.json" - } - ----------------------------------------------------------------------- --- Hydra node - -runHydraNodeOfflineMode - :: HydraUtxoMap - -> AVar Unit - -> POSIXTime - -> Effect (ChildProcess /\ FilePath) -runHydraNodeOfflineMode initUtxoMap apiServerStartedSem sysStart = do - nodeId <- UUID.toString <$> UUID.genUUID - tmpDir <- tmpdir - let - workdir = tmpDir <> nodeId - initUtxoFp = workdir <> "utxo.json" - workdirExists <- FSSync.exists workdir - unless workdirExists (FSSync.mkdir workdir) - writeJsonToFile initUtxoFp initUtxoMap - let persistDir = workdir <> "persist-dir" - genesisFp <- genGenesisFromTemplate workdir sysStart - hydraNodeProcess <- spawn "hydra-node" (hydraNodeArgs nodeId persistDir initUtxoFp genesisFp) - defaultSpawnOptions - onDataString (stdout hydraNodeProcess) Encoding.UTF8 \str -> - when (String.contains (Pattern "APIServerStarted") str) do - void $ AVarSync.tryPut unit apiServerStartedSem - pure $ hydraNodeProcess /\ workdir - where - hydraNodeArgs :: String -> FilePath -> FilePath -> FilePath -> Array String - hydraNodeArgs nodeId persistDir initUtxoFp genesisFp = - [ "offline" - , "--node-id" - , nodeId - , "--host" - , appConfig.hydraNode.host - , "--port" - , UInt.toString appConfig.hydraNode.port - , "--api-host" - , appConfig.hydraNodeApi.host - , "--api-port" - , UInt.toString appConfig.hydraNodeApi.port - , "--persistence-dir" - , persistDir - , "--hydra-signing-key" - , appConfig.hydraSk - , "--cardano-signing-key" - , appConfig.cardanoSk - , "--ledger-protocol-parameters" - , appConfig.pparams - , "--ledger-genesis" - , genesisFp - , "--initial-utxo" - , initUtxoFp - ] - -genGenesisFromTemplate :: FilePath -> POSIXTime -> Effect FilePath -genGenesisFromTemplate workdir sysStartPosix' = do - genesisTemplate <- either throw pure =<< readJsonFromFile appConfig.genesisTemplate - let - sysStartPosix = sysStartPosix' - mkPosixTimeUnsafe (Minutes one) - sysStart = wrap $ dateTimeFromPosixTimeUnsafe sysStartPosix - genesisFp = workdir <> "genesis.json" - writeJsonToFile genesisFp $ - Obj.insert "systemStart" (CA.encode sysStartCodec sysStart) - genesisTemplate - pure genesisFp - ----------------------------------------------------------------------- --- WebSocket - -type TestParams = - { auctionInfo :: AuctionInfo - , bidTerms :: BidTerms - , contractEnv :: ContractEnv - , callback :: TestResult -> Aff Unit - } - -type HydraNodeApiWebSocketMock = - { baseWs :: WebSocket Contract HydraNodeApi_InMessage HydraNodeApi_OutMessage - , newTx :: Transaction -> Effect Unit - } - -mkHydraNodeApiWebSocket :: TestParams -> Effect HydraNodeApiWebSocketMock -mkHydraNodeApiWebSocket params = do - ws <- fst <$> mkWebSocket - { hostPort: appConfig.hydraNodeApi - , inMsgCodec: hydraNodeApiInMessageCodec - , outMsgCodec: hydraNodeApiOutMessageCodec - , runM: void <<< launchAff <<< runContractNullCostsAff params.contractEnv - } - let - hydraNodeApiWs :: HydraNodeApiWebSocketMock - hydraNodeApiWs = - { baseWs: ws - , newTx: ws.send <<< Out_NewTx <<< { transaction: _ } - } - ws.onMessage (messageHandler params hydraNodeApiWs) - pure hydraNodeApiWs - -messageHandler - :: TestParams - -> HydraNodeApiWebSocketMock - -> HydraNodeApi_InMessage - -> Contract Unit -messageHandler params ws = case _ of - In_HeadIsOpen { utxo } -> do - let utxos = toUtxoMapWithoutRefScripts utxo - res <- runExceptT $ placeBidL2' (unwrap params.auctionInfo) params.bidTerms ws.newTx - utxos - appConfig.cardanoSk - case res of - Left contractError -> - liftAff $ params.callback $ ContractError contractError - Right _ -> - pure unit - In_SnapshotConfirmed { snapshot } -> do - let utxos = toUtxoMapWithoutRefScripts (unwrap snapshot).utxo - liftAff $ params.callback $ SnapshotConfirmed $ snd <$> findStandingBidUtxo - (unwrap params.auctionInfo) - utxos - In_TxInvalid -> - liftAff $ params.callback TxInvalid - _ -> pure unit - ----------------------------------------------------------------------- --- ContractEnv - -patchContractEnv' :: forall (a :: Type). Contract a -> Contract a -patchContractEnv' contract = do - contractEnv <- patchContractEnv TestnetId - local (const contractEnv) contract - -patchContractEnv :: forall (a :: Type). NetworkId -> Contract ContractEnv -patchContractEnv network = do - pparams <- pparamsSlice - ask <#> \env -> env - { networkId = network - , ledgerConstants = - env.ledgerConstants - { pparams = - env.ledgerConstants.pparams # modify _ - { costModels = - wrap $ Map.singleton PlutusV2 - (wrap $ fromInt <$> pparams.costModels."PlutusV2") - , maxTxExUnits = - { mem: pparams.maxTxExecutionUnits.memory - , steps: pparams.maxTxExecutionUnits.steps - } - } - } - } - -pparamsSlice :: Contract PParamsSlice -pparamsSlice = - liftedE $ liftEffect $ - caDecodeFile pparamsSliceCodec appConfig.pparams - -type PParamsSlice = - { maxTxExecutionUnits :: { memory :: BigInt, steps :: BigInt } - , costModels :: { "PlutusV2" :: Array Int } - } - -pparamsSliceCodec :: CA.JsonCodec PParamsSlice -pparamsSliceCodec = - CA.object "PParamsSlice" $ CAR.record - { maxTxExecutionUnits: - CA.object "PParamsSlice:ExUnits" $ CAR.record - { memory: bigIntCodecNum - , steps: bigIntCodecNum - } - , costModels: - CA.object "PParamsSlice:CostModels" $ CAR.record - { "PlutusV2": CA.array CA.int - } - } diff --git a/test/Plutip.purs b/test/Plutip.purs index c83675e..4760f99 100644 --- a/test/Plutip.purs +++ b/test/Plutip.purs @@ -19,8 +19,6 @@ import Test.Contract.PlaceBid (suite) as PlaceBid import Test.Contract.StartBidding (suite) as StartBidding import Test.Plutip.Config (plutipConfig) --- import Test.DelegateServer.PlaceBid.Suite (suite) as PlaceBidL2 - main :: Effect Unit main = do fiber <- launchAff $ interpret suite @@ -36,5 +34,3 @@ suite = AuthorizeBidders.suite PlaceBid.suite DelegateServer.suite - --- PlaceBidL2.suite diff --git a/test/data/genesis-template.json b/test/data/genesis-template.json deleted file mode 100644 index 9867b69..0000000 --- a/test/data/genesis-template.json +++ /dev/null @@ -1,39 +0,0 @@ -{ - "activeSlotsCoeff": 0.05, - "protocolParams": { - "protocolVersion": { - "minor": 0, - "major": 2 - }, - "decentralisationParam": 1, - "eMax": 18, - "extraEntropy": { - "tag": "NeutralNonce" - }, - "maxTxSize": 16384, - "maxBlockBodySize": 65536, - "maxBlockHeaderSize": 1100, - "minFeeA": 44, - "minFeeB": 155381, - "minUTxOValue": 1000000, - "poolDeposit": 500000000, - "minPoolCost": 340000000, - "keyDeposit": 2000000, - "nOpt": 150, - "rho": 0.003, - "tau": 0.20, - "a0": 0.3 - }, - "genDelegs": {}, - "updateQuorum": 5, - "networkId": "Testnet", - "initialFunds": {}, - "maxLovelaceSupply": 45000000000000000, - "networkMagic": 1097911063, - "epochLength": 432000, - "systemStart": "2019-07-24T20:20:16Z", - "slotsPerKESPeriod": 129600, - "slotLength": 1, - "maxKESEvolutions": 62, - "securityParam": 2160 -} diff --git a/test/data/keys/cardano.sk b/test/data/keys/cardano.sk deleted file mode 100644 index f56df38..0000000 --- a/test/data/keys/cardano.sk +++ /dev/null @@ -1,5 +0,0 @@ -{ - "type": "PaymentSigningKeyShelley_ed25519", - "description": "Payment Signing Key", - "cborHex": "5820a2fa1283f10713006c04d04473053ed9f038653591946a2b3d3bd414cc26b768" -} diff --git a/test/data/keys/cardano.vk b/test/data/keys/cardano.vk deleted file mode 100644 index 13325ea..0000000 --- a/test/data/keys/cardano.vk +++ /dev/null @@ -1,5 +0,0 @@ -{ - "type": "PaymentVerificationKeyShelley_ed25519", - "description": "Payment Verification Key", - "cborHex": "58200442e7446c461bad220a688b88f42e4bf9e1fab3dcec7ca9e32c2e9382016531" -} diff --git a/test/data/keys/hydra.sk b/test/data/keys/hydra.sk deleted file mode 100644 index 4d42b3b..0000000 --- a/test/data/keys/hydra.sk +++ /dev/null @@ -1,5 +0,0 @@ -{ - "type": "HydraSigningKey_ed25519", - "description": "", - "cborHex": "5820da0fe2e3e408d81d2cdb4e7611666df9ef51af0a40c5335f299f7193936abfd0" -} diff --git a/test/data/keys/hydra.vk b/test/data/keys/hydra.vk deleted file mode 100644 index 907c19e..0000000 --- a/test/data/keys/hydra.vk +++ /dev/null @@ -1,5 +0,0 @@ -{ - "type": "HydraVerificationKey_ed25519", - "description": "", - "cborHex": "5820178e85034c7a2452e8b0d6396463183d94ad207848a010e2fe37b58f0bbd14a0" -} diff --git a/test/data/keys/wallet.sk b/test/data/keys/wallet.sk deleted file mode 100644 index d751158..0000000 --- a/test/data/keys/wallet.sk +++ /dev/null @@ -1,5 +0,0 @@ -{ - "type": "PaymentSigningKeyShelley_ed25519", - "description": "Payment Signing Key", - "cborHex": "582060ce2f4625dbb91e713a727e8c8996179d2aa486585354196c5dc248db492e3d" -} diff --git a/test/data/keys/wallet.vk b/test/data/keys/wallet.vk deleted file mode 100644 index 5f57ec2..0000000 --- a/test/data/keys/wallet.vk +++ /dev/null @@ -1,5 +0,0 @@ -{ - "type": "PaymentVerificationKeyShelley_ed25519", - "description": "Payment Verification Key", - "cborHex": "58204e82cd5841612792f312bab42b9627d09b11e240c1068b55372c3a94b85d87f7" -}