diff --git a/README.md b/README.md index 9cd296d..b0cc9fc 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,7 @@ # seabug-contracts A library for interacting with Seabug smart contracts via the Cardano Transaction Lib (CTL). + +## Tests + +Use `spago test` to run the tests. Something like `nix build .#checks..seabug-contracts` can also be used, where `` is something like `x86_64-linux`. diff --git a/flake.lock b/flake.lock index 4776a6b..620c74b 100644 --- a/flake.lock +++ b/flake.lock @@ -549,17 +549,17 @@ "servant-purescript": "servant-purescript" }, "locked": { - "lastModified": 1654207766, - "narHash": "sha256-HeN/bCFrR/Epc6NTx5GO6UmEXACdtrLHt6p4VCFI2xE=", + "lastModified": 1654586193, + "narHash": "sha256-eunqLMnBekc4vmc5b1IsZlOYvJ9PuLVMKWKwZBwxJ6E=", "owner": "Plutonomicon", "repo": "cardano-transaction-lib", - "rev": "5c7e3dd0d6c001df1d7c8e7b675e1d79530dbdff", + "rev": "a8aabb842ecc1e287d4a60ea4f4c6cff6fbfeea7", "type": "github" }, "original": { "owner": "Plutonomicon", "repo": "cardano-transaction-lib", - "rev": "5c7e3dd0d6c001df1d7c8e7b675e1d79530dbdff", + "rev": "a8aabb842ecc1e287d4a60ea4f4c6cff6fbfeea7", "type": "github" } }, diff --git a/spago.dhall b/spago.dhall index af4dd4e..9ef77d6 100644 --- a/spago.dhall +++ b/spago.dhall @@ -14,16 +14,21 @@ You can edit this file as you like. , "bifunctors" , "bigints" , "cardano-transaction-lib" + , "const" , "control" , "debug" , "effect" + , "either" , "exceptions" + , "foldable-traversable" , "http-methods" , "maybe" + , "mote" , "newtype" , "ordered-collections" , "partial" , "prelude" + , "spec" , "transformers" , "tuples" , "uint" diff --git a/src/Seabug/CallContract.purs b/src/Seabug/CallContract.purs index 1e0f4e8..9623638 100644 --- a/src/Seabug/CallContract.purs +++ b/src/Seabug/CallContract.purs @@ -46,8 +46,8 @@ import Effect (Effect) import Effect.Aff (error) import Effect.Class (liftEffect) import Effect.Exception (Error) -import Metadata.Seabug (SeabugMetadata(SeabugMetadata)) -import Metadata.Seabug.Share (unShare) +import Seabug.Metadata.Types (SeabugMetadata(SeabugMetadata)) +import Seabug.Metadata.Share (unShare) import Partial.Unsafe (unsafePartial) import Plutus.FromPlutusType (fromPlutusType) import Seabug.Contract.MarketPlaceBuy (marketplaceBuy) diff --git a/src/Seabug/Contract/MarketPlaceBuy.purs b/src/Seabug/Contract/MarketPlaceBuy.purs index 19f4180..69aebcb 100644 --- a/src/Seabug/Contract/MarketPlaceBuy.purs +++ b/src/Seabug/Contract/MarketPlaceBuy.purs @@ -131,8 +131,8 @@ mkMarketplaceTx (NftData nftData) = do newName <- liftedM "marketplaceBuy: Cannot hash new token" $ mkTokenName newNft log $ "curr: " <> show curr - log $ "oldName: " <> show oldName - log $ "newName: " <> show newName + log $ "oldName: " <> show oldName + log $ "newName: " <> show newName let oldNftValue = Value.singleton curr oldName $ negate one newNftValue = Value.singleton curr newName one diff --git a/src/Seabug/Metadata.purs b/src/Seabug/Metadata.purs index ccb0961..39cc600 100644 --- a/src/Seabug/Metadata.purs +++ b/src/Seabug/Metadata.purs @@ -32,7 +32,7 @@ import Data.Bifunctor (bimap, lmap) import Data.Function (on) import Data.HTTP.Method (Method(GET)) import Data.Newtype (unwrap) -import Metadata.Seabug (SeabugMetadata(SeabugMetadata)) +import Seabug.Metadata.Types (SeabugMetadata(SeabugMetadata)) import Partial.Unsafe (unsafePartial) import Types.CborBytes (cborBytesToByteArray) diff --git a/src/Seabug/Metadata/Share.purs b/src/Seabug/Metadata/Share.purs new file mode 100644 index 0000000..a0041ec --- /dev/null +++ b/src/Seabug/Metadata/Share.purs @@ -0,0 +1,49 @@ +module Seabug.Metadata.Share + ( Share + , mkShare + , unShare + ) where + +import Prelude + +import Data.BigInt (BigInt) +import Data.BigInt as BigInt +import Data.Maybe (Maybe(Just, Nothing)) +import FromData (class FromData) +import Metadata.FromMetadata (class FromMetadata) +import Metadata.ToMetadata (class ToMetadata, toMetadata) +import ToData (class ToData) +import Types.Int (toBigInt) as Int +import Types.PlutusData (PlutusData(Integer)) +import Types.TransactionMetadata (TransactionMetadatum(Int)) as Metadata + +-- | A number between 0 and 10000 (inclusive) representing percentage of the price. +newtype Share = Share BigInt + +derive newtype instance ToData Share + +instance FromData Share where + fromData (Integer n) = BigInt.toInt n >>= mkShare + fromData _ = Nothing + +instance ToMetadata Share where + -- Must be safe when `Share` is built using `mkShare` smart constructor. + toMetadata = toMetadata <<< unShare + +instance FromMetadata Share where + fromMetadata (Metadata.Int n) = + BigInt.toInt (Int.toBigInt n) >>= mkShare + fromMetadata _ = Nothing + +instance Show Share where + show (Share share) = "(mkShare (" <> show share <> "))" + +derive instance Eq Share + +mkShare :: Int -> Maybe Share +mkShare n + | n >= 0 && n <= 10000 = Just $ Share $ BigInt.fromInt n + | otherwise = Nothing + +unShare :: Share -> BigInt +unShare (Share n) = n diff --git a/src/Seabug/Metadata/Types.purs b/src/Seabug/Metadata/Types.purs new file mode 100644 index 0000000..6cc5f34 --- /dev/null +++ b/src/Seabug/Metadata/Types.purs @@ -0,0 +1,286 @@ +module Seabug.Metadata.Types + ( SeabugMetadata(SeabugMetadata) + , SeabugMetadataDelta(SeabugMetadataDelta) + ) where + +import Prelude + +import Aeson + ( class DecodeAeson + , JsonDecodeError + ( TypeMismatch + ) + , caseAesonObject + , decodeAeson + , getField + ) +import Data.BigInt (fromInt) as BigInt +import Data.Either (Either(Left), note) +import Data.Generic.Rep (class Generic) +import Data.Map (toUnfoldable) as Map +import Data.Maybe (Maybe(Nothing), fromJust) +import Data.Newtype (class Newtype, wrap) +import Data.Show.Generic (genericShow) +import Data.Tuple (Tuple(Tuple)) +import Data.Tuple.Nested ((/\)) +import FromData (class FromData, fromData) +import Metadata.Helpers (unsafeMkKey, lookupKey, lookupMetadata) +import Seabug.Metadata.Share (Share, mkShare) +import Metadata.FromMetadata (class FromMetadata, fromMetadata) +import Metadata.MetadataType (class MetadataType, metadataLabel) +import Metadata.ToMetadata (class ToMetadata, toMetadata) +import Partial.Unsafe (unsafePartial) +import Plutus.Types.AssocMap (Map(Map)) as AssocMap +import ToData (class ToData, toData) +import Serialization.Hash (ScriptHash, scriptHashFromBytes) +import Type.Proxy (Proxy(Proxy)) +import Types.ByteArray (ByteArray, hexToByteArray) +import Types.RawBytes (hexToRawBytesUnsafe) +import Types.Natural (Natural) +import Types.PlutusData (PlutusData(Map)) +import Types.PubKeyHash (PubKeyHash) +import Types.Scripts (MintingPolicyHash, ValidatorHash) +import Cardano.Types.Value (CurrencySymbol, mkCurrencySymbol) +import Types.TokenName (TokenName, mkTokenName) +import Types.TransactionMetadata (TransactionMetadatum(MetadataMap)) + +newtype SeabugMetadata = SeabugMetadata + { policyId :: MintingPolicyHash + , mintPolicy :: ByteArray + , collectionNftCS :: CurrencySymbol + , collectionNftTN :: TokenName + , lockingScript :: ValidatorHash + , authorPkh :: PubKeyHash + , authorShare :: Share + , marketplaceScript :: ValidatorHash + , marketplaceShare :: Share + , ownerPkh :: PubKeyHash + , ownerPrice :: Natural + } + +derive instance Generic SeabugMetadata _ +derive instance Newtype SeabugMetadata _ +derive instance Eq SeabugMetadata + +instance Show SeabugMetadata where + show = genericShow + +instance MetadataType SeabugMetadata where + metadataLabel _ = wrap (BigInt.fromInt 727) + +instance ToMetadata SeabugMetadata where + toMetadata (SeabugMetadata meta) = toMetadata + [ meta.policyId /\ + [ "mintPolicy" /\ toMetadata meta.mintPolicy + , "collectionNftCS" /\ toMetadata meta.collectionNftCS + , "collectionNftTN" /\ toMetadata meta.collectionNftTN + , "lockingScript" /\ toMetadata meta.lockingScript + , "authorPkh" /\ toMetadata meta.authorPkh + , "authorShare" /\ toMetadata meta.authorShare + , "marketplaceScript" /\ toMetadata meta.marketplaceScript + , "marketplaceShare" /\ toMetadata meta.marketplaceShare + , "ownerPkh" /\ toMetadata meta.ownerPkh + , "ownerPrice" /\ toMetadata meta.ownerPrice + ] + ] + +instance FromMetadata SeabugMetadata where + fromMetadata (MetadataMap mp) = do + policyId /\ contents <- case Map.toUnfoldable mp of + [ policyId /\ contents ] -> + Tuple <$> fromMetadata policyId <*> pure contents + _ -> Nothing + mintPolicy <- + lookupMetadata "mintPolicy" contents >>= fromMetadata + collectionNftCS <- + lookupMetadata "collectionNftCS" contents >>= fromMetadata + collectionNftTN <- + lookupMetadata "collectionNftTN" contents >>= fromMetadata + lockingScript <- + lookupMetadata "lockingScript" contents >>= fromMetadata + authorPkh <- + lookupMetadata "authorPkh" contents >>= fromMetadata + authorShare <- + lookupMetadata "authorShare" contents >>= fromMetadata + marketplaceScript <- + lookupMetadata "marketplaceScript" contents >>= fromMetadata + marketplaceShare <- + lookupMetadata "marketplaceShare" contents >>= fromMetadata + ownerPkh <- + lookupMetadata "ownerPkh" contents >>= fromMetadata + ownerPrice <- + lookupMetadata "ownerPrice" contents >>= fromMetadata + pure $ SeabugMetadata + { policyId + , mintPolicy + , collectionNftCS + , collectionNftTN + , lockingScript + , authorPkh + , authorShare + , marketplaceScript + , marketplaceShare + , ownerPkh + , ownerPrice + } + fromMetadata _ = Nothing + +instance ToData SeabugMetadata where + toData (SeabugMetadata meta) = unsafePartial $ toData $ AssocMap.Map + [ unsafeMkKey "727" /\ AssocMap.Map + [ meta.policyId /\ AssocMap.Map + [ unsafeMkKey "mintPolicy" /\ toData meta.mintPolicy + , unsafeMkKey "collectionNftCS" /\ toData meta.collectionNftCS + , unsafeMkKey "collectionNftTN" /\ toData meta.collectionNftTN + , unsafeMkKey "lockingScript" /\ toData meta.lockingScript + , unsafeMkKey "authorPkh" /\ toData meta.authorPkh + , unsafeMkKey "authorShare" /\ toData meta.authorShare + , unsafeMkKey "marketplaceScript" /\ toData meta.marketplaceScript + , unsafeMkKey "marketplaceShare" /\ toData meta.marketplaceShare + , unsafeMkKey "ownerPkh" /\ toData meta.ownerPkh + , unsafeMkKey "ownerPrice" /\ toData meta.ownerPrice + ] + ] + ] + +instance FromData SeabugMetadata where + fromData sm = unsafePartial do + policyId /\ contents <- lookupKey "727" sm >>= case _ of + Map [ policyId /\ contents ] -> + Tuple <$> fromData policyId <*> fromData contents + _ -> Nothing + mintPolicy <- lookupKey "mintPolicy" contents >>= fromData + collectionNftCS <- lookupKey "collectionNftCS" contents >>= fromData + collectionNftTN <- lookupKey "collectionNftTN" contents >>= fromData + lockingScript <- lookupKey "lockingScript" contents >>= fromData + authorPkh <- lookupKey "authorPkh" contents >>= fromData + authorShare <- lookupKey "authorShare" contents >>= fromData + marketplaceScript <- lookupKey "marketplaceScript" contents >>= fromData + marketplaceShare <- lookupKey "marketplaceShare" contents >>= fromData + ownerPkh <- lookupKey "ownerPkh" contents >>= fromData + ownerPrice <- lookupKey "ownerPrice" contents >>= fromData + pure $ SeabugMetadata + { policyId + , mintPolicy + , collectionNftCS + , collectionNftTN + , lockingScript + , authorPkh + , authorShare + , marketplaceScript + , marketplaceShare + , ownerPkh + , ownerPrice + } + +instance DecodeAeson SeabugMetadata where + decodeAeson = + caseAesonObject + (Left (TypeMismatch "Expected object")) + $ \o -> do + collectionNftCS <- + note (TypeMismatch "Invalid ByteArray") + <<< (mkCurrencySymbol <=< hexToByteArray) + =<< getField o "collectionNftCS" + collectionNftTN <- + note (TypeMismatch "expected ASCII-encoded `TokenName`") + <<< (mkTokenName <=< hexToByteArray) + =<< getField o "collectionNftTN" + lockingScript <- + map wrap + <<< decodeScriptHash =<< getField o "lockingScript" + authorPkh <- + map wrap + <<< decodeAeson =<< getField o "authorPkh" + authorShare <- decodeShare =<< getField o "authorShare" + marketplaceScript <- map wrap <<< decodeScriptHash + =<< getField o "marketplaceScript" + marketplaceShare <- decodeShare =<< getField o "marketplaceShare" + ownerPkh <- map wrap <<< decodeAeson =<< getField o + "ownerPkh" + ownerPrice <- getField o "ownerPrice" + pure $ SeabugMetadata + { -- Not used in the endpoints where we parse the metadata, so we + -- can set a dummy value + policyId: wrap + $ unsafePartial + $ fromJust + $ scriptHashFromBytes + $ hexToRawBytesUnsafe + "00000000000000000000000000000000000000000000000000000000" + , mintPolicy: mempty + , collectionNftCS + , collectionNftTN + , lockingScript + , authorPkh + , authorShare + , marketplaceScript + , marketplaceShare + , ownerPkh + , ownerPrice + } + where + decodeShare :: Int -> Either JsonDecodeError Share + decodeShare = note (TypeMismatch "Expected int between 0 and 10000") + <<< mkShare + + decodeScriptHash :: String -> Either JsonDecodeError ScriptHash + decodeScriptHash = + note + (TypeMismatch "Expected hex-encoded script hash") + <<< (scriptHashFromBytes <<< wrap <=< hexToByteArray) + +newtype SeabugMetadataDelta = SeabugMetadataDelta + { policyId :: MintingPolicyHash + , ownerPkh :: PubKeyHash + , ownerPrice :: Natural + } + +derive instance Generic SeabugMetadataDelta _ +derive instance Newtype SeabugMetadataDelta _ +derive instance Eq SeabugMetadataDelta + +instance Show SeabugMetadataDelta where + show = genericShow + +instance MetadataType SeabugMetadataDelta where + metadataLabel _ = metadataLabel (Proxy :: Proxy SeabugMetadata) + +instance ToMetadata SeabugMetadataDelta where + toMetadata (SeabugMetadataDelta meta) = toMetadata + [ meta.policyId /\ + [ "ownerPkh" /\ toMetadata meta.ownerPkh + , "ownerPrice" /\ toMetadata meta.ownerPrice + ] + ] + +instance FromMetadata SeabugMetadataDelta where + fromMetadata (MetadataMap mp) = do + policyId /\ contents <- case Map.toUnfoldable mp of + [ policyId /\ contents ] -> + Tuple <$> fromMetadata policyId <*> pure contents + _ -> Nothing + ownerPkh <- lookupMetadata "ownerPkh" contents >>= fromMetadata + ownerPrice <- lookupMetadata "ownerPrice" contents >>= fromMetadata + pure $ SeabugMetadataDelta { policyId, ownerPkh, ownerPrice } + fromMetadata _ = Nothing + +instance ToData SeabugMetadataDelta where + toData (SeabugMetadataDelta meta) = unsafePartial $ toData $ AssocMap.Map + [ unsafeMkKey "727" /\ AssocMap.Map + [ meta.policyId /\ AssocMap.Map + [ unsafeMkKey "ownerPkh" /\ toData meta.ownerPkh + , unsafeMkKey "ownerPrice" /\ toData meta.ownerPrice + ] + ] + ] + +instance FromData SeabugMetadataDelta where + fromData sm = unsafePartial do + policyId /\ contents <- lookupKey "727" sm >>= case _ of + Map [ policyId /\ contents ] -> + Tuple <$> fromData policyId <*> fromData contents + _ -> Nothing + ownerPkh <- lookupKey "ownerPkh" contents >>= fromData + ownerPrice <- lookupKey "ownerPrice" contents >>= fromData + pure $ SeabugMetadataDelta { policyId, ownerPkh, ownerPrice } diff --git a/test/Fixtures.purs b/test/Fixtures.purs new file mode 100644 index 0000000..a9a76b8 --- /dev/null +++ b/test/Fixtures.purs @@ -0,0 +1,102 @@ +-- Feel free to update binary fixtures if they do not match the results you are +-- getting in tests. However, make sure you understand the reason why they +-- don't match. +-- To update the fixture, simply copy the value from failing test output. +-- +-- Or construct a value using CSL and get the hex string: +-- +-- ``` +-- const byteArrayToHex = arr => Buffer.from(arr).toString('hex'); +-- console.log(byteArrayToHex(something.to_bytes())) +-- ``` +module Test.Fixtures + ( seabugMetadataDeltaFixture1 + , seabugMetadataFixture1 + ) where + +import Prelude + +import Contract.Address (Ed25519KeyHash, PubKeyHash(..)) +import Contract.Numeric.Natural as Natural +import Contract.Prelude (fromJust) +import Contract.Prim.ByteArray (hexToByteArrayUnsafe) +import Contract.Scripts (MintingPolicyHash(..), ScriptHash, ValidatorHash(..)) +import Contract.Value (TokenName, mkTokenName) +import Data.BigInt as BigInt +import Metadata.Seabug (SeabugMetadata(..), SeabugMetadataDelta(..)) +import Metadata.Seabug.Share (Share, mkShare) +import Partial.Unsafe (unsafePartial) +import Serialization.Hash (ed25519KeyHashFromBytes, scriptHashFromBytes) +import Types.RawBytes (hexToRawBytesUnsafe) +import Cardano.Types.Value (CurrencySymbol, mkCurrencySymbol) + +currencySymbol1 :: CurrencySymbol +currencySymbol1 = unsafePartial $ fromJust $ mkCurrencySymbol $ + hexToByteArrayUnsafe + "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e" + +tokenName1 :: TokenName +tokenName1 = unsafePartial $ fromJust $ mkTokenName $ + hexToByteArrayUnsafe "4974657374546f6b656e" + +ed25519KeyHashFixture1 :: Ed25519KeyHash +ed25519KeyHashFixture1 = + -- $ Bech32 "hstk_1rsf0q0q77t5nttxrtmpwd7tvv58a80a686t92pgy65ekz0s8ncu" + unsafePartial $ fromJust + $ ed25519KeyHashFromBytes + $ hexToRawBytesUnsafe + "1c12f03c1ef2e935acc35ec2e6f96c650fd3bfba3e96550504d53361" + +ed25519KeyHashFixture2 :: Ed25519KeyHash +ed25519KeyHashFixture2 = + -- "hbas_1xranhpfej50zdup5jy995dlj9juem9x36syld8wm465hz92acfp" + unsafePartial $ fromJust + $ ed25519KeyHashFromBytes + $ hexToRawBytesUnsafe + "30fb3b8539951e26f034910a5a37f22cb99d94d1d409f69ddbaea971" + +scriptHash1 :: ScriptHash +scriptHash1 = unsafePartial $ fromJust $ scriptHashFromBytes $ + hexToRawBytesUnsafe + "5d677265fa5bb21ce6d8c7502aca70b9316d10e958611f3c6b758f65" + +scriptHash2 :: ScriptHash +scriptHash2 = unsafePartial $ fromJust $ scriptHashFromBytes $ + hexToRawBytesUnsafe + "00000000005bb21ce6d8c7502aca70b9316d10e958611f3c6b758f60" + +policyId :: MintingPolicyHash +policyId = MintingPolicyHash scriptHash1 + +validatorHashFixture1 :: ValidatorHash +validatorHashFixture1 = ValidatorHash scriptHash1 + +validatorHashFixture2 :: ValidatorHash +validatorHashFixture2 = ValidatorHash scriptHash2 + +shareFixture :: Share +shareFixture = unsafePartial $ fromJust $ mkShare 100 + +seabugMetadataFixture1 :: SeabugMetadata +seabugMetadataFixture1 = SeabugMetadata + { policyId: policyId + , mintPolicy: hexToByteArrayUnsafe "00000000" + , collectionNftCS: currencySymbol1 + , collectionNftTN: tokenName1 + , lockingScript: validatorHashFixture1 + , authorPkh: PubKeyHash ed25519KeyHashFixture1 + , authorShare: shareFixture + , marketplaceScript: validatorHashFixture2 + , marketplaceShare: shareFixture + , ownerPkh: PubKeyHash ed25519KeyHashFixture2 + , ownerPrice: unsafePartial $ fromJust $ Natural.fromBigInt $ BigInt.fromInt + 10 + } + +seabugMetadataDeltaFixture1 :: SeabugMetadataDelta +seabugMetadataDeltaFixture1 = SeabugMetadataDelta + { policyId: policyId + , ownerPkh: PubKeyHash ed25519KeyHashFixture2 + , ownerPrice: unsafePartial $ fromJust $ Natural.fromBigInt $ BigInt.fromInt + 10 + } diff --git a/test/Main.purs b/test/Main.purs index 7c1d23f..f859310 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -2,5 +2,13 @@ module Test.Main (main) where import Contract.Prelude +import Contract.Monad (launchAff_) +import Test.Metadata as Metadata +import Test.Util (interpret) +import TestM (TestPlanM) + main :: Effect Unit -main = log "Hello Purescript!" +main = launchAff_ $ interpret unitTestPlan + +unitTestPlan :: TestPlanM Unit +unitTestPlan = Metadata.suite diff --git a/test/Metadata.purs b/test/Metadata.purs new file mode 100644 index 0000000..ae54101 --- /dev/null +++ b/test/Metadata.purs @@ -0,0 +1,31 @@ +module Test.Metadata + ( suite + ) where + +import Prelude + +import Data.Maybe (Maybe(Just)) +import FromData (fromData) +import Metadata.MetadataType (fromGeneralTxMetadata, toGeneralTxMetadata) +import Mote (group, test) +import Test.Fixtures (seabugMetadataFixture1, seabugMetadataDeltaFixture1) +import Test.Spec.Assertions (shouldEqual) +import TestM (TestPlanM) +import ToData (toData) + +suite :: TestPlanM Unit +suite = do + group "Seabug Metadata" $ do + test "MetadataType instance" do + fromGeneralTxMetadata (toGeneralTxMetadata seabugMetadataFixture1) + `shouldEqual` Just seabugMetadataFixture1 + test "FromData / ToData instances" do + fromData (toData seabugMetadataFixture1) `shouldEqual` Just + seabugMetadataFixture1 + group "Seabug Metadata delta" $ do + test "MetadataType instance" do + fromGeneralTxMetadata (toGeneralTxMetadata seabugMetadataDeltaFixture1) + `shouldEqual` Just seabugMetadataDeltaFixture1 + test "FromData / ToData instances" do + fromData (toData seabugMetadataDeltaFixture1) `shouldEqual` Just + seabugMetadataDeltaFixture1 diff --git a/test/TestM.purs b/test/TestM.purs new file mode 100644 index 0000000..c481b35 --- /dev/null +++ b/test/TestM.purs @@ -0,0 +1,10 @@ +module TestM + ( TestPlanM + ) where + +import Prelude +import Data.Const (Const) +import Effect.Aff (Aff) +import Mote (MoteT) + +type TestPlanM a = MoteT (Const Void) (Aff Unit) Aff a diff --git a/test/Util.purs b/test/Util.purs new file mode 100644 index 0000000..3493748 --- /dev/null +++ b/test/Util.purs @@ -0,0 +1,31 @@ +module Test.Util + ( interpret + ) where + +import Prelude + +import Data.Const (Const) +import Data.Foldable (sequence_) +import Data.Maybe (Maybe(Just)) +import Data.Newtype (wrap) +import Effect.Aff (Aff) +import Effect.Aff.Class (liftAff) +import Mote (Plan, foldPlan, planT) +import Test.Spec (Spec, describe, it, pending) +import Test.Spec.Reporter (consoleReporter) +import Test.Spec.Runner (defaultConfig, runSpec') +import TestM (TestPlanM) + +interpret :: TestPlanM Unit -> Aff Unit +interpret spif = do + plan <- planT spif + runSpec' defaultConfig { timeout = Just (wrap 10000.0) } [ consoleReporter ] $ + go plan + where + go :: Plan (Const Void) (Aff Unit) -> Spec Unit + go = + foldPlan + (\x -> it x.label $ liftAff x.value) + pending + (\x -> describe x.label $ go x.value) + sequence_