From 2942a5700427d1c6ffb5c99dab29a9a87e5012b2 Mon Sep 17 00:00:00 2001 From: devfull <26844641+devfull@users.noreply.github.com> Date: Wed, 24 Aug 2022 16:37:49 +0200 Subject: [PATCH 01/15] [vesting] rewrite the private sale module --- bin/cardano-address-script | 38 + src/Tokenomia/Common/Aeson/AssetClass.hs | 32 + src/Tokenomia/Common/Arbitrary/AssetClass.hs | 41 + src/Tokenomia/Common/Arbitrary/Builtins.hs | 27 + src/Tokenomia/Common/Arbitrary/Modifiers.hs | 10 + src/Tokenomia/Common/Arbitrary/POSIXTime.hs | 31 + src/Tokenomia/Common/Arbitrary/Slot.hs | 18 + src/Tokenomia/Common/Arbitrary/Wallet.hs | 205 +++++ src/Tokenomia/Common/Data/List/Extra.hs | 28 + src/Tokenomia/Common/Parser/Address.hs | 94 +++ src/Tokenomia/Common/Time.hs | 33 + .../TokenDistribution/Distribution.hs | 13 +- src/Tokenomia/Vesting/GenerateNative.hs | 793 +++++++++++------- test/Spec.hs | 22 +- test/Spec/Tokenomia/Common/Data/List/Extra.hs | 63 ++ test/Spec/Tokenomia/Common/Parser/Address.hs | 34 + test/Spec/Tokenomia/Common/Time.hs | 79 ++ test/Spec/Tokenomia/Vesting/GenerateNative.hs | 546 ++++++++++++ tokenomia.cabal | 20 +- 19 files changed, 1809 insertions(+), 318 deletions(-) create mode 100755 bin/cardano-address-script create mode 100644 src/Tokenomia/Common/Aeson/AssetClass.hs create mode 100644 src/Tokenomia/Common/Arbitrary/AssetClass.hs create mode 100644 src/Tokenomia/Common/Arbitrary/Builtins.hs create mode 100644 src/Tokenomia/Common/Arbitrary/Modifiers.hs create mode 100644 src/Tokenomia/Common/Arbitrary/POSIXTime.hs create mode 100644 src/Tokenomia/Common/Arbitrary/Slot.hs create mode 100644 src/Tokenomia/Common/Arbitrary/Wallet.hs create mode 100644 src/Tokenomia/Common/Data/List/Extra.hs create mode 100644 src/Tokenomia/Common/Parser/Address.hs create mode 100644 src/Tokenomia/Common/Time.hs create mode 100644 test/Spec/Tokenomia/Common/Data/List/Extra.hs create mode 100644 test/Spec/Tokenomia/Common/Parser/Address.hs create mode 100644 test/Spec/Tokenomia/Common/Time.hs create mode 100644 test/Spec/Tokenomia/Vesting/GenerateNative.hs diff --git a/bin/cardano-address-script b/bin/cardano-address-script new file mode 100755 index 00000000..8085e570 --- /dev/null +++ b/bin/cardano-address-script @@ -0,0 +1,38 @@ +#!/bin/bash + +# This script is a wrapper around cardano-address. +# +# By default, cardano-address takes its input from stdin. For now, piping with +# (|>) from Shh.Internal leads to unexpected behaviour when doing IO inside the +# PropertyM transformer of QuickCheck. With (|>)¸the command cardano-address +# sometimes does not receive stdin and hang indefinitely, probably due to a +# strictness issue of the monads involved. +# +# The purpose of this script is to provide a hack, hidding the plumbing inside a +# bash script to avoid depending on the pipe from Haskell. The parameter +# following `--` is taken as the input for cardano-address. The rest of the +# arguments are propagated as-is. +# +# In order to use cardano-address in property testing from Haskell, you must +# install this script on your path. + +args=() + +while [ $# -gt 0 ]; do + case "$1" in + "--") + shift + break 2 + ;; + *) + args+=("$1") + shift + ;; + esac +done + +if [ -t 0 ]; then + printf '%s\n' "$1" +else + cat - +fi | cardano-address "${args[@]}" diff --git a/src/Tokenomia/Common/Aeson/AssetClass.hs b/src/Tokenomia/Common/Aeson/AssetClass.hs new file mode 100644 index 00000000..b80dcdee --- /dev/null +++ b/src/Tokenomia/Common/Aeson/AssetClass.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Tokenomia.Common.Aeson.AssetClass + ( assetClassFromJSON + , assetClassToJSON + ) where + +import Control.Arrow ( (***) ) + +import Data.Aeson.Types ( Parser ) +import Data.Aeson ( Value, object, withObject, (.:), (.=) ) +import Data.String ( IsString(..) ) + +import Plutus.V1.Ledger.Value ( AssetClass(..), assetClass, toString ) + + +-- | Alternative AssetClass Parser to the FromJSON instance +assetClassFromJSON :: Value -> Parser AssetClass +assetClassFromJSON = withObject "AssetClass" $ \o -> + assetClass + <$> (fromString <$> o .: "currencySymbol") + <*> (fromString <$> o .: "tokenName") + +-- | Alternative AssetClass Value to the ToJSON instance +assetClassToJSON :: AssetClass -> Value +assetClassToJSON x = + let (currencySymbol, tokenName) = (show *** toString) $ unAssetClass x + in + object + [ "currencySymbol" .= currencySymbol + , "tokenName" .= tokenName + ] diff --git a/src/Tokenomia/Common/Arbitrary/AssetClass.hs b/src/Tokenomia/Common/Arbitrary/AssetClass.hs new file mode 100644 index 00000000..00325aef --- /dev/null +++ b/src/Tokenomia/Common/Arbitrary/AssetClass.hs @@ -0,0 +1,41 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Tokenomia.Common.Arbitrary.AssetClass + () where + +import Plutus.V1.Ledger.Value + ( AssetClass(..) + , CurrencySymbol (..) + , TokenName (..) + ) + +import Test.Tasty.QuickCheck + ( Arbitrary + , CoArbitrary + , Function + , arbitrary + , shrink + ) + +import Tokenomia.Common.Arbitrary.Builtins () + + +instance Arbitrary CurrencySymbol where + arbitrary = CurrencySymbol <$> arbitrary + shrink x = CurrencySymbol <$> shrink (unCurrencySymbol x) + +instance Arbitrary TokenName where + arbitrary = TokenName <$> arbitrary + shrink x = TokenName <$> shrink (unTokenName x) + +instance Arbitrary AssetClass where + arbitrary = AssetClass <$> arbitrary + shrink x = AssetClass <$> shrink (unAssetClass x) + +instance CoArbitrary CurrencySymbol +instance CoArbitrary TokenName +instance CoArbitrary AssetClass + +instance Function CurrencySymbol +instance Function TokenName +instance Function AssetClass diff --git a/src/Tokenomia/Common/Arbitrary/Builtins.hs b/src/Tokenomia/Common/Arbitrary/Builtins.hs new file mode 100644 index 00000000..62b8bf3d --- /dev/null +++ b/src/Tokenomia/Common/Arbitrary/Builtins.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Tokenomia.Common.Arbitrary.Builtins + () where + +import PlutusTx.Builtins.Internal + ( BuiltinByteString(..) ) + +import Test.QuickCheck.Instances.ByteString () +import Test.Tasty.QuickCheck + ( Arbitrary + , CoArbitrary + , Function + , arbitrary + , resize + , shrink + ) + + +instance Arbitrary BuiltinByteString where + arbitrary = BuiltinByteString <$> resize 64 arbitrary + shrink x + | x == mempty = mempty + | otherwise = pure mempty + +instance CoArbitrary BuiltinByteString +instance Function BuiltinByteString diff --git a/src/Tokenomia/Common/Arbitrary/Modifiers.hs b/src/Tokenomia/Common/Arbitrary/Modifiers.hs new file mode 100644 index 00000000..c501668a --- /dev/null +++ b/src/Tokenomia/Common/Arbitrary/Modifiers.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Tokenomia.Common.Arbitrary.Modifiers + ( Restricted(..) + ) where + + +newtype Restricted a + = Restricted { getRestricted :: a } + deriving stock ( Show, Eq ) diff --git a/src/Tokenomia/Common/Arbitrary/POSIXTime.hs b/src/Tokenomia/Common/Arbitrary/POSIXTime.hs new file mode 100644 index 00000000..7e506d09 --- /dev/null +++ b/src/Tokenomia/Common/Arbitrary/POSIXTime.hs @@ -0,0 +1,31 @@ +module Tokenomia.Common.Arbitrary.POSIXTime + () where + +import Data.Default ( def ) +import Ledger ( POSIXTime(..) ) +import Ledger.TimeSlot ( SlotConfig(..) ) + +import Test.Tasty.QuickCheck + ( Arbitrary + , arbitrary + , genericShrink + , getPositive + , scale + , shrink + ) + + +-- +-- [Note: Generator scale] +-- +-- As POSIXTime will be mostly converted to slot, it is interesting to scale the +-- generator in order to have different slots. With the default integer scale, +-- all generated POSIXTime would be enclosed by the same slot. +-- + +instance Arbitrary POSIXTime where + arbitrary = + let slotLength = fromInteger $ scSlotLength def + in + POSIXTime . getPositive <$> scale (* slotLength) arbitrary + shrink = filter (>0) . genericShrink diff --git a/src/Tokenomia/Common/Arbitrary/Slot.hs b/src/Tokenomia/Common/Arbitrary/Slot.hs new file mode 100644 index 00000000..ae545257 --- /dev/null +++ b/src/Tokenomia/Common/Arbitrary/Slot.hs @@ -0,0 +1,18 @@ +module Tokenomia.Common.Arbitrary.Slot + () where + +import Ledger + ( Slot(..) ) + +import Test.Tasty.QuickCheck + ( Arbitrary + , arbitrary + , genericShrink + , getNonNegative + , shrink + ) + + +instance Arbitrary Slot where + arbitrary = Slot . getNonNegative <$> arbitrary + shrink = filter (>=0) . genericShrink diff --git a/src/Tokenomia/Common/Arbitrary/Wallet.hs b/src/Tokenomia/Common/Arbitrary/Wallet.hs new file mode 100644 index 00000000..361b0c87 --- /dev/null +++ b/src/Tokenomia/Common/Arbitrary/Wallet.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module Tokenomia.Common.Arbitrary.Wallet + ( Mnemonics(..) + , RootPrivateKey(..) + , StakePrivateKey(..) + , StakePublicKey(..) + , PaymentPrivateKey(..) + , PaymentPublicKey(..) + , PaymentAddress(..) + + , generateMnemonics + , getRootPrivateKey + , getStakePrivateKey + , getStakePublicKey + , getPaymentPrivateKey + , getPaymentPublicKey + , getPaymentAddress + , getPaymentAddressDelegated + + , generateKeysForAddressDerivation + , deriveAddress + , deriveAddresses + , generateAddresses + ) where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.Kind ( Type ) +import Data.ByteString.Lazy ( ByteString ) +import Data.ByteString.Lazy.Char8 qualified + as ByteString ( unwords ) + +import Shh.Internal + ( ExecReference(..) + , load + , captureTrim + , captureWords + , (|>) + ) + + +load SearchPath + [ "cardano-address-script" + ] + +missingExecutables :: IO [FilePath] + +newtype Mnemonics + = Mnemonics + { unMnemonics :: [ByteString] } + deriving stock (Show) + +newtype RootPrivateKey + = RootPrivateKey + { unRootPrivateKey :: ByteString } + deriving stock (Show) + +newtype StakePrivateKey + = StakePrivateKey + { unStakePrivateKey :: ByteString } + deriving stock (Show) + +newtype StakePublicKey + = StakePublicKey + { unStakePublicKey :: ByteString } + deriving stock (Show) + +newtype PaymentPrivateKey + = PaymentPrivateKey + { unPaymentPrivateKey :: ByteString } + deriving stock (Show) + +newtype PaymentPublicKey + = PaymentPublicKey + { unPaymentPublicKey :: ByteString } + deriving stock (Show) + +newtype PaymentAddress + = PaymentAddress + { unPaymentAddress :: ByteString } + deriving stock (Show) + +generateMnemonics :: + forall (m :: Type -> Type). + ( MonadIO m ) + => Integer -> m Mnemonics +generateMnemonics size = + Mnemonics <$> liftIO + ( cardano_address_script "recovery-phrase" "generate" "--size" size + |> captureWords + ) + +getRootPrivateKey :: + forall (m :: Type -> Type). + ( MonadIO m ) + => Mnemonics -> m RootPrivateKey +getRootPrivateKey (Mnemonics mnemonics) = + RootPrivateKey <$> liftIO + ( cardano_address_script "key" "from-recovery-phrase" "Shelley" "--" (ByteString.unwords mnemonics) + |> captureTrim + ) + +getStakePrivateKey :: + forall (m :: Type -> Type). + ( MonadIO m ) + => RootPrivateKey -> m StakePrivateKey +getStakePrivateKey (RootPrivateKey rootPrivateKey) = + StakePrivateKey <$> liftIO + ( cardano_address_script "key" "child" "1852H/1815H/0H/2/0" "--" rootPrivateKey + |> captureTrim + ) + +getStakePublicKey :: + forall (m :: Type -> Type). + ( MonadIO m ) + => StakePrivateKey-> m StakePublicKey +getStakePublicKey (StakePrivateKey stakePrivateKey) = + StakePublicKey <$> liftIO + ( cardano_address_script "key" "public" "--with-chain-code" "--" stakePrivateKey + |> captureTrim + ) + +getPaymentPrivateKey :: + forall (m :: Type -> Type). + ( MonadIO m ) + => RootPrivateKey -> Integer -> m PaymentPrivateKey +getPaymentPrivateKey (RootPrivateKey rootPrivateKey) index = + PaymentPrivateKey <$> liftIO + ( cardano_address_script "key" "child" ("1852H/1815H/0H/0/" <> show index) "--" rootPrivateKey + |> captureTrim + ) + +getPaymentPublicKey :: + forall (m :: Type -> Type). + ( MonadIO m ) + => PaymentPrivateKey -> m PaymentPublicKey +getPaymentPublicKey (PaymentPrivateKey paymentPrivateKey) = + PaymentPublicKey <$> liftIO + ( cardano_address_script "key" "public" "--with-chain-code" "--" paymentPrivateKey + |> captureTrim + ) + +getPaymentAddress :: + forall (m :: Type -> Type). + ( MonadIO m ) + => String -> PaymentPublicKey -> m PaymentAddress +getPaymentAddress network (PaymentPublicKey paymentPublicKey) = + PaymentAddress <$> liftIO + ( cardano_address_script "address" "payment" "--network-tag" network "--" paymentPublicKey + |> captureTrim + ) + +getPaymentAddressDelegated :: + forall (m :: Type -> Type). + ( MonadIO m ) + => StakePublicKey -> PaymentAddress -> m PaymentAddress +getPaymentAddressDelegated (StakePublicKey stakePublicKey) (PaymentAddress paymentAddress) = + PaymentAddress <$> liftIO + ( cardano_address_script "address" "delegation" stakePublicKey "--" paymentAddress + |> captureTrim + ) + +generateKeysForAddressDerivation :: + forall (m :: Type -> Type). + ( MonadIO m ) + => m (RootPrivateKey, StakePublicKey) +generateKeysForAddressDerivation = + do + rootPrivateKey <- generateMnemonics 24 >>= getRootPrivateKey + stakePublicKey <- getStakePrivateKey rootPrivateKey >>= getStakePublicKey + pure (rootPrivateKey, stakePublicKey) + +deriveAddress :: + forall (m :: Type -> Type). + ( MonadIO m ) + => String -> RootPrivateKey -> StakePublicKey -> Integer -> m PaymentAddress +deriveAddress network rootPrivateKey stakePublicKey index = + getPaymentPrivateKey rootPrivateKey index + >>= getPaymentPublicKey + >>= getPaymentAddress network + >>= getPaymentAddressDelegated stakePublicKey + +deriveAddresses :: + forall (m :: Type -> Type) (t :: Type -> Type). + ( MonadIO m + , Traversable t + ) + => String -> RootPrivateKey -> StakePublicKey -> t Integer -> m (t PaymentAddress) +deriveAddresses network rootPrivateKey stakePublicKey = + traverse $ deriveAddress network rootPrivateKey stakePublicKey + +generateAddresses :: + forall (m :: Type -> Type) (t :: Type -> Type). + ( MonadIO m + , Traversable t + ) + => String -> t Integer -> m (t PaymentAddress) +generateAddresses network xs = + generateKeysForAddressDerivation + >>= \keys -> uncurry (deriveAddresses network) keys xs diff --git a/src/Tokenomia/Common/Data/List/Extra.hs b/src/Tokenomia/Common/Data/List/Extra.hs new file mode 100644 index 00000000..77449d44 --- /dev/null +++ b/src/Tokenomia/Common/Data/List/Extra.hs @@ -0,0 +1,28 @@ +module Tokenomia.Common.Data.List.Extra + ( mapLastWith + , para + , transpose + ) where + +import Control.Applicative ( ZipList(..) ) + + +-- | map different functions on elements of a list depending on their position. +mapLastWith :: (a -> a) -> (a -> a) -> [a] -> [a] +mapLastWith f f' = para g [] + where + g x [] _ = [f' x] + g x _ r = f x : r + +-- | list paramorphism, see foldr +para :: (a -> [a] -> b -> b) -> b -> [a] -> b +para f z = go + where + go [] = z + go (x:xs) = f x xs (go xs) + +-- | transpose generalized to traversable +transpose :: (Traversable t) => t [a] -> [t a] +transpose xs + | null xs = [] + | otherwise = getZipList $ traverse ZipList xs diff --git a/src/Tokenomia/Common/Parser/Address.hs b/src/Tokenomia/Common/Parser/Address.hs new file mode 100644 index 00000000..fe7cef04 --- /dev/null +++ b/src/Tokenomia/Common/Parser/Address.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE KindSignatures #-} + +module Tokenomia.Common.Parser.Address + ( deserialiseCardanoAddress + , serialiseCardanoAddress + , unsafeSerialiseCardanoAddress + ) where + +import Ledger.Address ( Address(..) ) +import Ledger.Credential ( Credential(..) ) +import Ledger.Crypto ( PubKeyHash(PubKeyHash) ) + +import Data.ByteArray ( length ) +import Data.Text ( Text, isPrefixOf ) +import Data.Kind ( Type ) +import Data.Either.Combinators ( mapLeft, maybeToRight ) + +import PlutusCore.Pretty ( Pretty(pretty) ) + +import PlutusTx.Prelude ( fromBuiltin ) + +import Prelude hiding ( length ) + +import Plutus.Contract.CardanoAPI + ( ToCardanoError + , fromCardanoAddress + , toCardanoAddress + ) + +import Cardano.Chain.Common ( decodeAddressBase58 ) + +import Cardano.Api.Byron qualified as Bryon + ( Address(ByronAddress) ) + +import Cardano.Api + ( AsType(AsAddressInEra, AsAlonzoEra, AsByronEra) + , IsCardanoEra + , NetworkId + , AddressInEra(AddressInEra) + , AddressTypeInEra(ByronAddressInAnyEra) + , AlonzoEra + , deserialiseAddress + , serialiseAddress + ) + +import Tokenomia.Common.Data.Convertible ( convert ) + + +deserialiseAddressInEra + :: forall (era :: Type). IsCardanoEra era + => AsType era -> Text -> Either Text Address +deserialiseAddressInEra era address = do + cardanoAddress <- maybeToRight "deserialisation failed" $ + deserialiseAddress (AsAddressInEra era) address + mapLeft (const "not a cardano address") $ + fromCardanoAddress cardanoAddress + +deserialiseCardanoAddress :: Text -> Either Text Address +deserialiseCardanoAddress address + | "addr" `isPrefixOf` address = deserialiseAddressInEra AsAlonzoEra address + | otherwise = deserialiseAddressInEra AsByronEra address + +serialiseAlonzoAddress :: NetworkId -> Address -> Either Text (AddressInEra AlonzoEra) +serialiseAlonzoAddress networdId address = + mapLeft showError $ + toCardanoAddress networdId address + where + showError :: ToCardanoError -> Text + showError err = + (convert . show . pretty $ err) + <> (convert . show $ address) + +serialiseByronAddress :: Address -> Either Text (AddressInEra AlonzoEra) +serialiseByronAddress (Address (PubKeyCredential (PubKeyHash bytes)) _) = do + base58 <- + mapLeft (convert . show) $ + decodeAddressBase58 $ convert $ fromBuiltin bytes + pure $ AddressInEra ByronAddressInAnyEra (Bryon.ByronAddress base58) +serialiseByronAddress _ = Left "Invalid Byron address" + +serialiseCardanoAddress :: NetworkId -> Address -> Either Text Text +serialiseCardanoAddress _ address@(Address (PubKeyCredential (PubKeyHash bytes)) _) + | length bytes > 28 = + serialiseAddress <$> serialiseByronAddress address +serialiseCardanoAddress networkId address = + serialiseAddress <$> serialiseAlonzoAddress networkId address + +unsafeSerialiseCardanoAddress :: NetworkId -> Address -> Text +unsafeSerialiseCardanoAddress networkId address = + either (error . convert) id $ + serialiseCardanoAddress networkId address diff --git a/src/Tokenomia/Common/Time.hs b/src/Tokenomia/Common/Time.hs new file mode 100644 index 00000000..1560f152 --- /dev/null +++ b/src/Tokenomia/Common/Time.hs @@ -0,0 +1,33 @@ +module Tokenomia.Common.Time + ( posixTimeToEnclosingSlotNo + , slotAfterNextBeginPOSIXTime + , toCardanoSlotNo + , toNextBeginPOSIXTime + ) where + +import Cardano.Api ( SlotNo(..) ) +import Data.Default ( def ) +import Ledger ( POSIXTime, Slot (..) ) +import Ledger.TimeSlot ( posixTimeToEnclosingSlot, slotToBeginPOSIXTime ) + + +-- | Convert from Plutus to Cardano slot representation +toCardanoSlotNo :: Slot -> SlotNo +toCardanoSlotNo = SlotNo . fromInteger . getSlot + +-- | POSIXTime to enclosing SlotNo +posixTimeToEnclosingSlotNo :: POSIXTime -> SlotNo +posixTimeToEnclosingSlotNo = toCardanoSlotNo . posixTimeToEnclosingSlot def + +-- | Smaller slot whose starting POSIXTime is greater or equal to the given time +slotAfterNextBeginPOSIXTime :: POSIXTime -> Slot +slotAfterNextBeginPOSIXTime time = + let n = posixTimeToEnclosingSlot def time + in + if time == slotToBeginPOSIXTime def n + then n + else n + 1 + +-- | Smaller POSIXTime starting a slot that is greater or equal to the given time +toNextBeginPOSIXTime :: POSIXTime -> POSIXTime +toNextBeginPOSIXTime = slotToBeginPOSIXTime def . slotAfterNextBeginPOSIXTime diff --git a/src/Tokenomia/TokenDistribution/Distribution.hs b/src/Tokenomia/TokenDistribution/Distribution.hs index a00de5e3..fd91aea6 100644 --- a/src/Tokenomia/TokenDistribution/Distribution.hs +++ b/src/Tokenomia/TokenDistribution/Distribution.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} module Tokenomia.TokenDistribution.Distribution ( Distribution(..) @@ -43,13 +44,15 @@ data Recipient = Recipient { address :: Address , amount :: Integer - } deriving (Show) + } + deriving stock ( Show ) data Distribution = Distribution { assetClass :: AssetClass , recipients :: [Recipient] - } deriving (Show) + } + deriving stock ( Show ) -- Unfortunately, address serialisation requires a network Id. As such, one cannot correctly ToJSON a Distribution. -- Instead, we use a proxy type that allows us to provide this information diff --git a/src/Tokenomia/Vesting/GenerateNative.hs b/src/Tokenomia/Vesting/GenerateNative.hs index 154c0c7b..d69fead1 100644 --- a/src/Tokenomia/Vesting/GenerateNative.hs +++ b/src/Tokenomia/Vesting/GenerateNative.hs @@ -1,316 +1,499 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Tokenomia.Vesting.GenerateNative (generatePrivateSaleFiles, nativeScriptToLedgerAddr, NativeScript (NativeScript)) where - -import Cardano.Api ( - Hash, - PaymentCredential (PaymentCredentialByScript), - PaymentKey, - Script (SimpleScript), - SimpleScript ( - RequireAllOf, - RequireSignature, - RequireTimeAfter - ), - SimpleScriptVersion (SimpleScriptV2), - SlotNo, - StakeAddressReference (NoStakeAddress), - TimeLocksSupported (TimeLocksInSimpleScriptV2), - hashScript, - makeShelleyAddress, - serialiseToBech32, +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Tokenomia.Vesting.GenerateNative + ( Allocation + , DatabaseOutput(..) + , InvestorAddress(..) + , NativeScript(..) + , NativeScriptInfo (..) + , PrivateSale(..) + , PrivateSaleTranche(..) + , TrancheProperties(..) + , TranchesProportions(..) + , generatePrivateSaleFiles + , getNetworkId + , investorAddressPubKeyHash + , merge + , minAllocation + , nativeScriptAddress + , parsePrivateSale + , readPrivateSale + , scaleRatios + , splitAllocation + , splitInTranches + , toDatabaseOutput + , toDistribution + , trancheNativeScriptInfos + , validateAllocations + , validatePrivateSale + , validateTranchesProportions + ) where + +import Control.Error.Safe ( assertErr ) +import Control.Monad ( join ) +import Control.Monad.Except ( MonadError, liftEither ) +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import Control.Monad.Reader ( MonadReader, asks ) +import Data.Bifunctor ( first ) +import Data.Either.Combinators ( maybeToRight ) +import Data.Foldable ( traverse_ ) +import Data.Functor.Syntax ( (<$$>) ) +import Data.Kind ( Type ) +import Data.String ( fromString ) +import Data.Text ( Text ) +import Data.Ratio ( Ratio, (%), numerator, denominator ) + +import Data.List.NonEmpty ( NonEmpty((:|)), (<|) ) +import Data.List.NonEmpty qualified + as NEList ( fromList, head, toList, zip ) + +import Data.Map.NonEmpty ( NEMap, traverseWithKey ) +import Data.Map.NonEmpty qualified + as NEMap ( elems, fromAscList, keys ) + +import GHC.Generics ( Generic ) +import GHC.Natural ( Natural, naturalFromInteger, naturalToInteger ) + +import Ledger ( POSIXTime, PubKeyHash, toPubKeyHash ) +import Ledger.Address ( Address ) +import Ledger.Value ( AssetClass(..) ) +import System.FilePath ( replaceFileName ) + +import Data.Aeson + ( FromJSON(..) + , ToJSON(..) + , FromJSONKey + , ToJSONKey + , (.=) + , eitherDecodeFileStrict + , encodeFile + , object + ) + +import Cardano.Api + ( PaymentCredential(PaymentCredentialByScript) + , Script(SimpleScript) + , SimpleScript + ( RequireAllOf + , RequireSignature + , RequireTimeAfter + ) + , SimpleScriptVersion(SimpleScriptV2) + , SimpleScriptV2 + , StakeAddressReference(NoStakeAddress) + , TimeLocksSupported(TimeLocksInSimpleScriptV2) + , hashScript + , makeShelleyAddress + , serialiseToBech32 + , NetworkMagic(..) ) -import qualified Blockfrost.Client as Blockfrost -import qualified Cardano.Api as Api -import Control.Applicative (ZipList (ZipList, getZipList)) -import Control.Monad.Except (MonadError, liftEither) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Reader (MonadReader, asks) -import Data.Aeson (eitherDecodeFileStrict, encodeFile) -import Data.Aeson.TH (defaultOptions, deriveJSON) -import Data.Bifunctor (Bifunctor (bimap), first) -import Data.Either.Combinators (maybeToRight) -import Data.Foldable (traverse_) -import Data.Foldable.Extra (sumOn') -import Data.Kind (Type) -import Data.List.NonEmpty (NonEmpty, nonEmpty, (<|)) -import qualified Data.List.NonEmpty as List.NonEmpty -import Data.Map.NonEmpty (NEMap) -import qualified Data.Map.NonEmpty as Map.NonEmpty -import Data.String (IsString (fromString)) -import Data.Text (Text) -import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) -import Data.Tuple.Extra (firstM, second) -import Ledger (Slot (Slot, getSlot), toPubKeyHash) -import Ledger.Address (Address) -import Ledger.Value (AssetClass (unAssetClass)) -import Numeric.Natural -import Plutus.V1.Ledger.Value (toString) -import System.FilePath (replaceFileName) -import Tokenomia.Vesting.Sendings (checkMalformedAddr) -import Tokenomia.Common.Environment (Environment (Mainnet, Testnet, magicNumber), toSlot) -import Tokenomia.Common.Error (TokenomiaError (InvalidPrivateSale, MalformedAddress)) -import Tokenomia.TokenDistribution.Distribution (Distribution (Distribution), Recipient (Recipient), WithNetworkId (WithNetworkId)) -import Tokenomia.TokenDistribution.Parser.Address (deserialiseCardanoAddress) - -type Amount = Natural - -data Tranche = Tranche - { percentage :: Natural -- out of 10,000 - , duration :: Integer -- number of slots - } - deriving stock (Show) - -$(deriveJSON defaultOptions ''Tranche) - --- Invariants --- Σ percentages = 100% --- Description : Represent Vesting Tranches (Time Sequential and contiguous) - -newtype Tranches = Tranches (NonEmpty Tranche) - deriving stock (Show) - --- Separate to keep the derived json instance clean -unTranches :: Tranches -> NonEmpty Tranche -unTranches (Tranches x) = x - -$(deriveJSON defaultOptions ''Tranches) - -data PrivateInvestor = PrivateInvestor - { address :: Blockfrost.Address - , allocation :: Amount - } - deriving stock (Show) - -$(deriveJSON defaultOptions ''PrivateInvestor) - -data PrivateSale = PrivateSale - { start :: POSIXTime -- External POSIXTime, given in seconds - , tranches :: Tranches - , assetClass :: AssetClass - , investors :: NonEmpty PrivateInvestor - } - deriving stock (Show) - -$(deriveJSON defaultOptions ''PrivateSale) - -data NativeScript = NativeScript - { pkh :: String - , unlockTime :: Integer - } - deriving stock (Show, Eq) - -$(deriveJSON defaultOptions ''NativeScript) - --- | Simplified AssetClass that serialises to JSON without newtypes over currency symbol and token name -data AssetClassSimple = AssetClassSimple - { currencySymbol :: String -- As hex - , tokenName :: String -- As hex - } - deriving stock (Show) - -$(deriveJSON defaultOptions ''AssetClassSimple) - -data LockedFund = LockedFund - { nativeScript :: NativeScript - , asset :: AssetClassSimple - } - deriving stock (Show) - -$(deriveJSON defaultOptions ''LockedFund) - --- Map AddressAsText [LockedFund] -type DatabaseOutput = NEMap Text (NonEmpty LockedFund) - -deriving newtype instance Ord Blockfrost.Address -getNetworkId :: forall (m :: Type -> Type). MonadReader Environment m => m Api.NetworkId -getNetworkId = asks readNetworkId +import qualified Cardano.Api as Api ( NetworkId(..) ) + +import Tokenomia.Common.Aeson.AssetClass ( assetClassToJSON ) +import Tokenomia.Common.Data.List.Extra ( mapLastWith, transpose ) +import Tokenomia.Common.Environment ( Environment(..) ) +import Tokenomia.Common.Error ( TokenomiaError(InvalidPrivateSale, MalformedAddress) ) +import Tokenomia.Common.Time ( posixTimeToEnclosingSlotNo , toNextBeginPOSIXTime ) + +import Tokenomia.TokenDistribution.Parser.Address + ( deserialiseCardanoAddress ) + +import Tokenomia.TokenDistribution.Distribution + ( Distribution(..) + , Recipient(..) + , WithNetworkId(..) + ) + + +-------------------------------------------------------------------------------- +-- +-- [Note: Caveat] +-- +-- Allocation ratios do not match exactly tranche proportions. +-- Rounding occurs in order to have intregral allocations. +-- See [Note: Rounding Allocation] +-- +-- NativeScript requireTimeAfter may not correspond exactly to tranche +-- unlockTime. On-chain time calculations are expressed in slots and a slot +-- correspond to an interval of POSIXTime. +-- See [Note: Slot Calculation] +-- +-------------------------------------------------------------------------------- +-- +-- [Note: Rounding Allocation] +-- +-- Let `[r_1, r_2, ..., r_k]` be the ratios for all `k` tranches. +-- Let `n` be the total allocation. +-- Let `ε` be the minimum amount on a script. +-- +-- The allocation `n` will be splitted on `k` scripts with an integer partition. +-- When `Σ r_i = 1`, +-- +-- n = ⌊n r_1⌋ + ⌊n r_2⌋ + ... + (⌊n r_k⌋ + δ) (1) +-- +-- where δ corresponds to rounding errors. +-- +-- Each terms represent the amount sent on a different script. +-- Thus, +-- +-- ∀ i, ⌊n r_i⌋ >= ε (2) +-- +-- To have (1) and (2), it is sufficient to have the following preconditions +-- ∀ i, n r_i >= ε + 1 +-- n >= k ε +-- +-- So, +-- n >= ⌈ max [(ε + 1) / r_i, ..., (ε + 1) / r_k, k ε] ⌉ +-- +-------------------------------------------------------------------------------- +-- +-- [Note: Slot Calculation] +-- +-- Consider the following situation. +-- +-- n-1 n n+1 > slot number +-- | | | | +-- ---|-------|a-b----|-------|---> time in miliseconds since epoch +-- ^ +-- unlockTime (ms) +-- +-- Let `t` be the specified unlockTime. +-- Let `n` be the enclosing slot number of `t`. +-- +-- The `RequireTimeAfter` parameter of a native script is expressed in slot. +-- Thus, it is necessary to choose a slot number from an unlockTime. +-- +-- When `t` is not a starting POSIXTime of a slot, +-- +-- a) With RequireTimeAfter (SlotNo n), +-- the transaction could succeed at `t - 1 ∈ (SlotNo n)`, +-- even if t - 1 < unlockTime. +-- b) With RequireTimeAfter (SlotNo n+1), +-- the transaction could fail at `t + 1 ∈ (SlotNo n)`, +-- even if t + 1 > unlockTime. +-- +-- The less misleading alternative is b) for two reasons. +-- It is best to use a stricter condition than a more tolerant one. +-- It is best to succeed later than having no retry to gain understanding. +-- +-------------------------------------------------------------------------------- + +type Allocation = Natural + +newtype InvestorAddress + = InvestorAddress + { unInvestorAddress :: Text } + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (ToJSON, FromJSON, ToJSONKey, FromJSONKey) + +newtype TranchesProportions + = TranchesProportions + { unTranchesProportions :: NonEmpty (Ratio Natural) } + deriving stock (Show) + +data TrancheProperties + = TrancheProperties + { proportion :: Ratio Natural + , unlockTime :: POSIXTime + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +data PrivateSale + = PrivateSale + { tranchesProperties :: NonEmpty TrancheProperties + , assetClass :: AssetClass + , allocationByAddress :: NEMap InvestorAddress Allocation + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +data PrivateSaleTranche + = PrivateSaleTranche + { trancheUnlockTime :: POSIXTime + , trancheAssetClass :: AssetClass + , trancheAllocationByAddress :: NEMap InvestorAddress Allocation + } + deriving stock (Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +data NativeScript + = NativeScript + { requireSignature :: PubKeyHash + , requireTimeAfter :: POSIXTime + } + deriving stock (Show) + +data NativeScriptInfo + = NativeScriptInfo + { requiring :: NativeScript + , recipient :: Recipient + } + deriving stock (Show) + +instance ToJSON NativeScript where + toJSON NativeScript{..} = + object + [ "requireSignature" .= toJSON (show requireSignature) + , "requireTimeAfter" .= toJSON requireTimeAfter + ] + +instance ToJSON (WithNetworkId NativeScriptInfo) where + toJSON (NativeScriptInfo{..} `WithNetworkId` networkId) = + object + [ "nativeScriptInfo" .= object + [ "requiring" .= toJSON requiring + , "recipient" .= toJSON (recipient `WithNetworkId` networkId) + ] + ] + +data DatabaseOutput + = DatabaseOutput + { lockedAssetClass :: AssetClass + , lockedFunds :: NEMap InvestorAddress (NonEmpty NativeScriptInfo) + } + deriving stock (Show) + +instance ToJSON (WithNetworkId DatabaseOutput) where + toJSON (DatabaseOutput{..} `WithNetworkId` networkId) = + object + [ "lockedAssetClass" .= assetClassToJSON lockedAssetClass + , "lockedFunds" .= toJSON ((`WithNetworkId` networkId) <$$> lockedFunds) + ] + +-------------------------------------------------------------------------------- + +-- | Preconditions on the input data +validatePrivateSale :: + forall (m :: Type -> Type). + ( MonadError TokenomiaError m ) + => PrivateSale -> m () +validatePrivateSale PrivateSale{..} = + let proportions = TranchesProportions $ proportion <$> tranchesProperties + ε = 10 + in + liftEither $ do + validateTranchesProportions proportions + validateAllocations ε proportions $ NEMap.elems allocationByAddress + traverse_ (unsafeDeserialiseCardanoAddress . unInvestorAddress) $ NEMap.keys allocationByAddress + +-- | Preconditions on tranches proportions +validateTranchesProportions :: TranchesProportions -> Either TokenomiaError () +validateTranchesProportions (TranchesProportions proportions) = do + assertErr + (InvalidPrivateSale "All tranche proportion must be strictly positive.") + (all (> 0) proportions) + assertErr + (InvalidPrivateSale "Tranche proportions must sum to 1.") + (sum proportions == 1) + +-- | Preconditions on total allocations +validateAllocations :: Natural -> TranchesProportions -> NonEmpty Allocation -> Either TokenomiaError () +validateAllocations ε proportions allocations = + assertErr + (InvalidPrivateSale "Some allocations are too small.") + (all (>= minAllocation ε proportions) allocations) + +-- | Minimum allowed allocation to divide in tranche +minAllocation :: Natural -> TranchesProportions -> Allocation +minAllocation ε (TranchesProportions xs) = + let k = naturalFromInteger . toInteger $ length xs + in + ceiling $ maximum $ (k*ε % 1) <| (divByRatio (ε + 1) <$> xs) where - readNetworkId :: Environment -> Api.NetworkId - readNetworkId Mainnet {} = Api.Mainnet - readNetworkId Testnet {magicNumber} = Api.Testnet . Api.NetworkMagic $ fromInteger magicNumber + inv :: Integral a => Ratio a -> Ratio a + inv x = denominator x % numerator x + + divByRatio :: Integral a => a -> Ratio a -> Ratio a + divByRatio a x = (a % 1) * inv x +-------------------------------------------------------------------------------- + +getNetworkId :: forall (m :: Type -> Type). MonadReader Environment m => m Api.NetworkId +getNetworkId = asks readNetworkId + where + readNetworkId :: Environment -> Api.NetworkId + readNetworkId Mainnet {} = Api.Mainnet + readNetworkId Testnet {magicNumber} = Api.Testnet . NetworkMagic $ fromInteger magicNumber + +unsafeDeserialiseCardanoAddress :: + forall (m :: Type -> Type). + ( MonadError TokenomiaError m ) + => Text -> m Address +unsafeDeserialiseCardanoAddress = + liftEither . first (const MalformedAddress) . deserialiseCardanoAddress + +-- | Parse PrivateSale from a JSON file +readPrivateSale :: + forall (m :: Type -> Type). + ( MonadIO m + , MonadError TokenomiaError m + ) + => FilePath -> m PrivateSale +readPrivateSale path = + (liftIO . (eitherDecodeFileStrict @PrivateSale) $ path) + >>= liftEither . first InvalidPrivateSale + +-- | Parse PrivateSale from a JSON file and validate the data parsePrivateSale :: - forall (m :: Type -> Type). - ( MonadIO m - , MonadError TokenomiaError m - ) => - String -> - m PrivateSale + forall (m :: Type -> Type). + ( MonadIO m + , MonadError TokenomiaError m + ) + => FilePath -> m PrivateSale parsePrivateSale path = do - eitherErrPriv <- liftIO . (eitherDecodeFileStrict @PrivateSale) $ path - liftEither $ do - prvSale <- first InvalidPrivateSale eitherErrPriv - - validateTranches $ tranches prvSale - traverse_ (checkMalformedAddr . address) $ investors prvSale - pure prvSale + privateSale <- readPrivateSale path + privateSale <$ validatePrivateSale privateSale generatePrivateSaleFiles :: - forall (m :: Type -> Type). - ( MonadIO m - , MonadError TokenomiaError m - , MonadReader Environment m - ) => - m () + forall (m :: Type -> Type). + ( MonadIO m + , MonadError TokenomiaError m + , MonadReader Environment m + ) + => m () generatePrivateSaleFiles = do - liftIO . putStrLn $ "Please enter a filepath with JSON data" - path <- liftIO getLine - - prvSale <- parsePrivateSale path - nativeData <- splitInTranches prvSale - networkId <- getNetworkId - - let dbOutput = toDbOutput prvSale nativeData - distribution <- toDistribution prvSale nativeData - - liftIO $ do - encodeFile (replaceFileName path "database.json") dbOutput - encodeFile (replaceFileName path "distribution.json") $ distribution `WithNetworkId` networkId - putStrLn "Files database.json and distribution.json generated." - -toDistribution :: - forall (m :: Type -> Type). - ( MonadError TokenomiaError m - , MonadReader Environment m - ) => - PrivateSale -> - NEMap Blockfrost.Address (NonEmpty (NativeScript, Amount)) -> - m Distribution -toDistribution prvSale nativeData = Distribution (assetClass prvSale) <$> recipients - where - elemsList = - ZipList . List.NonEmpty.toList <$> Map.NonEmpty.elems nativeData - - mergedNativeScriptAmts :: [(NativeScript, Integer)] - mergedNativeScriptAmts = - fmap (second toInteger) - . getZipList - . foldr (\nsAmt acc -> combineNs <$> nsAmt <*> acc) (List.NonEmpty.head elemsList) - $ List.NonEmpty.tail elemsList - - combineNs (ns, a1) (_, a2) = (ns, a1 + a2) - - recipients :: m [Recipient] - recipients = traverse (fmap (uncurry Recipient) . firstM nativeScriptToLedgerAddr) mergedNativeScriptAmts - -nativeScriptToLedgerAddr :: - forall (m :: Type -> Type). - ( MonadError TokenomiaError m - , MonadReader Environment m - ) => - NativeScript -> - m Address -nativeScriptToLedgerAddr ns = do - networkId <- getNetworkId - textToLedgerAddress . serialiseToBech32 $ shelleyAddr networkId - where - shelleyAddr nid = makeShelleyAddress nid (PaymentCredentialByScript hashedScript) NoStakeAddress - hashedScript = hashScript $ SimpleScript SimpleScriptV2 cardanNs - cardanNs = - RequireAllOf - [ RequireSignature pkHash - , RequireTimeAfter TimeLocksInSimpleScriptV2 unlockAfterSlot - ] - - pkHash :: Hash PaymentKey - pkHash = fromString (pkh ns) - - unlockAfterSlot :: SlotNo - unlockAfterSlot = fromInteger (unlockTime ns) - -textToLedgerAddress :: - forall (m :: Type -> Type). - MonadError TokenomiaError m => - Text -> - m Address -textToLedgerAddress = - liftEither . first (const MalformedAddress) . deserialiseCardanoAddress - -toDbOutput :: - PrivateSale -> - NEMap Blockfrost.Address (NonEmpty (NativeScript, Amount)) -> - DatabaseOutput -toDbOutput ps invDistMap = - Map.NonEmpty.mapKeys addrToText - $ fmap ((`LockedFund` acSimple) . fst) <$> invDistMap - where - acSimple = uncurry AssetClassSimple . bimap show toString . unAssetClass $ assetClass ps - addrToText :: Blockfrost.Address -> Text - addrToText (Blockfrost.Address addr) = addr - -assertErr :: String -> Bool -> Either TokenomiaError () -assertErr _ True = Right () -assertErr err _ = Left $ InvalidPrivateSale err - -validateTranches :: Tranches -> Either TokenomiaError () -validateTranches tranches = do - assertErr - ("The sum of all the tranches must be 10000, but we got: " <> show tranchesSum) - $ tranchesSum == 10000 - where - tranchesSum = sumOn' percentage $ unTranches tranches - -mergeInvestors :: NonEmpty PrivateInvestor -> NEMap Blockfrost.Address Amount -mergeInvestors = Map.NonEmpty.fromListWith (+) . (toTuple <$>) + path <- liftIO $ do + putStrLn "Please enter a filepath with JSON data" + getLine + + networkId <- getNetworkId + privateSaleTranches <- splitInTranches <$> parsePrivateSale path + databaseOutput <- toDatabaseOutput privateSaleTranches + let distribution = toDistribution databaseOutput + + liftIO $ do + encodeFile (replaceFileName path "database.json") (databaseOutput `WithNetworkId` networkId) + encodeFile (replaceFileName path "distribution.json") (distribution `WithNetworkId` networkId) + putStrLn "Files database.json and distribution.json generated." + +-- | Try to convert an Address to its PubKeyHash +investorAddressPubKeyHash :: + forall (m :: Type -> Type). + ( MonadError TokenomiaError m ) + => InvestorAddress -> m PubKeyHash +investorAddressPubKeyHash (InvestorAddress text) = do + unsafeDeserialiseCardanoAddress text >>= + liftEither + . maybeToRight (InvalidPrivateSale "Not a PubKeyHash address") + . toPubKeyHash + +-- | Make a Cardano SimpleScript from a NativeScript and deserialise its address +nativeScriptAddress :: + forall (m :: Type -> Type). + ( MonadError TokenomiaError m + , MonadReader Environment m + ) + => NativeScript -> m Address +nativeScriptAddress = + simpleScriptAddress . toCardanoSimpleScript where - toTuple :: PrivateInvestor -> (Blockfrost.Address, Amount) - toTuple (PrivateInvestor x y) = (x, y) - -{- | We are taking the floor of the corresponding percentage in all items - except in the last one where we do the corrections to sum the right amount. --} -splitAmountInTranches :: - Slot -> - Amount -> - Tranches -> - Amount -> - NonEmpty (Slot, Amount) -splitAmountInTranches startSlot total trs acc = - case nonEmpty . List.NonEmpty.tail $ unTranches trs of - Nothing -> pure (nextSlot, total - acc) - Just remainTranches -> - let takenAmount :: Amount - takenAmount = div (total * percentage tranche) 10000 - in (nextSlot, takenAmount) <| splitAmountInTranches nextSlot total (Tranches remainTranches) (acc + takenAmount) + toCardanoSimpleScript :: NativeScript -> SimpleScript SimpleScriptV2 + toCardanoSimpleScript NativeScript{..} = + RequireAllOf + [ RequireSignature (fromString . show $ requireSignature) + , RequireTimeAfter TimeLocksInSimpleScriptV2 (posixTimeToEnclosingSlotNo requireTimeAfter) + ] + + simpleScriptAddress :: SimpleScript SimpleScriptV2 -> m Address + simpleScriptAddress script = do + networkId <- getNetworkId + unsafeDeserialiseCardanoAddress . serialiseToBech32 $ + makeShelleyAddress + networkId + (PaymentCredentialByScript . hashScript $ SimpleScript SimpleScriptV2 script) + NoStakeAddress + +-- | Construct NativeScriptInfos of a tranche for all addresses +trancheNativeScriptInfos :: + forall (m :: Type -> Type). + ( MonadError TokenomiaError m + , MonadReader Environment m + ) + => PrivateSaleTranche -> m (NEMap InvestorAddress NativeScriptInfo) +trancheNativeScriptInfos PrivateSaleTranche{..} = + traverseWithKey nativeScriptInfo trancheAllocationByAddress where - tranche :: Tranche - tranche = List.NonEmpty.head $ unTranches trs - nextSlot :: Slot - nextSlot = Slot (duration tranche) + startSlot - -splitInTranches :: - forall (m :: Type -> Type). - ( MonadIO m - , MonadError TokenomiaError m - , MonadReader Environment m - ) => - PrivateSale -> - m (NEMap Blockfrost.Address (NonEmpty (NativeScript, Amount))) -splitInTranches PrivateSale {..} = do - startSlot <- toSlot $ posixSecondsToUTCTime start - let f :: Blockfrost.Address -> Amount -> m (NonEmpty (NativeScript, Amount)) - f addr x = traverse (toNative addr) $ splitAmountInTranches startSlot x tranches 0 - - toNative :: Blockfrost.Address -> (Slot, Amount) -> m (NativeScript, Amount) - toNative (Blockfrost.Address addr) (slot, amt) = do - ledgerAddress <- textToLedgerAddress addr - pkh <- liftEither $ maybeToRight (InvalidPrivateSale "Address is not PubKeyHash address") $ toPubKeyHash ledgerAddress - pure $ (NativeScript (show pkh) $ getSlot slot, amt) - - investorsMap :: NEMap Blockfrost.Address Amount - investorsMap = mergeInvestors investors - - Map.NonEmpty.traverseWithKey f investorsMap + nativeScriptInfo :: InvestorAddress -> Allocation -> m NativeScriptInfo + nativeScriptInfo investorAddress allocation = do + requiring <- nativeScript investorAddress + recipient <- (`Recipient` naturalToInteger allocation) + <$> nativeScriptAddress requiring + pure NativeScriptInfo{..} + + nativeScript :: InvestorAddress -> m NativeScript + nativeScript investorAddress = do + pubKeyHash <- investorAddressPubKeyHash investorAddress + pure $ NativeScript pubKeyHash (toNextBeginPOSIXTime trancheUnlockTime) + +-- | Merge a list of maps into a single map to list using the keys of the first map +merge :: (Ord k) => NonEmpty (NEMap k v) -> NEMap k (NonEmpty v) +merge xxs@(x :| _) = + NEMap.fromAscList $ + NEList.zip + (NEMap.keys x) + (NEList.fromList $ transpose (NEList.toList . NEMap.elems <$> xxs)) + +-- | Reshape all tranches NativeScriptInfos into a DatabaseOutput +toDatabaseOutput :: + forall (m :: Type -> Type). + ( MonadError TokenomiaError m + , MonadReader Environment m + ) + => NonEmpty PrivateSaleTranche -> m DatabaseOutput +toDatabaseOutput tranches = + do + allTrancheNativeScriptInfos <- traverse trancheNativeScriptInfos tranches + let lockedAssetClass = trancheAssetClass $ NEList.head tranches + lockedFunds = merge allTrancheNativeScriptInfos + pure DatabaseOutput{..} + +-- | Flatten all recipients of a DatabaseOutput for Distribution +toDistribution :: DatabaseOutput -> Distribution +toDistribution DatabaseOutput{..} = + let recipients = NEList.toList $ join (recipient <$$> NEMap.elems lockedFunds) + assetClass = lockedAssetClass + in + Distribution{..} + +-------------------------------------------------------------------------------- + +-- | Duplicate the PrivateSale data into tranches with allocations partitionned +splitInTranches :: PrivateSale -> NonEmpty PrivateSaleTranche +splitInTranches PrivateSale {..} = + let properties = NEList.toList tranchesProperties + tranchesUnlockTimes = unlockTime <$> properties + tranchesProportions = proportion <$> properties + tranchesAllocationByAddress = + transpose $ + scaleRatios tranchesProportions <$> allocationByAddress + in + NEList.fromList $ zipWith + (`PrivateSaleTranche` assetClass) + tranchesUnlockTimes + tranchesAllocationByAddress + +-- | Partition an integer into `k` parts, each part corresponding to a given ratio +scaleRatios :: (Integral a) => [Ratio a] -> a -> [a] +scaleRatios ratios scale = + let xs = floor . ((scale % 1) *) <$> ratios + rounding = floor ((scale % 1) * sum ratios) - sum xs + in + mapLastWith id (+ rounding) xs + +-- | Split an allocation given a well-defined list of tranches proportions +splitAllocation :: TranchesProportions -> Allocation -> [Allocation] +splitAllocation (TranchesProportions rs) = scaleRatios $ NEList.toList rs diff --git a/test/Spec.hs b/test/Spec.hs index fdee6fb7..9dd747b0 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,8 +2,12 @@ module Main(main) where +import qualified Spec.Tokenomia.Vesting.GenerateNative +import qualified Spec.Tokenomia.Common.Data.List.Extra +import qualified Spec.Tokenomia.Common.Time import qualified Spec.Tokenomia.Wallet.UTxO import qualified Spec.Tokenomia.Common.Value +import qualified Spec.Tokenomia.Common.Parser.Address import qualified Spec.Tokenomia.ICO.Funds.Exchange.Plan import qualified Spec.Tokenomia.ICO.Funds.Validation.Investor.Plan import qualified Spec.Tokenomia.ICO.Funds.Validation.CardanoCLI.Plan @@ -14,11 +18,15 @@ main :: IO () main = defaultMain tests tests :: TestTree -tests = testGroup "use cases" [ - Spec.Tokenomia.Wallet.UTxO.tests , - Spec.Tokenomia.Common.Value.tests, - Spec.Tokenomia.ICO.Funds.Exchange.Plan.tests, - Spec.Tokenomia.ICO.Funds.Validation.Investor.Plan.tests, - Spec.Tokenomia.ICO.Funds.Validation.CardanoCLI.Plan.tests, - Spec.Tokenomia.Vesting.Sendings.tests +tests = testGroup "use cases" + [ Spec.Tokenomia.Wallet.UTxO.tests + , Spec.Tokenomia.Common.Value.tests + , Spec.Tokenomia.ICO.Funds.Exchange.Plan.tests + , Spec.Tokenomia.ICO.Funds.Validation.Investor.Plan.tests + , Spec.Tokenomia.ICO.Funds.Validation.CardanoCLI.Plan.tests + , Spec.Tokenomia.Vesting.Sendings.tests + , Spec.Tokenomia.Common.Data.List.Extra.tests + , Spec.Tokenomia.Common.Parser.Address.tests + , Spec.Tokenomia.Common.Time.tests + , Spec.Tokenomia.Vesting.GenerateNative.tests ] diff --git a/test/Spec/Tokenomia/Common/Data/List/Extra.hs b/test/Spec/Tokenomia/Common/Data/List/Extra.hs new file mode 100644 index 00000000..d6bfbbb8 --- /dev/null +++ b/test/Spec/Tokenomia/Common/Data/List/Extra.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Spec.Tokenomia.Common.Data.List.Extra + ( tests + ) where + +import Data.Function ( (&) ) + +import Test.QuickCheck.Function ( apply ) +import Test.QuickCheck.Modifiers ( NonEmptyList(..) ) +import Test.Tasty.QuickCheck ( testProperty ) +import Test.Tasty ( TestTree, testGroup ) + +import Tokenomia.Common.Data.List.Extra ( mapLastWith, transpose ) + + +tests :: TestTree +tests = testGroup "Common.Data.List.Extra" [ properties ] + +propertiesMapLastWith :: [TestTree] +propertiesMapLastWith = + [ testProperty "mapLastWith f g [] == []" + ( \(apply -> f) (apply -> g) -> + mapLastWith @Integer f g [] & null + ) + , testProperty "mapLastWith id id == id" + ( \(NonEmpty xs) -> + mapLastWith @Integer id id xs == xs + ) + , testProperty "mapLastWith f id == (map f init) ++ [last]" + ( \(NonEmpty xs) (apply -> f) -> + mapLastWith @Integer f id xs == map f (init xs) ++ [last xs] + ) + , testProperty "mapLastWith id g == init ++ [g last]" + ( \(NonEmpty xs) (apply -> g) -> + mapLastWith @Integer id g xs == init xs ++ [g (last xs)] + ) + , testProperty "mapLastWith f g == (map f init) ++ [g last]" + ( \(NonEmpty xs) (apply -> f) (apply -> g) -> + mapLastWith @Integer f g xs == map f (init xs) ++ [g (last xs)] + ) + ] + +propertiesTranspose :: [TestTree] +propertiesTranspose = + [ testProperty "transpose [] == []" $ transpose [] & null + , testProperty "valid transpose length" + ( \((NonEmpty xs) :: NonEmptyList [Integer]) -> + length (transpose xs) == minimum (length <$> xs) + ) + , testProperty "valid transpose elements length" + ( \(xs :: [[Integer]]) -> + all (== length xs) (length <$> transpose xs) + ) + ] + +properties :: TestTree +properties = testGroup "Properties" + [ testGroup "mapLastWith" propertiesMapLastWith + , testGroup "transpose" propertiesTranspose + ] diff --git a/test/Spec/Tokenomia/Common/Parser/Address.hs b/test/Spec/Tokenomia/Common/Parser/Address.hs new file mode 100644 index 00000000..43979045 --- /dev/null +++ b/test/Spec/Tokenomia/Common/Parser/Address.hs @@ -0,0 +1,34 @@ +module Spec.Tokenomia.Common.Parser.Address + ( tests + ) where + +import Data.Either.Combinators ( isRight ) +import Data.Functor.Syntax ( (<$$>) ) + +import Test.QuickCheck.Monadic ( monadicIO ) +import Test.Tasty.QuickCheck ( testProperty, withMaxSuccess ) +import Test.Tasty ( TestTree, testGroup ) + +import Tokenomia.Common.Arbitrary.Wallet ( PaymentAddress(..), generateAddresses ) +import Tokenomia.Common.Data.Convertible ( convert ) +import Tokenomia.Common.Parser.Address ( deserialiseCardanoAddress ) + + +tests :: TestTree +tests = testGroup "Common.Parser.Address" [ properties ] + +properties :: TestTree +properties = testGroup "Properties" + [ testGroup "deserialiseCardanoAddress" + [ testProperty "generated with cardano-address (testnet)" $ + withMaxSuccess 1 $ monadicIO $ + all isRight + <$> deserialiseCardanoAddress . convert . unPaymentAddress + <$$> generateAddresses "testnet" [0..3] + , testProperty "generated with cardano-address (mainnet)" $ + withMaxSuccess 1 $ monadicIO $ + all isRight + <$> deserialiseCardanoAddress . convert . unPaymentAddress + <$$> generateAddresses "mainnet" [0..3] + ] + ] diff --git a/test/Spec/Tokenomia/Common/Time.hs b/test/Spec/Tokenomia/Common/Time.hs new file mode 100644 index 00000000..9ae17d91 --- /dev/null +++ b/test/Spec/Tokenomia/Common/Time.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Spec.Tokenomia.Common.Time + ( tests + ) where + +import Data.Default ( def ) +import Ledger ( POSIXTime, Slot(..) ) +import Ledger.TimeSlot ( posixTimeToEnclosingSlot, slotToBeginPOSIXTime ) + +import Test.Tasty.QuickCheck ( testProperty ) +import Test.Tasty ( TestTree, testGroup ) + +import Tokenomia.Common.Arbitrary.POSIXTime ( ) +import Tokenomia.Common.Arbitrary.Slot ( ) + +import Tokenomia.Common.Time + ( posixTimeToEnclosingSlotNo + , slotAfterNextBeginPOSIXTime + , toNextBeginPOSIXTime + ) + + +tests :: TestTree +tests = testGroup "Common.Time" [ properties ] + +propertiesPosixTimeToEnclosingSlotNo :: [TestTree] +propertiesPosixTimeToEnclosingSlotNo = + [ testProperty "preserve order" + ( \(a :: POSIXTime) (b :: POSIXTime) -> + let na = posixTimeToEnclosingSlotNo a + nb = posixTimeToEnclosingSlotNo b + in + elem (compare na nb) [EQ, compare a b] + ) + ] + +propertiesSlotAfterNextBeginPOSIXTime :: [TestTree] +propertiesSlotAfterNextBeginPOSIXTime = + [ testProperty "preserve order" + ( \(a :: POSIXTime) (b :: POSIXTime) -> + let na = slotAfterNextBeginPOSIXTime a + nb = slotAfterNextBeginPOSIXTime b + in + elem (compare na nb) [EQ, compare a b] + ) + , testProperty "is after enclosing slot" + ( \(a :: POSIXTime) -> + posixTimeToEnclosingSlot def a <= slotAfterNextBeginPOSIXTime a + ) + ] + +propertiesToNextBeginPOSIXTime :: [TestTree] +propertiesToNextBeginPOSIXTime = + [ testProperty "is a future time" + ( \(time :: POSIXTime) -> + time <= toNextBeginPOSIXTime time + ) + , testProperty "is a slot starting time" + ( \(time :: POSIXTime) -> + let begin = toNextBeginPOSIXTime time + n = posixTimeToEnclosingSlot def begin + in + begin == slotToBeginPOSIXTime def n + ) + , testProperty "is an identity of slots starting time" + ( \(n :: Slot) -> + let begin = slotToBeginPOSIXTime def n + in + begin == toNextBeginPOSIXTime begin + ) + ] + +properties :: TestTree +properties = testGroup "Properties" + [ testGroup "posixTimeToEnclosingSlotNo" propertiesPosixTimeToEnclosingSlotNo + , testGroup "slotAfterNextBeginPOSIXTime" propertiesSlotAfterNextBeginPOSIXTime + , testGroup "toNextBeginPOSIXTime" propertiesToNextBeginPOSIXTime + ] diff --git a/test/Spec/Tokenomia/Vesting/GenerateNative.hs b/test/Spec/Tokenomia/Vesting/GenerateNative.hs new file mode 100644 index 00000000..6676f474 --- /dev/null +++ b/test/Spec/Tokenomia/Vesting/GenerateNative.hs @@ -0,0 +1,546 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TupleSections #-} + +module Spec.Tokenomia.Vesting.GenerateNative + ( tests + ) where + +import Control.Applicative ( ZipList(..) ) +import Control.Monad.Except ( runExceptT ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Reader ( runReaderT ) +import Data.List.NonEmpty ( NonEmpty(..), (<|) ) +import Data.List.NonEmpty qualified + as NEList ( fromList, toList, zip, zipWith ) + +import Data.Map ( unionsWith ) +import Data.Map.NonEmpty ( NEMap ) +import Data.Map.NonEmpty qualified + as NEMap ( fromList, toList, toMap, keys, elems ) + +import Data.Either ( isRight ) +import Data.Either.Combinators ( fromRight' ) +import Data.Functor ( (<&>) ) +import Data.Functor.Syntax ( (<$$>) ) +import Data.Kind ( Type ) +import Data.Ratio ( (%) ) + +import GHC.Natural ( Natural, naturalFromInteger ) + +import Test.Tasty ( TestTree, testGroup ) +import Test.Tasty.HUnit ( testCase, (@?=) ) +import Test.QuickCheck.Modifiers ( NonEmptyList(..), Positive(..) ) +import Test.QuickCheck.Monadic ( monadicIO ) + +import Test.Tasty.QuickCheck + ( Arbitrary + , Gen + , Property + , arbitrary + , genericShrink + , mapSize + , noShrinking + , scale + , shrink + , shrinkList + , sized + , testProperty + , vectorOf + , withMaxSuccess + ) + +import Tokenomia.Common.Arbitrary.AssetClass () +import Tokenomia.Common.Arbitrary.Modifiers ( Restricted(..) ) +import Tokenomia.Common.Arbitrary.POSIXTime () +import Tokenomia.Common.Arbitrary.Wallet ( PaymentAddress(..), generateAddresses ) + +import Tokenomia.Common.Data.Convertible ( convert ) +import Tokenomia.Common.Data.List.Extra ( transpose ) +import Tokenomia.Common.Environment ( getTestnetEnvironmment ) +import Tokenomia.Common.Time ( toNextBeginPOSIXTime ) + +import Tokenomia.TokenDistribution.Distribution ( Distribution(recipients), Recipient(..) ) + +import Tokenomia.Vesting.GenerateNative + ( DatabaseOutput(..) + , InvestorAddress(..) + , NativeScript (..) + , NativeScriptInfo (..) + , PrivateSale(..) + , PrivateSaleTranche(..) + , TrancheProperties(..) + , TranchesProportions(..) + , investorAddressPubKeyHash + , merge + , minAllocation + , scaleRatios + , splitAllocation + , splitInTranches + , toDatabaseOutput + , toDistribution + , trancheNativeScriptInfos + , validateAllocations + , validatePrivateSale + , validateTranchesProportions + ) + +-- import Test.QuickCheck.Monadic ( assert ) +-- import Tokenomia.Vesting.GenerateNativeRefacto ( getNetworkId ) +-- import System.FilePath ( replaceFileName ) +-- import Data.Aeson ( encodeFile ) +-- import Tokenomia.TokenDistribution.Distribution ( WithNetworkId(..) ) + + +instance Arbitrary InvestorAddress where + arbitrary = InvestorAddress <$> arbitrary + shrink = genericShrink + +instance Arbitrary TrancheProperties where + arbitrary = TrancheProperties <$> arbitrary <*> arbitrary + shrink = genericShrink + +instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (NEMap k v) where + arbitrary = NEMap.fromList <$> arbitrary + shrink = fmap NEMap.fromList . shrinkAssocs . NEMap.toList + where + shrinkAssocs :: forall a b. Arbitrary b => NonEmpty (a, b) -> [NonEmpty (a, b)] + shrinkAssocs xs = + [ NEList.fromList xs' + | xs' <- shrinkList shrinkPair (NEList.toList xs) + , not (null xs') + ] + + shrinkPair :: forall a b. Arbitrary b => (a, b) -> [(a, b)] + shrinkPair (k, v) = (k,) <$> shrink v + +instance Arbitrary PrivateSale where + arbitrary = PrivateSale <$> arbitrary <*> arbitrary <*> arbitrary + shrink = genericShrink + +------------------------------------------------------------------------------- + +instance Arbitrary TranchesProportions where + arbitrary = + TranchesProportions <$> + do + xs <- getPositive <$$> arbitrary + pure $ xs <&> (% sum xs) + shrink (TranchesProportions (x :| xs)) + | null xs = [] + | otherwise = + let shrinks = shrink $ TranchesProportions $ NEList.fromList xs + in + TranchesProportions <$> + (x + head xs :| tail xs) + : ((x <|) . unTranchesProportions <$> shrinks) + +-- | Arbitrary TranchesProportions are well-formed +validTranchesProportions :: TranchesProportions -> Bool +validTranchesProportions = isRight . validateTranchesProportions + +-- | All shrinked TranchesProportions are well-formed and smaller +validTranchesProportionsShrinks :: TranchesProportions -> Bool +validTranchesProportionsShrinks x = + let shrinks = shrink x + n = length (unTranchesProportions x) + in + length shrinks == n - 1 + && all (\y -> length (unTranchesProportions y) == n - 1) shrinks + && all validTranchesProportions shrinks + +-- | Partitionning the minimum allocation still yields valid parts +validMinAllocation :: Natural -> TranchesProportions -> Bool +validMinAllocation ε xs = + all (>= ε) $ + splitAllocation xs (minAllocation ε xs) + +------------------------------------------------------------------------------- +-- +-- [Note: Shrinking a record] +-- +-- The `a : shrink a` expression provides a way to build shrinks of a record +-- with at least one field shrinked, in an applicative way. Taking the tail +-- ensure to exclude the original record from the shrinks. +-- +-- Next improvement step would be to find a way to shrink exactly one field. +-- + +instance Arbitrary (Restricted (NonEmpty TrancheProperties)) where + arbitrary = + Restricted <$> + do + proportions <- unTranchesProportions <$> arbitrary + unlockTimes <- vectorOf (length proportions) arbitrary + pure $ NEList.fromList . getZipList $ + TrancheProperties + <$> ZipList (NEList.toList proportions) + <*> ZipList unlockTimes + shrink (Restricted xs) = + let proportions = TranchesProportions $ proportion <$> xs + unlockTimes = unlockTime <$> xs + + shrinkedProportions = unTranchesProportions <$> shrink proportions + noshrinkUnlockTimes = repeat unlockTimes + + shrinkedProperties = + getZipList $ + NEList.zipWith TrancheProperties + <$> ZipList shrinkedProportions + <*> ZipList noshrinkUnlockTimes + in + Restricted <$> shrinkedProperties + +instance Arbitrary (Restricted PrivateSale) where + arbitrary = + do + tranchesProperties <- getRestricted <$> arbitrary + assetClass <- arbitrary + allocationByAddress <- scale (*7) arbitrary + + let proportions = TranchesProportions $ proportion <$> tranchesProperties + ε = 10 + µ = minAllocation ε proportions + + pure $ + Restricted $ PrivateSale + tranchesProperties + assetClass + ((+ µ) <$> allocationByAddress) + shrink (Restricted PrivateSale{..}) = + let shrinkedProperties = + getRestricted <$> shrink' (Restricted tranchesProperties) + shrinkedAssetClass = shrink' assetClass + shrinkedAllocationByAddress = shrink' allocationByAddress + + shrinkedPrivateSale = + PrivateSale + <$> shrinkedProperties + <*> shrinkedAssetClass + <*> shrinkedAllocationByAddress + in + Restricted <$> filter validPrivateSaleAllocations (tail shrinkedPrivateSale) + where + shrink' :: forall a. Arbitrary a => a -> [a] + shrink' a = a : shrink a + +-- | Validate only allocations of a PrivateSale +validPrivateSaleAllocations :: PrivateSale -> Bool +validPrivateSaleAllocations PrivateSale{..} = + let proportions = TranchesProportions $ proportion <$> tranchesProperties + ε = 10 + in + isRight $ validateAllocations ε proportions $ NEMap.elems allocationByAddress + +-- | Convert generated PaymentAddress to InvestorAddress +toInvestorAddress :: PaymentAddress -> InvestorAddress +toInvestorAddress = InvestorAddress . convert . unPaymentAddress + +-- | Update a PrivateSale with valid generated testnet addresses +useValidAddresses :: + forall (m :: Type -> Type). + ( MonadIO m ) + => PrivateSale -> m PrivateSale +useValidAddresses PrivateSale{..} = + do + let allocations = NEMap.elems allocationByAddress + addresses <- toInvestorAddress <$$> generateAddresses "testnet" (indices allocations) + pure PrivateSale{allocationByAddress=NEMap.fromList $ NEList.zip addresses allocations,..} + where + indices :: forall (a :: Type). NonEmpty a -> NonEmpty Integer + indices = NEList.fromList . (\n -> [0..n-1]) . toInteger . length + +-- | Validate an arbitrary PrivateSale updated with valid addresses +validRestrictedPrivateSale :: Restricted PrivateSale -> Property +validRestrictedPrivateSale (Restricted privateSale) = + monadicIO $ + useValidAddresses privateSale + <&> isRight . validatePrivateSale + +-- | Validate shrinks of an arbitrary PrivateSale updated with valid addresses +validRestrictedPrivateSaleShrinks :: Restricted PrivateSale -> Property +validRestrictedPrivateSaleShrinks (Restricted privateSale) = + monadicIO $ + useValidAddresses privateSale + <&> all (isRight . validatePrivateSale . getRestricted) + . take 30 . shrink . Restricted + +------------------------------------------------------------------------------- + +tests :: TestTree +tests = testGroup "Vesting.GenerateNative" [ unitTests, properties ] + +unitTests :: TestTree +unitTests = testGroup "Unit tests" + [ testGroup "scaleRatios" + [ testCase "empty list" $ scaleRatios [] ( 0 :: Integer) @?= [] + , testCase "scale == 0" $ scaleRatios [1%10, 2%10, 3%10, 4%10] ( 0 :: Integer) @?= [0, 0, 0 , 0] + , testCase "scale == 1" $ scaleRatios [1%1 , 2%1 , 3%1 , 4%1 ] ( 1 :: Integer) @?= [1, 2, 3, 4] + , testCase "sum ratios == 1" $ scaleRatios [1%10, 2%10, 3%10, 4%10] (98 :: Integer) @?= [9, 19, 29, 41] + , testCase "sum ratios != 1" $ scaleRatios [1%10, 2%10, 3%10] (98 :: Integer) @?= [9, 19, 30] + ] + ] + +propertiesScaleRatios:: TestTree +propertiesScaleRatios = + testGroup "scaleRatios" + [ testProperty "scale == 0" + ( \(as :: NonEmptyList Integer) -> + let bs = getNonEmpty as + xs = (% max 1 (sum bs)) <$> bs + in + all (==0) $ scaleRatios xs 0 + ) + , testProperty "scale == 1" + ( \(as :: NonEmptyList Integer) -> + let bs = getNonEmpty as + xs = (% 1) <$> bs + in + scaleRatios xs 1 == bs + ) + ] + +propertiesArbitraryTranchesProportions :: TestTree +propertiesArbitraryTranchesProportions = + testGroup "Arbitrary TranchesProportions" + [ testProperty "valid arbitrary" validTranchesProportions + , testProperty "valid shrinks" validTranchesProportionsShrinks + , testProperty "valid minAllocation" validMinAllocation + ] + +propertiesArbitraryRestrictedPrivateSale :: TestTree +propertiesArbitraryRestrictedPrivateSale = + testGroup "Arbitrary Restricted PrivateSale" + [ testProperty "valid arbitrary" $ + withMaxSuccess 1 $ mapSize (const 7) validRestrictedPrivateSale + , testProperty "valid shrinks" $ + withMaxSuccess 1 $ mapSize (const 7) validRestrictedPrivateSaleShrinks + ] + +propertiesSplitInTranches :: TestTree +propertiesSplitInTranches = + testGroup "splitInTranches" + [ testProperty "split length equals number of tranches" + ( \(ps :: PrivateSale) -> + length (splitInTranches ps) == length (tranchesProperties ps) + ) + , testProperty "valid tranches assetclass" + ( \(ps :: PrivateSale) -> + all (==assetClass ps) (trancheAssetClass <$> splitInTranches ps) + ) + , testProperty "valid tranches unlocktime" + ( \(ps :: PrivateSale) -> + (unlockTime <$> tranchesProperties ps) + == (trancheUnlockTime <$> splitInTranches ps) + ) + , testProperty "valid tranches allocation sum" + ( \(Restricted ps :: Restricted PrivateSale) -> + NEMap.toMap (allocationByAddress ps) + == unionsWith + (+) + (NEMap.toMap . trancheAllocationByAddress <$> splitInTranches ps) + ) + ] + +propertiesInvestorAddressPubKeyHash :: TestTree +propertiesInvestorAddressPubKeyHash = + testGroup "investorAddressPubKeyHash" + [ testProperty "valid tranches allocation sum" $ withMaxSuccess 1 $ + monadicIO $ + all isRight <$> + do + addresses <- toInvestorAddress <$$> generateAddresses "testnet" [0..5] + traverse (runExceptT . investorAddressPubKeyHash) addresses + ] + +validTrancheNativeScriptUnlockTime :: PrivateSaleTranche -> NEMap InvestorAddress NativeScriptInfo -> Bool +validTrancheNativeScriptUnlockTime PrivateSaleTranche{..} xs = + all + (== toNextBeginPOSIXTime trancheUnlockTime) + (requireTimeAfter . requiring <$> NEMap.elems xs) + +validTrancheNativeScriptAddress :: PrivateSaleTranche -> NEMap InvestorAddress NativeScriptInfo -> Bool +validTrancheNativeScriptAddress PrivateSaleTranche{..} xs = + NEMap.keys trancheAllocationByAddress == NEMap.keys xs + +validTrancheNativeScriptAllocation :: PrivateSaleTranche -> NEMap InvestorAddress NativeScriptInfo -> Bool +validTrancheNativeScriptAllocation PrivateSaleTranche{..} xs = + let allNativeScriptsAllocation = + naturalFromInteger . amount . recipient <$> NEMap.elems xs + in + NEMap.elems trancheAllocationByAddress == allNativeScriptsAllocation + +propertiesTrancheNativeScriptInfos :: TestTree +propertiesTrancheNativeScriptInfos = + testGroup "trancheNativeScriptInfos" + [ testProperty "valid trancheNativeScriptInfos" $ + withMaxSuccess 1 $ mapSize (const 7) + ( \(Restricted ps :: Restricted PrivateSale) -> + monadicIO $ do + env <- getTestnetEnvironmment 1097911063 + validPrivateSale <- useValidAddresses ps + and + <$> traverse + (runValidTrancheNativeScriptInfos env) + (splitInTranches validPrivateSale) + ) + ] + where + runValidTrancheNativeScriptInfos env tranche = + runExceptT (runReaderT (trancheNativeScriptInfos tranche) env) + <&> validTrancheNativeScriptInfos tranche + validTrancheNativeScriptInfos tranche e = + let xs = fromRight' e + in + isRight e + && validTrancheNativeScriptUnlockTime tranche xs + && validTrancheNativeScriptAddress tranche xs + && validTrancheNativeScriptAllocation tranche xs + +newtype MapToTranspose k v + = MapToTranspose + { unMapToTranspose :: NEMap k (NonEmpty v) } + deriving stock (Show) + +newtype MapsToMerge k v + = MapsToMerge + { unMapsToMerge :: NonEmpty (NEMap k v) } + deriving stock (Show) + +nonEmptyVectorOf :: Int -> Gen a -> Gen (NonEmpty a) +nonEmptyVectorOf n gen = (:|) <$> gen <*> vectorOf n gen + +instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (MapToTranspose k v) where + arbitrary = + sized $ \n -> + do + keys <- nonEmptyVectorOf n arbitrary + vals <- nonEmptyVectorOf n (nonEmptyVectorOf n arbitrary) + pure $ MapToTranspose $ NEMap.fromList $ NEList.zip keys vals + +instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (MapsToMerge k v) where + arbitrary = + sized $ \n -> + do + keys <- nonEmptyVectorOf n arbitrary + MapsToMerge + <$> nonEmptyVectorOf n + (NEMap.fromList + <$> (NEList.zip keys + <$> nonEmptyVectorOf n arbitrary)) + +propertiesMerge :: TestTree +propertiesMerge = + testGroup "merge transposed squared map" + [ testProperty "merge . transpose == id" $ noShrinking + ( \((MapToTranspose xs) :: MapToTranspose Integer Integer) -> + let ys = transpose (NEList.toList <$> xs) + in + xs == merge (NEList.fromList ys) + ) + , testProperty "transpose . merge == id" $ noShrinking + ( \((MapsToMerge xs) :: MapsToMerge Integer Integer) -> + let ys = merge xs + in + xs == NEList.fromList (transpose (NEList.toList <$> ys)) + ) + ] + +validDatabaseOutputLength :: NonEmpty PrivateSaleTranche -> DatabaseOutput -> Bool +validDatabaseOutputLength xs DatabaseOutput{..} = + all + (==length lockedFunds) + (length . trancheAllocationByAddress <$> xs) + +validDatabaseOutputScriptsCount :: NonEmpty PrivateSaleTranche -> DatabaseOutput -> Bool +validDatabaseOutputScriptsCount xs DatabaseOutput{..} = + all + (==length xs) + (length <$> NEMap.elems lockedFunds) + +propertiesToDatabaseOutput :: TestTree +propertiesToDatabaseOutput = + testGroup "toDatabaseOutput" + [ testProperty "valid DatabaseOutput" $ noShrinking $ + withMaxSuccess 1 $ mapSize (const 7) + ( \(Restricted ps :: Restricted PrivateSale) -> + monadicIO $ do + env <- getTestnetEnvironmment 1097911063 + validPrivateSale <- useValidAddresses ps + let tranches = splitInTranches validPrivateSale + runToDatabaseOutput env tranches + <&> validDatabaseOutput tranches + ) + ] + where + runToDatabaseOutput env tranches = + runExceptT (runReaderT (toDatabaseOutput tranches) env) + validDatabaseOutput tranches e = + let xs = fromRight' e + in + isRight e + && validDatabaseOutputLength tranches xs + && validDatabaseOutputScriptsCount tranches xs + +validDistributionLength :: NonEmpty PrivateSaleTranche -> Distribution -> Bool +validDistributionLength xs distribution = + length (recipients distribution) + == sum (length . trancheAllocationByAddress <$> xs) + +propertiesToDistribution :: TestTree +propertiesToDistribution = + testGroup "toDistribution" + [ testProperty "valid Distribution" $ noShrinking $ + withMaxSuccess 1 $ mapSize (const 7) + ( \(Restricted ps :: Restricted PrivateSale) -> + monadicIO $ do + env <- getTestnetEnvironmment 1097911063 + validPrivateSale <- useValidAddresses ps + let tranches = splitInTranches validPrivateSale + runToDistribution env tranches + <&> validDistribution tranches + ) + ] + where + runToDistribution env tranches = + runExceptT (runReaderT (toDistribution <$> toDatabaseOutput tranches) env) + validDistribution tranches e = + let xs = fromRight' e + in + isRight e + && validDistributionLength tranches xs + +properties :: TestTree +properties = testGroup "Properties" + [ propertiesScaleRatios + , propertiesArbitraryTranchesProportions + , propertiesArbitraryRestrictedPrivateSale + , propertiesSplitInTranches + , propertiesInvestorAddressPubKeyHash + , propertiesTrancheNativeScriptInfos + , propertiesMerge + , propertiesToDatabaseOutput + , propertiesToDistribution + --, propertiesToJSON + ] + +-- propertiesToJSON :: TestTree +-- propertiesToJSON = +-- testGroup "toJSON" +-- [ testProperty "toJSON" $ withMaxSuccess 1 $ mapSize (const 7) +-- ( \(Restricted ps :: Restricted PrivateSale) -> +-- monadicIO $ do +-- env <- getTestnetEnvironmment 1097911063 +-- networkId <- runReaderT getNetworkId env +-- validPrivateSale <- useValidAddresses ps +-- let privateSaleTranches = splitInTranches validPrivateSale +-- databaseOutput <- runExceptT $ runReaderT (toDatabaseOutput privateSaleTranches) env +-- liftIO $ encodeFile (replaceFileName "/tmp/" "database.json") (fromRight' databaseOutput `WithNetworkId` networkId) +-- liftIO $ encodeFile (replaceFileName "/tmp/" "distribution.json") (toDistribution (fromRight' databaseOutput) `WithNetworkId` networkId) +-- assert True +-- ) +-- ] diff --git a/tokenomia.cabal b/tokenomia.cabal index 018ad2e6..dc2cc2d5 100644 --- a/tokenomia.cabal +++ b/tokenomia.cabal @@ -72,6 +72,13 @@ library Tokenomia.Vesting.Retrieve Tokenomia.Vesting.Sendings Tokenomia.Tokenomic.CLAP.Simulation + Tokenomia.Common.Aeson.AssetClass + Tokenomia.Common.Arbitrary.AssetClass + Tokenomia.Common.Arbitrary.Builtins + Tokenomia.Common.Arbitrary.Modifiers + Tokenomia.Common.Arbitrary.POSIXTime + Tokenomia.Common.Arbitrary.Slot + Tokenomia.Common.Arbitrary.Wallet Tokenomia.Common.AssetClass Tokenomia.Common.Blockfrost Tokenomia.Common.Value @@ -86,12 +93,15 @@ library Tokenomia.Common.Address Tokenomia.Common.Asset Tokenomia.Common.Hash + Tokenomia.Common.Time Tokenomia.Common.Token Tokenomia.Common.PageNumber Tokenomia.Common.Data.ByteString Tokenomia.Common.Data.Convertible + Tokenomia.Common.Data.List.Extra Tokenomia.Common.Data.List.NonEmpty Tokenomia.Common.Parser + Tokenomia.Common.Parser.Address Tokenomia.Common.Parser.AssetClass Tokenomia.Common.Parser.MinRequiredUTxO Tokenomia.Common.Parser.Value @@ -152,6 +162,7 @@ library composition, composition-extra, either, + errors, extra, filepath, memory, @@ -202,7 +213,9 @@ library deepseq, hashable, hex, - hex-text + hex-text, + tasty-quickcheck, + quickcheck-instances hs-source-dirs: src test-suite tokenomia-tests @@ -211,6 +224,10 @@ test-suite tokenomia-tests main-is: Spec.hs hs-source-dirs: test other-modules: + Spec.Tokenomia.Vesting.GenerateNative + Spec.Tokenomia.Common.Data.List.Extra + Spec.Tokenomia.Common.Parser.Address + Spec.Tokenomia.Common.Time Spec.Tokenomia.Token.CLAPStyle.MonetaryPolicy Spec.Tokenomia.Vesting.Contract Spec.Tokenomia.Vesting.Sendings @@ -250,6 +267,7 @@ test-suite tokenomia-tests safe-money, containers, either, + composition-extra, hex, data-default From eb1c725f1231f37df431dac5ec0c18b313206ac5 Mon Sep 17 00:00:00 2001 From: devfull <26844641+devfull@users.noreply.github.com> Date: Mon, 5 Sep 2022 16:56:09 +0200 Subject: [PATCH 02/15] [vesting] add minimumUTxO calculation and tests --- src/Tokenomia/CardanoApi/Fees.hs | 110 +++++++++++++ src/Tokenomia/CardanoApi/FromPlutus/Error.hs | 12 ++ src/Tokenomia/CardanoApi/FromPlutus/Value.hs | 72 +++++++++ src/Tokenomia/CardanoApi/PParams.hs | 42 +++++ src/Tokenomia/CardanoApi/Value.hs | 16 ++ src/Tokenomia/Common/Arbitrary/AssetClass.hs | 49 +++++- src/Tokenomia/Common/Arbitrary/Builtins.hs | 56 +++++-- src/Tokenomia/Common/Arbitrary/Utils.hs | 26 +++ src/Tokenomia/Common/Arbitrary/Value.hs | 39 +++++ src/Tokenomia/Common/Data/ByteString.hs | 7 +- src/Tokenomia/Common/Data/Either/Extra.hs | 10 ++ src/Tokenomia/Vesting/GenerateNative.hs | 28 +++- test/Spec.hs | 8 + test/Spec/Tokenomia/CardanoApi/Fees.hs | 148 ++++++++++++++++++ .../Tokenomia/CardanoApi/FromPlutus/Value.hs | 69 ++++++++ .../Tokenomia/Common/Arbitrary/Builtins.hs | 82 ++++++++++ test/Spec/Tokenomia/Common/Arbitrary/Utils.hs | 38 +++++ test/Spec/Tokenomia/Vesting/GenerateNative.hs | 12 +- tokenomia.cabal | 15 ++ 19 files changed, 814 insertions(+), 25 deletions(-) create mode 100644 src/Tokenomia/CardanoApi/Fees.hs create mode 100644 src/Tokenomia/CardanoApi/FromPlutus/Error.hs create mode 100644 src/Tokenomia/CardanoApi/FromPlutus/Value.hs create mode 100644 src/Tokenomia/CardanoApi/PParams.hs create mode 100644 src/Tokenomia/CardanoApi/Value.hs create mode 100644 src/Tokenomia/Common/Arbitrary/Utils.hs create mode 100644 src/Tokenomia/Common/Arbitrary/Value.hs create mode 100644 src/Tokenomia/Common/Data/Either/Extra.hs create mode 100644 test/Spec/Tokenomia/CardanoApi/Fees.hs create mode 100644 test/Spec/Tokenomia/CardanoApi/FromPlutus/Value.hs create mode 100644 test/Spec/Tokenomia/Common/Arbitrary/Builtins.hs create mode 100644 test/Spec/Tokenomia/Common/Arbitrary/Utils.hs diff --git a/src/Tokenomia/CardanoApi/Fees.hs b/src/Tokenomia/CardanoApi/Fees.hs new file mode 100644 index 00000000..f0d4dd2a --- /dev/null +++ b/src/Tokenomia/CardanoApi/Fees.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +module Tokenomia.CardanoApi.Fees + ( HasDatumHash(..) + , calculateDefaultMinimumUTxOFromValue + , calculateMinimumUTxOFromValue + , calculateDefaultMinimumUTxOFromAssetId + , calculateMinimumUTxOFromAssetId + , utxoEntrySize + ) + where + +import Cardano.Api + ( ShelleyBasedEra(..) + , AssetId(..) + , Value + , Lovelace(..) + , selectLovelace + , valueFromList + ) + +import Cardano.Api.Shelley + ( ProtocolParameters(..) + , calcMinimumDeposit + , lovelaceToValue + , toMaryValue + ) + +import Cardano.Ledger.Val qualified + as Value ( size ) + +import Tokenomia.CardanoApi.Value ( unLovelace ) +import Tokenomia.CardanoApi.PParams ( defaultCalculateMinimumUTxOParams ) + + +data HasDatumHash + = NoDatumHash + | WithDatumHash + deriving stock (Show) + +-- | Utxo entry size calculation +utxoEntrySize :: Value -> HasDatumHash -> Integer +utxoEntrySize value datum = + utxoEntrySizeWithoutVal + Value.size (toMaryValue value) + datumHashSize datum + where + datumHashSize :: HasDatumHash -> Integer + datumHashSize NoDatumHash = 0 + datumHashSize WithDatumHash = 10 + + utxoEntrySizeWithoutVal :: Integer + utxoEntrySizeWithoutVal = 27 + +-- | Calculate minimumUTxO simply from Value instead of TxOut +calculateMinimumUTxOFromValue :: + forall era. + ShelleyBasedEra era + -> Value + -> HasDatumHash + -> ProtocolParameters + -> Maybe Value +calculateMinimumUTxOFromValue era value datumHash ProtocolParameters{..} = + lovelaceToValue <$> + case era of + ShelleyBasedEraShelley -> protocolParamMinUTxOValue + ShelleyBasedEraAllegra -> calculateMinimumUTxOAllegraMary + ShelleyBasedEraMary -> calculateMinimumUTxOAllegraMary + ShelleyBasedEraAlonzo -> calculateMinimumUTxOAlonzo + where + calculateMinimumUTxOAllegraMary :: Maybe Lovelace + calculateMinimumUTxOAllegraMary = + calcMinimumDeposit value + <$> protocolParamMinUTxOValue + + calculateMinimumUTxOAlonzo :: Maybe Lovelace + calculateMinimumUTxOAlonzo = + (Lovelace (utxoEntrySize value datumHash) *) + <$> protocolParamUTxOCostPerWord + +-- | Calculate minimumUTxO with default protocol parameters from a Value +calculateDefaultMinimumUTxOFromValue :: + forall era. + ShelleyBasedEra era -> Value -> HasDatumHash -> Maybe Value +calculateDefaultMinimumUTxOFromValue era value datumHash = + calculateMinimumUTxOFromValue era value datumHash $ + defaultCalculateMinimumUTxOParams era + +-- | Calculate minimumUTxO for a singleton Value from AssetId +calculateMinimumUTxOFromAssetId :: + forall era. + ShelleyBasedEra era + -> AssetId + -> ProtocolParameters + -> Maybe Integer +calculateMinimumUTxOFromAssetId era assetId parameters = + let value = valueFromList [(assetId, 1)] + in + unLovelace . selectLovelace <$> + calculateMinimumUTxOFromValue era value NoDatumHash parameters + +-- | Calculate minimumUTxO with default protocol parameters from AssetId +calculateDefaultMinimumUTxOFromAssetId :: + forall era. + ShelleyBasedEra era -> AssetId -> Maybe Integer +calculateDefaultMinimumUTxOFromAssetId era assetId = + calculateMinimumUTxOFromAssetId era assetId $ + defaultCalculateMinimumUTxOParams era diff --git a/src/Tokenomia/CardanoApi/FromPlutus/Error.hs b/src/Tokenomia/CardanoApi/FromPlutus/Error.hs new file mode 100644 index 00000000..215cb1bc --- /dev/null +++ b/src/Tokenomia/CardanoApi/FromPlutus/Error.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Tokenomia.CardanoApi.FromPlutus.Error + ( FromPlutusError(..) + ) where + + +data FromPlutusError + = PlutusCurrencySymbolNotPolicyId + | PlutusTokenNameNotAssetName + | PlutusAssetClassNotAssetId + deriving stock (Show) diff --git a/src/Tokenomia/CardanoApi/FromPlutus/Value.hs b/src/Tokenomia/CardanoApi/FromPlutus/Value.hs new file mode 100644 index 00000000..7eddbe8a --- /dev/null +++ b/src/Tokenomia/CardanoApi/FromPlutus/Value.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TupleSections #-} + +module Tokenomia.CardanoApi.FromPlutus.Value + ( currencySymbolAsPolicyId + , tokenNameAsAssetName + , assetClassAsAssetId + , fromPlutusValue + ) where + +import Data.Either.Combinators ( maybeToRight ) +import Data.Functor ( (<&>) ) +import Tokenomia.Common.Data.Either.Extra ( toEither ) + +import Cardano.Api + ( PolicyId + , AssetName + , AssetId(..) + , AsType(..) + , Quantity(..) + , Value + , deserialiseFromRawBytes + , valueFromList + ) + +import PlutusTx.Builtins ( fromBuiltin ) +import Plutus.V1.Ledger.Ada ( adaSymbol, adaToken ) +import Plutus.V1.Ledger.Value qualified + as Plutus ( Value ) +import Plutus.V1.Ledger.Value + ( AssetClass(..) + , CurrencySymbol(..) + , TokenName(..) + , flattenValue + , assetClass + ) + +import Tokenomia.CardanoApi.FromPlutus.Error + ( FromPlutusError(..) ) + + +-- | Convert a CurrencySymbol to a PolicyId +currencySymbolAsPolicyId :: CurrencySymbol -> Either FromPlutusError PolicyId +currencySymbolAsPolicyId (CurrencySymbol x) = + maybeToRight PlutusCurrencySymbolNotPolicyId $ + deserialiseFromRawBytes AsPolicyId (fromBuiltin x) + +-- | Convert a TokenName to an AssetName +tokenNameAsAssetName :: TokenName -> Either FromPlutusError AssetName +tokenNameAsAssetName (TokenName x) = + maybeToRight PlutusTokenNameNotAssetName $ + deserialiseFromRawBytes AsAssetName (fromBuiltin x) + +-- | Convert an AssetClass to an AssetId +assetClassAsAssetId :: AssetClass -> Either FromPlutusError AssetId +assetClassAsAssetId (AssetClass (cs, tn)) + | cs == adaSymbol = + toEither (tn == adaToken) + PlutusAssetClassNotAssetId + AdaAssetId + | otherwise = + AssetId + <$> currencySymbolAsPolicyId cs + <*> tokenNameAsAssetName tn + +-- | Convert a Plutus Value to a Cardano.Api Value +fromPlutusValue :: Plutus.Value -> Either FromPlutusError Value +fromPlutusValue value = + valueFromList <$> sequence (fromPlutusSingleton <$> flattenValue value) + where + fromPlutusSingleton (cs, tn, x) = + assetClassAsAssetId (assetClass cs tn) <&> (, Quantity x) diff --git a/src/Tokenomia/CardanoApi/PParams.hs b/src/Tokenomia/CardanoApi/PParams.hs new file mode 100644 index 00000000..b02aa637 --- /dev/null +++ b/src/Tokenomia/CardanoApi/PParams.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +module Tokenomia.CardanoApi.PParams + ( defaultCalculateMinimumUTxOParams + , withCalculateMinimumUTxOParams + ) where + +import Cardano.Api ( ShelleyBasedEra(..), fromLedgerPParams ) +import Cardano.Api.Shelley ( ProtocolParameters, ShelleyLedgerEra ) +import Cardano.Ledger.Coin ( Coin (..) ) +import Cardano.Ledger.Core ( PParams ) +import Cardano.Ledger.Alonzo.PParams ( PParams'(..) ) +import Cardano.Ledger.Shelley.PParams ( PParams'(..) ) +import Data.Default ( def ) + + +-- | Update the right parameters necessary to calculateMinimumUTxO +withCalculateMinimumUTxOParams :: + forall era. + Integer -> ShelleyBasedEra era -> PParams (ShelleyLedgerEra era) -> ProtocolParameters +withCalculateMinimumUTxOParams n era pparams = + fromLedgerPParams era $ updateWith (Coin n) pparams + where + updateWith = + case era of + ShelleyBasedEraShelley -> (\x up -> up {_minUTxOValue = x}) + ShelleyBasedEraAllegra -> (\x up -> up {_minUTxOValue = x}) + ShelleyBasedEraMary -> (\x up -> up {_minUTxOValue = x}) + ShelleyBasedEraAlonzo -> (\x up -> up {_coinsPerUTxOWord = x}) + +-- | Default parameters necessary to calculateMinimumUTxO +defaultCalculateMinimumUTxOParams :: + forall era. + ShelleyBasedEra era -> ProtocolParameters +defaultCalculateMinimumUTxOParams era = + case era of + ShelleyBasedEraShelley -> withCalculateMinimumUTxOParams 1000000 era def + ShelleyBasedEraAllegra -> withCalculateMinimumUTxOParams 1000000 era def + ShelleyBasedEraMary -> withCalculateMinimumUTxOParams 1000000 era def + ShelleyBasedEraAlonzo -> withCalculateMinimumUTxOParams 34482 era def diff --git a/src/Tokenomia/CardanoApi/Value.hs b/src/Tokenomia/CardanoApi/Value.hs new file mode 100644 index 00000000..6a69b56f --- /dev/null +++ b/src/Tokenomia/CardanoApi/Value.hs @@ -0,0 +1,16 @@ +module Tokenomia.CardanoApi.Value + ( unLovelace + , unQuantity + ) where + +import Cardano.Api + ( Lovelace(..) + , Quantity(..) + ) + + +unLovelace :: Lovelace -> Integer +unLovelace (Lovelace l) = l + +unQuantity :: Quantity -> Integer +unQuantity (Quantity l) = l diff --git a/src/Tokenomia/Common/Arbitrary/AssetClass.hs b/src/Tokenomia/Common/Arbitrary/AssetClass.hs index 00325aef..9db8acfe 100644 --- a/src/Tokenomia/Common/Arbitrary/AssetClass.hs +++ b/src/Tokenomia/Common/Arbitrary/AssetClass.hs @@ -1,12 +1,19 @@ -{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Tokenomia.Common.Arbitrary.AssetClass () where +import Data.String ( fromString ) +import Plutus.V1.Ledger.Ada ( adaSymbol, adaToken ) import Plutus.V1.Ledger.Value ( AssetClass(..) , CurrencySymbol (..) , TokenName (..) + , assetClass ) import Test.Tasty.QuickCheck @@ -14,10 +21,14 @@ import Test.Tasty.QuickCheck , CoArbitrary , Function , arbitrary + , frequency + , resize , shrink ) -import Tokenomia.Common.Arbitrary.Builtins () +import Tokenomia.Common.AssetClass ( adaAssetClass ) +import Tokenomia.Common.Arbitrary.Builtins ( vectorOfHexBytes ) +import Tokenomia.Common.Arbitrary.Modifiers ( Restricted(..) ) instance Arbitrary CurrencySymbol where @@ -39,3 +50,37 @@ instance CoArbitrary AssetClass instance Function CurrencySymbol instance Function TokenName instance Function AssetClass + +instance Arbitrary (Restricted CurrencySymbol) where + arbitrary = frequency + [ (3, pure $ Restricted adaSymbol) + , (1, Restricted . fromString <$> vectorOfHexBytes 28) + ] + shrink (Restricted x) + | x == adaSymbol = [] + | otherwise = [Restricted adaSymbol] + +instance Arbitrary (Restricted TokenName) where + arbitrary = Restricted . TokenName <$> resize 32 arbitrary + shrink x = Restricted . TokenName <$> shrink (unTokenName . getRestricted $ x) + +instance Arbitrary (Restricted AssetClass) where + arbitrary = + do + Restricted currencySymbol <- arbitrary + Restricted tokenName <- arbitrary + pure . Restricted $ + if currencySymbol == adaSymbol + then assetClass adaSymbol adaToken + else assetClass currencySymbol tokenName + shrink (Restricted (AssetClass (currencySymbol, tokenName))) + | currencySymbol == adaSymbol = [] + | otherwise = + let shrinkedTokenNames = getRestricted <$> shrink (Restricted tokenName) + shrinks = adaAssetClass : (assetClass currencySymbol <$> shrinkedTokenNames) + in + Restricted <$> shrinks + +deriving newtype instance Ord (Restricted CurrencySymbol) +deriving newtype instance Ord (Restricted TokenName) +deriving newtype instance Ord (Restricted AssetClass) diff --git a/src/Tokenomia/Common/Arbitrary/Builtins.hs b/src/Tokenomia/Common/Arbitrary/Builtins.hs index 62b8bf3d..c016599d 100644 --- a/src/Tokenomia/Common/Arbitrary/Builtins.hs +++ b/src/Tokenomia/Common/Arbitrary/Builtins.hs @@ -1,27 +1,65 @@ -{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Tokenomia.Common.Arbitrary.Builtins - () where + ( Hex(..) + , fromHexString + , toHexString + , vectorOfHexBytes + ) where -import PlutusTx.Builtins.Internal - ( BuiltinByteString(..) ) + +import Data.List.Split ( chunksOf ) + +import PlutusTx.Builtins.Internal ( BuiltinByteString(..) ) + +import Tokenomia.Common.Arbitrary.Utils ( shrinkListStructure ) +import Tokenomia.Common.Data.Convertible ( convert ) +import Tokenomia.Common.Data.ByteString ( unsafeDecodeHex, encode ) import Test.QuickCheck.Instances.ByteString () import Test.Tasty.QuickCheck ( Arbitrary , CoArbitrary , Function + , Gen , arbitrary - , resize + , elements + , listOf , shrink + , vectorOf ) +newtype Hex a + = Hex { unHex :: a } + deriving stock ( Show, Eq ) + +instance Arbitrary (Hex String) where + arbitrary = + Hex . concat <$> listOf (vectorOf 2 arbitraryHexSymbol) + + shrink (Hex xs) = + Hex . concat <$> shrinkListStructure (chunksOf 2 xs) + instance Arbitrary BuiltinByteString where - arbitrary = BuiltinByteString <$> resize 64 arbitrary - shrink x - | x == mempty = mempty - | otherwise = pure mempty + arbitrary = fromHexString <$> arbitrary + shrink x = fromHexString <$> shrink (toHexString x) instance CoArbitrary BuiltinByteString instance Function BuiltinByteString + +arbitraryHexSymbol :: Gen Char +arbitraryHexSymbol = elements $ ['0'..'9'] ++ ['a' .. 'f'] + +fromHexString :: Hex String -> BuiltinByteString +fromHexString = convert . unsafeDecodeHex . convert . unHex + +toHexString :: BuiltinByteString -> Hex String +toHexString = Hex . convert . encode . convert + +vectorOfHexBytes :: Int -> Gen String +vectorOfHexBytes n = + vectorOf (2 * n) arbitraryHexSymbol diff --git a/src/Tokenomia/Common/Arbitrary/Utils.hs b/src/Tokenomia/Common/Arbitrary/Utils.hs new file mode 100644 index 00000000..084b13e5 --- /dev/null +++ b/src/Tokenomia/Common/Arbitrary/Utils.hs @@ -0,0 +1,26 @@ +module Tokenomia.Common.Arbitrary.Utils + ( growingFrequency + , inBijection + , isIdentity + , shrinkListStructure + ) where + +import Test.Tasty.QuickCheck ( Gen, frequency, shrinkList ) + +-- | Helper generator to choose element from a list with increasing frequency +growingFrequency :: [a] -> Gen a +growingFrequency xs = frequency $ zip [1..] (pure <$> xs) + +-- | Helper function to test identity property +isIdentity :: Eq a => (a -> a) -> a -> Bool +isIdentity f x = f x == x + +-- | Helper function to test bijection property +inBijection :: (Eq a, Eq b) => (a -> b) -> (b -> a) -> a -> b -> Bool +inBijection f g x y = + isIdentity (f . g) y + && isIdentity (g . f) x + +-- | Shrinks only the list structure but not its elements +shrinkListStructure :: [a] -> [[a]] +shrinkListStructure = shrinkList (const mempty) diff --git a/src/Tokenomia/Common/Arbitrary/Value.hs b/src/Tokenomia/Common/Arbitrary/Value.hs new file mode 100644 index 00000000..0e9f0820 --- /dev/null +++ b/src/Tokenomia/Common/Arbitrary/Value.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Tokenomia.Common.Arbitrary.Value + ( Restricted(..) + ) where + +import Data.Functor.Syntax ( (<$$>) ) +import Data.Set qualified as Set ( toList ) + +import Plutus.V1.Ledger.Value + ( AssetClass(..) + , Value(..) + , assetClassValue + ) + +import Test.Tasty.QuickCheck + ( Arbitrary + , Gen + , arbitrary + , getPositive + ) + +import Tokenomia.Common.Arbitrary.Modifiers ( Restricted(..) ) +import Tokenomia.Common.Arbitrary.AssetClass () + + +instance Arbitrary (Restricted Value) where + arbitrary = + Restricted . mconcat + <$> uncurry assetClassValue <$$> gen + where + gen :: Gen [(AssetClass, Integer)] + gen = + zip + <$> (getRestricted <$$> Set.toList <$> arbitrary) + <*> (getPositive <$$> arbitrary) diff --git a/src/Tokenomia/Common/Data/ByteString.hs b/src/Tokenomia/Common/Data/ByteString.hs index a30883e9..54a79c7a 100644 --- a/src/Tokenomia/Common/Data/ByteString.hs +++ b/src/Tokenomia/Common/Data/ByteString.hs @@ -2,11 +2,12 @@ module Tokenomia.Common.Data.ByteString ( unsafeDecodeHex + , encode ) where -import Data.ByteString ( ByteString ) -import Data.ByteString.Base16 qualified as Base16 ( decode ) +import Data.ByteString ( ByteString ) +import Data.ByteString.Base16 ( decode, encode ) unsafeDecodeHex :: ByteString -> ByteString -unsafeDecodeHex bs = either error id $ Base16.decode bs +unsafeDecodeHex bs = either error id $ decode bs diff --git a/src/Tokenomia/Common/Data/Either/Extra.hs b/src/Tokenomia/Common/Data/Either/Extra.hs new file mode 100644 index 00000000..75a67582 --- /dev/null +++ b/src/Tokenomia/Common/Data/Either/Extra.hs @@ -0,0 +1,10 @@ +module Tokenomia.Common.Data.Either.Extra + ( toEither + ) where + +import Control.Monad ( guard ) +import Data.Either.Combinators ( maybeToRight ) + +-- | Constructs a Right if the boolean is True +toEither :: Bool -> e -> a -> Either e a +toEither b e a = maybeToRight e (guard b >> pure a) diff --git a/src/Tokenomia/Vesting/GenerateNative.hs b/src/Tokenomia/Vesting/GenerateNative.hs index d69fead1..1c035719 100644 --- a/src/Tokenomia/Vesting/GenerateNative.hs +++ b/src/Tokenomia/Vesting/GenerateNative.hs @@ -22,6 +22,7 @@ module Tokenomia.Vesting.GenerateNative , PrivateSaleTranche(..) , TrancheProperties(..) , TranchesProportions(..) + , calculateDefaultMinimumUTxOFromAssetClass , generatePrivateSaleFiles , getNetworkId , investorAddressPubKeyHash @@ -47,7 +48,7 @@ import Control.Monad.Except ( MonadError, liftEither ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import Control.Monad.Reader ( MonadReader, asks ) import Data.Bifunctor ( first ) -import Data.Either.Combinators ( maybeToRight ) +import Data.Either.Combinators ( fromRight, maybeToRight ) import Data.Foldable ( traverse_ ) import Data.Functor.Syntax ( (<$$>) ) import Data.Kind ( Type ) @@ -83,7 +84,9 @@ import Data.Aeson ) import Cardano.Api - ( PaymentCredential(PaymentCredentialByScript) + ( NetworkMagic(..) + , PaymentCredential(PaymentCredentialByScript) + , ShelleyBasedEra(..) , Script(SimpleScript) , SimpleScript ( RequireAllOf @@ -97,17 +100,21 @@ import Cardano.Api , hashScript , makeShelleyAddress , serialiseToBech32 - , NetworkMagic(..) ) -import qualified Cardano.Api as Api ( NetworkId(..) ) +import Cardano.Api qualified + as Api ( NetworkId(..) ) +import Tokenomia.CardanoApi.Fees ( calculateDefaultMinimumUTxOFromAssetId ) import Tokenomia.Common.Aeson.AssetClass ( assetClassToJSON ) import Tokenomia.Common.Data.List.Extra ( mapLastWith, transpose ) import Tokenomia.Common.Environment ( Environment(..) ) import Tokenomia.Common.Error ( TokenomiaError(InvalidPrivateSale, MalformedAddress) ) import Tokenomia.Common.Time ( posixTimeToEnclosingSlotNo , toNextBeginPOSIXTime ) +import Tokenomia.CardanoApi.FromPlutus.Value + ( assetClassAsAssetId ) + import Tokenomia.TokenDistribution.Parser.Address ( deserialiseCardanoAddress ) @@ -283,13 +290,24 @@ validatePrivateSale :: => PrivateSale -> m () validatePrivateSale PrivateSale{..} = let proportions = TranchesProportions $ proportion <$> tranchesProperties - ε = 10 in liftEither $ do + ε <- calculateDefaultMinimumUTxOFromAssetClass assetClass validateTranchesProportions proportions validateAllocations ε proportions $ NEMap.elems allocationByAddress traverse_ (unsafeDeserialiseCardanoAddress . unInvestorAddress) $ NEMap.keys allocationByAddress +-- | Calculate mininum UTxO from a Plutus AssetClass +calculateDefaultMinimumUTxOFromAssetClass :: AssetClass -> Either TokenomiaError Natural +calculateDefaultMinimumUTxOFromAssetClass assetClass = + do + assetId <- first + (InvalidPrivateSale . show) + (assetClassAsAssetId assetClass) + naturalFromInteger <$> maybeToRight + (InvalidPrivateSale "Could not calculate minimum UTxO") + (calculateDefaultMinimumUTxOFromAssetId ShelleyBasedEraAlonzo assetId) + -- | Preconditions on tranches proportions validateTranchesProportions :: TranchesProportions -> Either TokenomiaError () validateTranchesProportions (TranchesProportions proportions) = do diff --git a/test/Spec.hs b/test/Spec.hs index 9dd747b0..a5280ddc 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,6 +3,10 @@ module Main(main) where import qualified Spec.Tokenomia.Vesting.GenerateNative +import qualified Spec.Tokenomia.CardanoApi.FromPlutus.Value +import qualified Spec.Tokenomia.CardanoApi.Fees +import qualified Spec.Tokenomia.Common.Arbitrary.Builtins +import qualified Spec.Tokenomia.Common.Arbitrary.Utils import qualified Spec.Tokenomia.Common.Data.List.Extra import qualified Spec.Tokenomia.Common.Time import qualified Spec.Tokenomia.Wallet.UTxO @@ -25,6 +29,10 @@ tests = testGroup "use cases" , Spec.Tokenomia.ICO.Funds.Validation.Investor.Plan.tests , Spec.Tokenomia.ICO.Funds.Validation.CardanoCLI.Plan.tests , Spec.Tokenomia.Vesting.Sendings.tests + , Spec.Tokenomia.CardanoApi.Fees.tests + , Spec.Tokenomia.CardanoApi.FromPlutus.Value.tests + , Spec.Tokenomia.Common.Arbitrary.Builtins.tests + , Spec.Tokenomia.Common.Arbitrary.Utils.tests , Spec.Tokenomia.Common.Data.List.Extra.tests , Spec.Tokenomia.Common.Parser.Address.tests , Spec.Tokenomia.Common.Time.tests diff --git a/test/Spec/Tokenomia/CardanoApi/Fees.hs b/test/Spec/Tokenomia/CardanoApi/Fees.hs new file mode 100644 index 00000000..dfa28fa3 --- /dev/null +++ b/test/Spec/Tokenomia/CardanoApi/Fees.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} + +module Spec.Tokenomia.CardanoApi.Fees + ( tests + ) where + +import Test.Tasty ( TestTree, testGroup ) +import Test.Tasty.HUnit ( Assertion, testCase, (@?=) ) + +import Cardano.Api + ( AssetId(..) + , AssetName(..) + , Lovelace(..) + , PolicyId(..) + , Quantity + , ShelleyBasedEra(..) + , valueFromList + , lovelaceToValue + ) + +import Tokenomia.CardanoApi.Fees + ( HasDatumHash(..) + , calculateDefaultMinimumUTxOFromValue + , calculateDefaultMinimumUTxOFromAssetId + , utxoEntrySize + ) + + +tests :: TestTree +tests = testGroup "CardanoApi.Fees" [ unitTests ] + +assertUTxOEntrySize :: [(AssetId, Quantity)]-> HasDatumHash -> Integer -> Assertion +assertUTxOEntrySize value hasDatumHash n = + utxoEntrySize (valueFromList value) hasDatumHash @?= n + +assertCalculateDefaultMinimumUTxOFromValue :: [(AssetId, Quantity)] -> HasDatumHash -> Integer -> Assertion +assertCalculateDefaultMinimumUTxOFromValue value hasDatumHash n = + calculateDefaultMinimumUTxOFromValue ShelleyBasedEraAlonzo (valueFromList value) hasDatumHash + @?= Just (lovelaceToValue (Lovelace n)) + +assertCalculateDefaultMinimumUTxOFromAssetId :: AssetId -> Integer -> Assertion +assertCalculateDefaultMinimumUTxOFromAssetId assetId n = + calculateDefaultMinimumUTxOFromAssetId ShelleyBasedEraAlonzo assetId @?= Just n + +unitTests :: TestTree +unitTests = testGroup "Unit tests" + [ testGroup "utxoEntrySize" + [ testCase "NoDatumHash (i)" $ assertUTxOEntrySize + [ (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName ""), 1) ] + NoDatumHash + 38 + , testCase "NoDatumHash (ii)" $ assertUTxOEntrySize + [ (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName "1"), 1) ] + NoDatumHash + 39 + , testCase "NoDatumHash (iii)" $ assertUTxOEntrySize + [ (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName "1"), 1) + , (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName "2"), 2) + , (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName "3"), 3) + ] + NoDatumHash + 42 + , testCase "NoDatumHash (iv)" $ assertUTxOEntrySize + [ (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName ""), 1) + , (AssetId (PolicyId "3ccd653511eec65bbd30c3489f53471b017c829bd97d3a2ae81fb818") (AssetName ""), 2) + ] + NoDatumHash + 43 + , testCase "NoDatumHash (v)" $ assertUTxOEntrySize + [ (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName "1"), 1) + , (AssetId (PolicyId "3ccd653511eec65bbd30c3489f53471b017c829bd97d3a2ae81fb818") (AssetName "2"), 2) + ] + NoDatumHash + 44 + , testCase "WithDatumHash (i)" $ assertUTxOEntrySize + [ (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName ""), 1) ] + WithDatumHash + 48 + , testCase "WithDatumHash (ii)" $ assertUTxOEntrySize + [ (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName "32 32 32 32 32 32 32 32 32 32 32"), 1) + , (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName "2 32 32 32 32 32 32 32 32 32 323"), 2) + , (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName " 32 32 32 32 32 32 32 32 32 3232"), 3) + ] + WithDatumHash + 63 + , testCase "WithDatumHash (iii)" $ assertUTxOEntrySize + [ (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName ""), 1) + , (AssetId (PolicyId "3ccd653511eec65bbd30c3489f53471b017c829bd97d3a2ae81fb818") (AssetName ""), 2) + ] + WithDatumHash + 53 + ] + , testGroup "calculateDefaultMinimumUTxOFromValue" + [ testCase "NoDatumHash (i)" $ assertCalculateDefaultMinimumUTxOFromValue + [ (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName ""), 1) ] + NoDatumHash + 1310316 + , testCase "NoDatumHash (ii)" $ assertCalculateDefaultMinimumUTxOFromValue + [ (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName "1"), 1) ] + NoDatumHash + 1344798 + , testCase "NoDatumHash (iii)" $ assertCalculateDefaultMinimumUTxOFromValue + [ (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName "1"), 1) + , (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName "2"), 2) + , (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName "3"), 3) + ] + NoDatumHash + 1448244 + , testCase "NoDatumHash (iv)" $ assertCalculateDefaultMinimumUTxOFromValue + [ (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName ""), 1) + , (AssetId (PolicyId "3ccd653511eec65bbd30c3489f53471b017c829bd97d3a2ae81fb818") (AssetName ""), 2) + ] + NoDatumHash + 1482726 + , testCase "NoDatumHash (v)" $ assertCalculateDefaultMinimumUTxOFromValue + [ (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName "1"), 1) + , (AssetId (PolicyId "3ccd653511eec65bbd30c3489f53471b017c829bd97d3a2ae81fb818") (AssetName "2"), 2) + ] + NoDatumHash + 1517208 + , testCase "WithDatumHash (i)" $ assertCalculateDefaultMinimumUTxOFromValue + [ (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName ""), 1) ] + WithDatumHash + 1655136 + , testCase "WithDatumHash (ii)" $ assertCalculateDefaultMinimumUTxOFromValue + [ (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName "32 32 32 32 32 32 32 32 32 32 32"), 1) + , (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName "2 32 32 32 32 32 32 32 32 32 323"), 2) + , (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName " 32 32 32 32 32 32 32 32 32 3232"), 3) + ] + WithDatumHash + 2172366 + , testCase "WithDatumHash (iii)" $ assertCalculateDefaultMinimumUTxOFromValue + [ (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName ""), 1) + , (AssetId (PolicyId "3ccd653511eec65bbd30c3489f53471b017c829bd97d3a2ae81fb818") (AssetName ""), 2) + ] + WithDatumHash + 1827546 + ] + , testGroup "calculateDefaultMinimumUTxOFromAssetId" + [ testCase "NoDatumHash (i)" $ assertCalculateDefaultMinimumUTxOFromAssetId + (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName "")) + 1310316 + , testCase "NoDatumHash (ii)" $ assertCalculateDefaultMinimumUTxOFromAssetId + (AssetId (PolicyId "1d6445ddeda578117f393848e685128f1e78ad0c4e48129c5964dc2e") (AssetName "1")) + 1344798 + ] + ] diff --git a/test/Spec/Tokenomia/CardanoApi/FromPlutus/Value.hs b/test/Spec/Tokenomia/CardanoApi/FromPlutus/Value.hs new file mode 100644 index 00000000..f7d1d4a2 --- /dev/null +++ b/test/Spec/Tokenomia/CardanoApi/FromPlutus/Value.hs @@ -0,0 +1,69 @@ +module Spec.Tokenomia.CardanoApi.FromPlutus.Value + ( tests + ) where + +import Data.Either ( isRight ) + +import Plutus.V1.Ledger.Ada ( adaSymbol ) +import Plutus.V1.Ledger.Value ( CurrencySymbol(..) ) + +import Test.Tasty.QuickCheck ( testProperty, shrink ) +import Test.Tasty ( TestTree, testGroup ) + +import Tokenomia.Common.Arbitrary.AssetClass() +import Tokenomia.Common.Arbitrary.Builtins () +import Tokenomia.Common.Arbitrary.Modifiers ( Restricted(..) ) +import Tokenomia.Common.Arbitrary.Value () + +import Tokenomia.CardanoApi.FromPlutus.Value + ( assetClassAsAssetId + , currencySymbolAsPolicyId + , tokenNameAsAssetName + , fromPlutusValue + ) + + +tests :: TestTree +tests = testGroup "CardanoApi.FromPlutus.Value" [ properties ] + +validCurrencySymbolAsPolicyId :: CurrencySymbol -> Bool +validCurrencySymbolAsPolicyId x = + x == adaSymbol || isRight (currencySymbolAsPolicyId x) + +propertiesCurrencySymbolAsPolicyId :: [TestTree] +propertiesCurrencySymbolAsPolicyId = + [ testProperty "currencySymbolAsPolicyId on arbitrary" $ + validCurrencySymbolAsPolicyId . getRestricted + , testProperty "currencySymbolAsPolicyId on shrinks" $ + \x -> and $ validCurrencySymbolAsPolicyId . getRestricted <$> shrink x + ] + +propertiesTokenNameAsAssetName :: [TestTree] +propertiesTokenNameAsAssetName = + [ testProperty "tokenNameAsAssetName on arbitrary" $ + isRight . tokenNameAsAssetName . getRestricted + , testProperty "tokenNameAsAssetName on shrinks" $ + \x -> and $ isRight . tokenNameAsAssetName . getRestricted <$> shrink x + ] + +propertiesAssetClassAsAssetId :: [TestTree] +propertiesAssetClassAsAssetId = + [ testProperty "assetClassAsAssetId on arbitrary" $ + isRight . assetClassAsAssetId . getRestricted + , testProperty "assetClassAsAssetId on shrinks" $ + \x -> and $ isRight . assetClassAsAssetId . getRestricted <$> shrink x + ] + +propertiesFromPlutusValue :: [TestTree] +propertiesFromPlutusValue = + [ testProperty "fromPlutusValue on arbitrary" $ + isRight . fromPlutusValue . getRestricted + ] + +properties :: TestTree +properties = testGroup "Properties" + [ testGroup "currencySymbolAsPolicyId" propertiesCurrencySymbolAsPolicyId + , testGroup "tokenNameAsAssetName" propertiesTokenNameAsAssetName + , testGroup "assetClassAsAssetId" propertiesAssetClassAsAssetId + , testGroup "fromPlutusValue" propertiesFromPlutusValue + ] diff --git a/test/Spec/Tokenomia/Common/Arbitrary/Builtins.hs b/test/Spec/Tokenomia/Common/Arbitrary/Builtins.hs new file mode 100644 index 00000000..0c8f182c --- /dev/null +++ b/test/Spec/Tokenomia/Common/Arbitrary/Builtins.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Spec.Tokenomia.Common.Arbitrary.Builtins + ( tests + ) where + +import Data.ByteString qualified + as ByteString ( length ) +import PlutusTx.Builtins.Internal ( BuiltinByteString(..) ) + +import Test.Tasty.QuickCheck ( testProperty, getSize, shrink ) +import Test.Tasty ( TestTree, testGroup ) + +import Test.QuickCheck.Modifiers ( Positive(..) ) + +import Tokenomia.Common.Data.Convertible ( convert ) +import Tokenomia.Common.Data.ByteString ( encode ) +import Tokenomia.Common.Arbitrary.Utils ( inBijection ) +import Tokenomia.Common.Arbitrary.Builtins + ( Hex(..) + , vectorOfHexBytes + , fromHexString + , toHexString + ) + + +tests :: TestTree +tests = testGroup "Common.Arbitrary.Builtins" [ properties ] + +builtinByteStringLength :: BuiltinByteString -> Int +builtinByteStringLength = ByteString.length . encode . convert + +propertiesHexString :: [TestTree] +propertiesHexString = + [ testProperty "vectorOfHexBytes length" + ( \(Positive n) -> + do + xs <- vectorOfHexBytes n + pure $ 2 * n == length xs + ) + , testProperty "arbitrary length" + ( \(xs :: Hex String) -> + do + n <- getSize + pure $ 2 * n >= (length .unHex $ xs) + ) + , testProperty "all shrinks length" + ( \(xs :: Hex String) -> + let shrinksLength = length . unHex <$> shrink xs + in + do + n <- getSize + pure $ all (2 * (n - 1) >=) shrinksLength + ) + ] + +propertiesBuiltinByteString :: [TestTree] +propertiesBuiltinByteString = + [ testProperty "inBijection fromHexString toHexString" $ + inBijection fromHexString toHexString + , testProperty "arbitrary length" + ( \(xs :: BuiltinByteString) -> + do + n <- getSize + pure $ 2 * n >= builtinByteStringLength xs + ) + , testProperty "all shrinks length" + ( \(xs :: BuiltinByteString) -> + let shrinksLength = builtinByteStringLength <$> shrink xs + in + do + n <- getSize + pure $ all (2 * n >=) shrinksLength + ) + ] + +properties :: TestTree +properties = testGroup "Properties" + [ testGroup "HexString" propertiesHexString + , testGroup "BuiltinByteString" propertiesBuiltinByteString + ] diff --git a/test/Spec/Tokenomia/Common/Arbitrary/Utils.hs b/test/Spec/Tokenomia/Common/Arbitrary/Utils.hs new file mode 100644 index 00000000..8adbd725 --- /dev/null +++ b/test/Spec/Tokenomia/Common/Arbitrary/Utils.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Spec.Tokenomia.Common.Arbitrary.Utils + ( tests + ) where + +import Data.Char ( toUpper, toLower ) +import Test.Tasty.QuickCheck ( testProperty, expectFailure ) +import Test.Tasty ( TestTree, testGroup ) + +import Tokenomia.Common.Arbitrary.Utils ( isIdentity, inBijection ) + + +tests :: TestTree +tests = testGroup "Common.Arbitrary.Utils" [ properties ] + +propertiesIsIdentity :: [TestTree] +propertiesIsIdentity = + [ testProperty "id isIdentity" $ + isIdentity @Integer id + ] + +propertiesInBijection :: [TestTree] +propertiesInBijection = + [ testProperty "inBijection id id" $ + inBijection @Integer id id + , testProperty "inBijection (+1) (-1)" $ + inBijection @Integer (+1) (subtract 1) + , testProperty "not inBijection toUpper toLower" $ + expectFailure $ inBijection toUpper toLower + ] + +properties :: TestTree +properties = testGroup "Properties" + [ testGroup "isIdentity" propertiesIsIdentity + , testGroup "inBijection" propertiesInBijection + ] diff --git a/test/Spec/Tokenomia/Vesting/GenerateNative.hs b/test/Spec/Tokenomia/Vesting/GenerateNative.hs index 6676f474..6d6a2623 100644 --- a/test/Spec/Tokenomia/Vesting/GenerateNative.hs +++ b/test/Spec/Tokenomia/Vesting/GenerateNative.hs @@ -75,6 +75,7 @@ import Tokenomia.Vesting.GenerateNative , PrivateSaleTranche(..) , TrancheProperties(..) , TranchesProportions(..) + , calculateDefaultMinimumUTxOFromAssetClass , investorAddressPubKeyHash , merge , minAllocation @@ -199,11 +200,11 @@ instance Arbitrary (Restricted PrivateSale) where arbitrary = do tranchesProperties <- getRestricted <$> arbitrary - assetClass <- arbitrary + Restricted assetClass <- arbitrary allocationByAddress <- scale (*7) arbitrary let proportions = TranchesProportions $ proportion <$> tranchesProperties - ε = 10 + ε = fromRight' $ calculateDefaultMinimumUTxOFromAssetClass assetClass µ = minAllocation ε proportions pure $ @@ -212,9 +213,8 @@ instance Arbitrary (Restricted PrivateSale) where assetClass ((+ µ) <$> allocationByAddress) shrink (Restricted PrivateSale{..}) = - let shrinkedProperties = - getRestricted <$> shrink' (Restricted tranchesProperties) - shrinkedAssetClass = shrink' assetClass + let shrinkedProperties = getRestricted <$> shrink' (Restricted tranchesProperties) + shrinkedAssetClass = getRestricted <$> shrink' (Restricted assetClass) shrinkedAllocationByAddress = shrink' allocationByAddress shrinkedPrivateSale = @@ -232,7 +232,7 @@ instance Arbitrary (Restricted PrivateSale) where validPrivateSaleAllocations :: PrivateSale -> Bool validPrivateSaleAllocations PrivateSale{..} = let proportions = TranchesProportions $ proportion <$> tranchesProperties - ε = 10 + ε = fromRight' $ calculateDefaultMinimumUTxOFromAssetClass assetClass in isRight $ validateAllocations ε proportions $ NEMap.elems allocationByAddress diff --git a/tokenomia.cabal b/tokenomia.cabal index dc2cc2d5..80c8da8f 100644 --- a/tokenomia.cabal +++ b/tokenomia.cabal @@ -72,12 +72,19 @@ library Tokenomia.Vesting.Retrieve Tokenomia.Vesting.Sendings Tokenomia.Tokenomic.CLAP.Simulation + Tokenomia.CardanoApi.FromPlutus.Error + Tokenomia.CardanoApi.FromPlutus.Value + Tokenomia.CardanoApi.Fees + Tokenomia.CardanoApi.PParams + Tokenomia.CardanoApi.Value Tokenomia.Common.Aeson.AssetClass Tokenomia.Common.Arbitrary.AssetClass Tokenomia.Common.Arbitrary.Builtins Tokenomia.Common.Arbitrary.Modifiers Tokenomia.Common.Arbitrary.POSIXTime Tokenomia.Common.Arbitrary.Slot + Tokenomia.Common.Arbitrary.Utils + Tokenomia.Common.Arbitrary.Value Tokenomia.Common.Arbitrary.Wallet Tokenomia.Common.AssetClass Tokenomia.Common.Blockfrost @@ -98,6 +105,7 @@ library Tokenomia.Common.PageNumber Tokenomia.Common.Data.ByteString Tokenomia.Common.Data.Convertible + Tokenomia.Common.Data.Either.Extra Tokenomia.Common.Data.List.Extra Tokenomia.Common.Data.List.NonEmpty Tokenomia.Common.Parser @@ -186,8 +194,10 @@ library containers, cardano-api, cardano-cli, + cardano-ledger-core, cardano-ledger-alonzo, cardano-ledger-byron, + cardano-ledger-shelley, plutus-ledger-api, serialise, freer-extras, @@ -224,7 +234,11 @@ test-suite tokenomia-tests main-is: Spec.hs hs-source-dirs: test other-modules: + Spec.Tokenomia.CardanoApi.FromPlutus.Value + Spec.Tokenomia.CardanoApi.Fees Spec.Tokenomia.Vesting.GenerateNative + Spec.Tokenomia.Common.Arbitrary.Builtins + Spec.Tokenomia.Common.Arbitrary.Utils Spec.Tokenomia.Common.Data.List.Extra Spec.Tokenomia.Common.Parser.Address Spec.Tokenomia.Common.Time @@ -269,6 +283,7 @@ test-suite tokenomia-tests either, composition-extra, hex, + cardano-api, data-default From 0ac9298921bf23f63778e5f47bbdc9180516f16a Mon Sep 17 00:00:00 2001 From: Charles Augu Date: Wed, 14 Sep 2022 15:03:21 +0200 Subject: [PATCH 03/15] add preprod in network options --- src/Tokenomia/CLI.hs | 6 +++++- src/Tokenomia/Common/Environment.hs | 15 +++++++++++++++ 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/src/Tokenomia/CLI.hs b/src/Tokenomia/CLI.hs index 9cdd1cc9..7d7fb3b0 100644 --- a/src/Tokenomia/CLI.hs +++ b/src/Tokenomia/CLI.hs @@ -75,6 +75,7 @@ selectNetwork = do environment <- liftIO $ askMenu networks >>= \case SelectTestnet -> getTestnetEnvironmment 1097911063 SelectMainnet -> getMainnetEnvironmment 764824073 + SelectPreprod -> getPreprodEnvironmment 1 clearConsole result :: Either TokenomiaError () <- runExceptT $ runReaderT recursiveMenu environment case result of @@ -86,17 +87,20 @@ selectNetwork = do networks :: NonEmpty SelectEnvironment networks = NonEmpty.fromList [ SelectTestnet, - SelectMainnet + SelectMainnet, + SelectPreprod ] data SelectEnvironment = SelectTestnet | SelectMainnet + | SelectPreprod instance DisplayMenuItem SelectEnvironment where displayMenuItem item = case item of SelectTestnet -> "Testnet (magicNumber 1097911063)" SelectMainnet -> "Mainnet (magicNumber 764824073)" + SelectPreprod -> "Preprod (magicNumber 1)" recursiveMenu diff --git a/src/Tokenomia/Common/Environment.hs b/src/Tokenomia/Common/Environment.hs index 6331f0f5..28ad1af1 100644 --- a/src/Tokenomia/Common/Environment.hs +++ b/src/Tokenomia/Common/Environment.hs @@ -7,6 +7,7 @@ module Tokenomia.Common.Environment ( getTestnetEnvironmment , getMainnetEnvironmment + , getPreprodEnvironmment , getNetworkEnvironmment , readNetworkMagic , Environment (..) @@ -80,6 +81,20 @@ getMainnetEnvironmment magicNumber = do return $ Mainnet {..} +getPreprodEnvironmment :: MonadIO m => Integer -> m Environment +getPreprodEnvironmment magicNumber = do + socketPath <- liftIO $ getEnv "CARDANO_NODE_SOCKET_PATH" + let localNodeConnectInfo = LocalNodeConnectInfo { + localConsensusModeParams = CardanoModeParams (EpochSlots 21600), + localNodeNetworkId = Shelley.Testnet (NetworkMagic (fromIntegral magicNumber)), + localNodeSocketPath = socketPath} + preShelleyEpochs = 208 + byronSlotsPerEpoch = 21600 + byronSecondsPerSlot = 20 + systemStart <- ExternalPosix.utcTimeToPOSIXSeconds . coerce <$> getSystemStart' localNodeConnectInfo + + return $ Testnet {..} + getTestnetEnvironmment :: MonadIO m => Integer -> m Environment getTestnetEnvironmment magicNumber = do socketPath <- liftIO $ getEnv "CARDANO_NODE_SOCKET_PATH" From b75135370031681d8d6c0bb8a814760a950e41b0 Mon Sep 17 00:00:00 2001 From: devfull <26844641+devfull@users.noreply.github.com> Date: Mon, 3 Oct 2022 17:23:20 +0200 Subject: [PATCH 04/15] [network] add a local state query module --- src/Tokenomia/CardanoApi/Query.hs | 205 ++++++++++++++++++++++++++++++ tokenomia.cabal | 4 + 2 files changed, 209 insertions(+) create mode 100644 src/Tokenomia/CardanoApi/Query.hs diff --git a/src/Tokenomia/CardanoApi/Query.hs b/src/Tokenomia/CardanoApi/Query.hs new file mode 100644 index 00000000..c1d54d09 --- /dev/null +++ b/src/Tokenomia/CardanoApi/Query.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE TypeFamilies #-} + +module Tokenomia.CardanoApi.Query + ( QueryFailure(..) + , queryCurrentEra + , queryWallclockToSlot + , queryWallclockToSlot' + , querySlotToWallclock + , querySlotToWallclock' + , queryUTxOByAddress + , queryUTxOByTxIn + , queryGenesisParameters + ) where + +import Control.Monad ( join ) +import Control.Monad.Reader ( MonadIO(..) ) +import Control.Monad.Trans.Except ( ExceptT ) +import Control.Monad.Trans.Except.Extra ( newExceptT, firstExceptT, secondExceptT ) +import Control.Lens ( (^.), _1 ) + +import Data.Bifunctor ( first ) +import Data.Composition ( (.:) ) +import Data.Set ( Set ) +import Data.Time.Clock ( NominalDiffTime ) + +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( SlotLength, RelativeTime ) +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras + ( EraMismatch ) +import Ouroboros.Consensus.HardFork.History.Qry + ( PastHorizonException + , Qry + , interpretQuery + , slotToWallclock + , wallclockToSlot + ) +import Ouroboros.Network.Protocol.LocalStateQuery.Type + ( AcquireFailure ) + +import Cardano.Api.Shelley + ( AddressAny + , AnyCardanoEra + , CardanoMode + , ConsensusModeIsMultiEra(CardanoModeIsMultiEra) + , EraHistory(..) + , EraInMode(ShelleyEraInCardanoMode) + , GenesisParameters + , LocalNodeConnectInfo + , QueryInEra(QueryInShelleyBasedEra) + , QueryInMode(QueryEraHistory, QueryInEra, QueryCurrentEra) + , QueryInShelleyBasedEra(QueryGenesisParameters, QueryUTxO) + , QueryUTxOFilter(QueryUTxOByTxIn, QueryUTxOByAddress) + , ShelleyBasedEra(ShelleyBasedEraShelley) + , ShelleyEra + , SlotNo + , TxIn + , UTxO + , executeLocalStateQueryExpr + , queryExpr + ) + + +data QueryFailure + = QueryNetworkFailure AcquireFailure + | QueryHistoryFailure PastHorizonException + | QueryEraMismatch EraMismatch + deriving stock ( Show ) + +-- | Return a `Left` value converted into an `ExceptT QueryFailure` +newExceptTQueryFailure :: + ( MonadIO m ) + => (e -> QueryFailure) + -> Either e a + -> ExceptT QueryFailure m a +newExceptTQueryFailure = + newExceptT . pure .: first + +-- | Join the result of an `executeQueryExpr` that is returning an `Either` +joinQueryFailures :: + ( MonadIO m ) + => (e -> QueryFailure) + -> ExceptT QueryFailure m (Either e a) + -> ExceptT QueryFailure m a +joinQueryFailures = + join .: secondExceptT . newExceptTQueryFailure + +-- | Execute simple query expressions +executeQueryExpr :: + ( MonadIO m ) + => QueryInMode mode a + -> LocalNodeConnectInfo mode + -> ExceptT QueryFailure m a +executeQueryExpr query info = + firstExceptT QueryNetworkFailure . newExceptT <$> liftIO $ + executeLocalStateQueryExpr info Nothing (\_ -> queryExpr query) + +-- | Execute query expressions in shelley based era +executeQueryExprInShelleyBasedEra :: + ( MonadIO m ) + => QueryInShelleyBasedEra ShelleyEra a + -> LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m a +executeQueryExprInShelleyBasedEra = + joinQueryFailures QueryEraMismatch .: + executeQueryExpr . + QueryInEra ShelleyEraInCardanoMode . + QueryInShelleyBasedEra ShelleyBasedEraShelley + +-- | Query the era of the tip +queryCurrentEra :: + ( MonadIO m ) + => LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m AnyCardanoEra +queryCurrentEra = executeQueryExpr $ QueryCurrentEra CardanoModeIsMultiEra + +-- | Query the history needed to interpret hardfork query +queryEraHistory :: + ( MonadIO m ) + => LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m (EraHistory CardanoMode) +queryEraHistory = executeQueryExpr $ QueryEraHistory CardanoModeIsMultiEra + +-- | Interpret a query with respect to the hardfork history +interpretQueryHistory :: + ( MonadIO m ) + => Qry a + -> LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m a +interpretQueryHistory query info = + do + EraHistory _ interpreter <- queryEraHistory info + newExceptTQueryFailure QueryHistoryFailure $ + interpretQuery interpreter query + +-- | Convert a time to its enclosing slot, with time spent and time left in this slot +queryWallclockToSlot :: + ( MonadIO m ) + => RelativeTime + -> LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m (SlotNo, NominalDiffTime, NominalDiffTime) +queryWallclockToSlot = + interpretQueryHistory . wallclockToSlot + +-- | Convert a time to its enclosing slot +queryWallclockToSlot' :: + ( MonadIO m ) + => RelativeTime + -> LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m SlotNo +queryWallclockToSlot' = + secondExceptT (^._1) .: queryWallclockToSlot + +-- | Convert a slot to its begin time, with the slot length +querySlotToWallclock :: + ( MonadIO m ) + => SlotNo + -> LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m (RelativeTime, SlotLength) +querySlotToWallclock = + interpretQueryHistory . slotToWallclock + +-- | Convert a slot to its begin time +querySlotToWallclock' :: + ( MonadIO m ) + => SlotNo + -> LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m RelativeTime +querySlotToWallclock' = + secondExceptT (^._1) .: querySlotToWallclock + +-- | Query UTxO filtered by addresses +queryUTxOByAddress :: + ( MonadIO m ) + => Set AddressAny + -> LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m (UTxO ShelleyEra) +queryUTxOByAddress = + queryUTxO . QueryUTxOByAddress + +-- | Query UTxO filtered by transaction inputs +queryUTxOByTxIn :: + ( MonadIO m ) + => Set TxIn + -> LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m (UTxO ShelleyEra) +queryUTxOByTxIn = + queryUTxO . QueryUTxOByTxIn + +-- | Query UTxO with a given filter +queryUTxO :: + ( MonadIO m ) + => QueryUTxOFilter + -> LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m (UTxO ShelleyEra) +queryUTxO = + executeQueryExprInShelleyBasedEra . QueryUTxO + +-- | Query the genesis parameters +queryGenesisParameters :: + ( MonadIO m ) + => LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m GenesisParameters +queryGenesisParameters = + executeQueryExprInShelleyBasedEra QueryGenesisParameters diff --git a/tokenomia.cabal b/tokenomia.cabal index 80c8da8f..15684b9e 100644 --- a/tokenomia.cabal +++ b/tokenomia.cabal @@ -76,6 +76,7 @@ library Tokenomia.CardanoApi.FromPlutus.Value Tokenomia.CardanoApi.Fees Tokenomia.CardanoApi.PParams + Tokenomia.CardanoApi.Query Tokenomia.CardanoApi.Value Tokenomia.Common.Aeson.AssetClass Tokenomia.Common.Arbitrary.AssetClass @@ -190,6 +191,7 @@ library iso8601-time, unordered-containers, ouroboros-consensus, + ouroboros-network, bytestring, containers, cardano-api, @@ -198,6 +200,7 @@ library cardano-ledger-alonzo, cardano-ledger-byron, cardano-ledger-shelley, + cardano-slotting, plutus-ledger-api, serialise, freer-extras, @@ -220,6 +223,7 @@ library nonempty-containers, streamly, transformers, + transformers-except, deepseq, hashable, hex, From 0d6a3e39050f3cba7621ff931397a13e22a06996 Mon Sep 17 00:00:00 2001 From: devfull <26844641+devfull@users.noreply.github.com> Date: Tue, 4 Oct 2022 07:14:06 +0200 Subject: [PATCH 05/15] [network] add a query for system start --- src/Tokenomia/CardanoApi/Query.hs | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/src/Tokenomia/CardanoApi/Query.hs b/src/Tokenomia/CardanoApi/Query.hs index c1d54d09..f1c85b52 100644 --- a/src/Tokenomia/CardanoApi/Query.hs +++ b/src/Tokenomia/CardanoApi/Query.hs @@ -4,13 +4,14 @@ module Tokenomia.CardanoApi.Query ( QueryFailure(..) , queryCurrentEra - , queryWallclockToSlot - , queryWallclockToSlot' + , queryGenesisParameters , querySlotToWallclock , querySlotToWallclock' + , querySystemStart , queryUTxOByAddress , queryUTxOByTxIn - , queryGenesisParameters + , queryWallclockToSlot + , queryWallclockToSlot' ) where import Control.Monad ( join ) @@ -25,7 +26,7 @@ import Data.Set ( Set ) import Data.Time.Clock ( NominalDiffTime ) import Ouroboros.Consensus.BlockchainTime.WallClock.Types - ( SlotLength, RelativeTime ) + ( RelativeTime, SlotLength, SystemStart ) import Ouroboros.Consensus.HardFork.Combinator.AcrossEras ( EraMismatch ) import Ouroboros.Consensus.HardFork.History.Qry @@ -48,7 +49,7 @@ import Cardano.Api.Shelley , GenesisParameters , LocalNodeConnectInfo , QueryInEra(QueryInShelleyBasedEra) - , QueryInMode(QueryEraHistory, QueryInEra, QueryCurrentEra) + , QueryInMode(QueryEraHistory, QueryInEra, QueryCurrentEra, QuerySystemStart) , QueryInShelleyBasedEra(QueryGenesisParameters, QueryUTxO) , QueryUTxOFilter(QueryUTxOByTxIn, QueryUTxOByAddress) , ShelleyBasedEra(ShelleyBasedEraShelley) @@ -114,6 +115,13 @@ queryCurrentEra :: -> ExceptT QueryFailure m AnyCardanoEra queryCurrentEra = executeQueryExpr $ QueryCurrentEra CardanoModeIsMultiEra +-- | Query the system start +querySystemStart :: + ( MonadIO m ) + => LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m SystemStart +querySystemStart = executeQueryExpr QuerySystemStart + -- | Query the history needed to interpret hardfork query queryEraHistory :: ( MonadIO m ) From 0a60a263a081b59b412d6f78c78a6eb802d9889c Mon Sep 17 00:00:00 2001 From: devfull <26844641+devfull@users.noreply.github.com> Date: Tue, 4 Oct 2022 11:33:49 +0200 Subject: [PATCH 06/15] [network] add relative to absolute time support --- src/Tokenomia/CardanoApi/Query.hs | 28 ++++++++++++++++++++++++++-- src/Tokenomia/CardanoApi/Time.hs | 23 +++++++++++++++++++++++ tokenomia.cabal | 1 + 3 files changed, 50 insertions(+), 2 deletions(-) create mode 100644 src/Tokenomia/CardanoApi/Time.hs diff --git a/src/Tokenomia/CardanoApi/Query.hs b/src/Tokenomia/CardanoApi/Query.hs index f1c85b52..98a92fa5 100644 --- a/src/Tokenomia/CardanoApi/Query.hs +++ b/src/Tokenomia/CardanoApi/Query.hs @@ -5,6 +5,8 @@ module Tokenomia.CardanoApi.Query ( QueryFailure(..) , queryCurrentEra , queryGenesisParameters + , queryNominalDiffTimeToSlot + , querySlotToNominalDiffTime , querySlotToWallclock , querySlotToWallclock' , querySystemStart @@ -61,6 +63,8 @@ import Cardano.Api.Shelley , queryExpr ) +import Tokenomia.CardanoApi.Time ( nominalDiffTimeToRelativeTime, relativeTimeToNominalDiffTime ) + data QueryFailure = QueryNetworkFailure AcquireFailure @@ -150,7 +154,7 @@ queryWallclockToSlot :: queryWallclockToSlot = interpretQueryHistory . wallclockToSlot --- | Convert a time to its enclosing slot +-- | Convert a relative time to its enclosing slot queryWallclockToSlot' :: ( MonadIO m ) => RelativeTime @@ -159,6 +163,16 @@ queryWallclockToSlot' :: queryWallclockToSlot' = secondExceptT (^._1) .: queryWallclockToSlot +-- | Convert a POSIXTime to its enclosing slot +queryNominalDiffTimeToSlot :: + ( MonadIO m ) + => SystemStart + -> NominalDiffTime + -> LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m SlotNo +queryNominalDiffTimeToSlot = + queryWallclockToSlot' .: nominalDiffTimeToRelativeTime + -- | Convert a slot to its begin time, with the slot length querySlotToWallclock :: ( MonadIO m ) @@ -168,7 +182,7 @@ querySlotToWallclock :: querySlotToWallclock = interpretQueryHistory . slotToWallclock --- | Convert a slot to its begin time +-- | Convert a slot to its begin relative time querySlotToWallclock' :: ( MonadIO m ) => SlotNo @@ -177,6 +191,16 @@ querySlotToWallclock' :: querySlotToWallclock' = secondExceptT (^._1) .: querySlotToWallclock +-- | Convert a slot to its begin POSIXTime +querySlotToNominalDiffTime :: + ( MonadIO m ) + => SystemStart + -> SlotNo + -> LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m NominalDiffTime +querySlotToNominalDiffTime systemStart = + secondExceptT (relativeTimeToNominalDiffTime systemStart) .: querySlotToWallclock' + -- | Query UTxO filtered by addresses queryUTxOByAddress :: ( MonadIO m ) diff --git a/src/Tokenomia/CardanoApi/Time.hs b/src/Tokenomia/CardanoApi/Time.hs new file mode 100644 index 00000000..f584dde7 --- /dev/null +++ b/src/Tokenomia/CardanoApi/Time.hs @@ -0,0 +1,23 @@ +module Tokenomia.CardanoApi.Time + ( nominalDiffTimeToRelativeTime + , relativeTimeToNominalDiffTime + ) where + +import Cardano.Slotting.Time ( SystemStart, fromRelativeTime, toRelativeTime ) +import Data.Time.Clock ( NominalDiffTime ) +import Data.Time.Clock.POSIX ( posixSecondsToUTCTime, utcTimeToPOSIXSeconds ) +import Data.Composition ( (.:) ) + +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( RelativeTime(..) ) + + +-- | Convert a relative time to POSIX time +relativeTimeToNominalDiffTime :: SystemStart -> RelativeTime -> NominalDiffTime +relativeTimeToNominalDiffTime = + utcTimeToPOSIXSeconds .: fromRelativeTime + +-- | Convert a POSIX time to relative time +nominalDiffTimeToRelativeTime :: SystemStart -> NominalDiffTime -> RelativeTime +nominalDiffTimeToRelativeTime systemStart = + toRelativeTime systemStart . posixSecondsToUTCTime diff --git a/tokenomia.cabal b/tokenomia.cabal index 15684b9e..d9ce1b24 100644 --- a/tokenomia.cabal +++ b/tokenomia.cabal @@ -77,6 +77,7 @@ library Tokenomia.CardanoApi.Fees Tokenomia.CardanoApi.PParams Tokenomia.CardanoApi.Query + Tokenomia.CardanoApi.Time Tokenomia.CardanoApi.Value Tokenomia.Common.Aeson.AssetClass Tokenomia.Common.Arbitrary.AssetClass From 2feceb415241edaf0c84a26f01941808399f5ac8 Mon Sep 17 00:00:00 2001 From: devfull <26844641+devfull@users.noreply.github.com> Date: Wed, 5 Oct 2022 11:23:58 +0200 Subject: [PATCH 07/15] [network] enable reading query args from env --- src/Tokenomia/Common/Environment.hs | 5 +- src/Tokenomia/Common/Environment/Query.hs | 61 +++++++++++++++++++++++ tokenomia.cabal | 1 + 3 files changed, 66 insertions(+), 1 deletion(-) create mode 100644 src/Tokenomia/Common/Environment/Query.hs diff --git a/src/Tokenomia/Common/Environment.hs b/src/Tokenomia/Common/Environment.hs index 6331f0f5..0772cd2f 100644 --- a/src/Tokenomia/Common/Environment.hs +++ b/src/Tokenomia/Common/Environment.hs @@ -56,6 +56,7 @@ data Environment = Testnet , preShelleyEpochs :: Integer , byronSlotsPerEpoch :: Integer , byronSecondsPerSlot :: Integer + , systemStart' :: SystemStart , systemStart :: ExternalPosix.POSIXTime } | Mainnet { magicNumber :: Integer @@ -63,6 +64,7 @@ data Environment = Testnet , preShelleyEpochs :: Integer , byronSlotsPerEpoch :: Integer , byronSecondsPerSlot :: Integer + , systemStart' :: SystemStart , systemStart :: ExternalPosix.POSIXTime } @@ -77,6 +79,7 @@ getMainnetEnvironmment magicNumber = do byronSlotsPerEpoch = 21600 byronSecondsPerSlot = 20 systemStart <- ExternalPosix.utcTimeToPOSIXSeconds . coerce <$> getSystemStart' localNodeConnectInfo + systemStart' <- getSystemStart' localNodeConnectInfo return $ Mainnet {..} @@ -91,6 +94,7 @@ getTestnetEnvironmment magicNumber = do byronSlotsPerEpoch = 21600 byronSecondsPerSlot = 20 systemStart <- ExternalPosix.utcTimeToPOSIXSeconds . coerce <$> getSystemStart' localNodeConnectInfo + systemStart' <- getSystemStart' localNodeConnectInfo return $ Testnet {..} @@ -161,4 +165,3 @@ convertToExternalPosix p = ExternalPosix.secondsToNominalDiffTime (fromIntegral formatISO8601 :: ExternalPosix.POSIXTime -> String formatISO8601 = ExternalPosix.formatISO8601 . ExternalPosix.posixSecondsToUTCTime - diff --git a/src/Tokenomia/Common/Environment/Query.hs b/src/Tokenomia/Common/Environment/Query.hs new file mode 100644 index 00000000..6d6b5de8 --- /dev/null +++ b/src/Tokenomia/Common/Environment/Query.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Tokenomia.Common.Environment.Query + ( evalQuery + , evalQueryWithSystemStart + ) where + +import Data.Bifunctor ( first ) +import Data.Kind ( Type ) + +import Control.Monad.Except ( MonadError, liftEither ) +import Control.Monad.Reader ( MonadReader, asks ) +import Control.Monad.Trans.Except ( ExceptT, runExceptT ) + +import Cardano.Api.Shelley ( LocalNodeConnectInfo, CardanoMode ) +import Cardano.Slotting.Time ( SystemStart ) + +import Tokenomia.Common.Environment ( Environment(..) ) + + +-- | Lift an ExceptT into a MonadError +evalExceptT :: + forall (m :: Type -> Type) (a :: Type) (b :: Type) (e :: Type). + ( MonadError e m ) + => (a -> e) + -> ExceptT a m b + -> m b +evalExceptT err x = + runExceptT x >>= liftEither . first err + +-- | Run a query that can fail in a MonadError, with a LocalNodeConnectInfo argument +evalQuery :: + forall (m :: Type -> Type) (a :: Type) (b :: Type) (c :: Type) (e :: Type). + ( MonadError e m + , MonadReader Environment m + ) + => (a -> e) + -> (c -> LocalNodeConnectInfo CardanoMode -> ExceptT a m b) + -> c + -> m b +evalQuery err query args = + asks localNodeConnectInfo + >>= evalExceptT err . query args + +-- | Run a query that can fail in a MonadError, with an additional SystemStart argument +evalQueryWithSystemStart :: + forall (m :: Type -> Type) (a :: Type) (b :: Type) (c :: Type) (e :: Type). + ( MonadError e m + , MonadReader Environment m + ) + => (a -> e) + -> (SystemStart -> c -> LocalNodeConnectInfo CardanoMode -> ExceptT a m b) + -> c + -> m b +evalQueryWithSystemStart err query args = + do + systemStart <- asks systemStart' + evalQuery err (uncurry query) (systemStart, args) diff --git a/tokenomia.cabal b/tokenomia.cabal index d9ce1b24..5e5662d2 100644 --- a/tokenomia.cabal +++ b/tokenomia.cabal @@ -98,6 +98,7 @@ library Tokenomia.Common.Shell.InteractiveMenu Tokenomia.Common.Shell.Console Tokenomia.Common.Environment + Tokenomia.Common.Environment.Query Tokenomia.Common.Datum Tokenomia.Common.Address Tokenomia.Common.Asset From 6f80c8680f923dc98253fe288a6f3a638cda3bbc Mon Sep 17 00:00:00 2001 From: devfull <26844641+devfull@users.noreply.github.com> Date: Wed, 5 Oct 2022 11:57:33 +0200 Subject: [PATCH 08/15] [polish] keep universal quantification implicit --- src/Tokenomia/Common/Environment/Query.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Tokenomia/Common/Environment/Query.hs b/src/Tokenomia/Common/Environment/Query.hs index 6d6b5de8..7590f5be 100644 --- a/src/Tokenomia/Common/Environment/Query.hs +++ b/src/Tokenomia/Common/Environment/Query.hs @@ -1,7 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} module Tokenomia.Common.Environment.Query ( evalQuery @@ -9,7 +7,6 @@ module Tokenomia.Common.Environment.Query ) where import Data.Bifunctor ( first ) -import Data.Kind ( Type ) import Control.Monad.Except ( MonadError, liftEither ) import Control.Monad.Reader ( MonadReader, asks ) @@ -23,7 +20,6 @@ import Tokenomia.Common.Environment ( Environment(..) ) -- | Lift an ExceptT into a MonadError evalExceptT :: - forall (m :: Type -> Type) (a :: Type) (b :: Type) (e :: Type). ( MonadError e m ) => (a -> e) -> ExceptT a m b @@ -33,7 +29,6 @@ evalExceptT err x = -- | Run a query that can fail in a MonadError, with a LocalNodeConnectInfo argument evalQuery :: - forall (m :: Type -> Type) (a :: Type) (b :: Type) (c :: Type) (e :: Type). ( MonadError e m , MonadReader Environment m ) @@ -47,7 +42,6 @@ evalQuery err query args = -- | Run a query that can fail in a MonadError, with an additional SystemStart argument evalQueryWithSystemStart :: - forall (m :: Type -> Type) (a :: Type) (b :: Type) (c :: Type) (e :: Type). ( MonadError e m , MonadReader Environment m ) From 6ac20cf2a61ae0d4323baa2f452ecd296e487dff Mon Sep 17 00:00:00 2001 From: devfull <26844641+devfull@users.noreply.github.com> Date: Wed, 5 Oct 2022 12:18:57 +0200 Subject: [PATCH 09/15] [polish] keep universal quantification implicit --- src/Tokenomia/Vesting/GenerateNative.hs | 11 +++-------- test/Spec/Tokenomia/Vesting/GenerateNative.hs | 11 ++++------- 2 files changed, 7 insertions(+), 15 deletions(-) diff --git a/src/Tokenomia/Vesting/GenerateNative.hs b/src/Tokenomia/Vesting/GenerateNative.hs index 1c035719..7d4386f1 100644 --- a/src/Tokenomia/Vesting/GenerateNative.hs +++ b/src/Tokenomia/Vesting/GenerateNative.hs @@ -285,7 +285,6 @@ instance ToJSON (WithNetworkId DatabaseOutput) where -- | Preconditions on the input data validatePrivateSale :: - forall (m :: Type -> Type). ( MonadError TokenomiaError m ) => PrivateSale -> m () validatePrivateSale PrivateSale{..} = @@ -340,7 +339,9 @@ minAllocation ε (TranchesProportions xs) = -------------------------------------------------------------------------------- -getNetworkId :: forall (m :: Type -> Type). MonadReader Environment m => m Api.NetworkId +getNetworkId :: + ( MonadReader Environment m ) + => m Api.NetworkId getNetworkId = asks readNetworkId where readNetworkId :: Environment -> Api.NetworkId @@ -348,7 +349,6 @@ getNetworkId = asks readNetworkId readNetworkId Testnet {magicNumber} = Api.Testnet . NetworkMagic $ fromInteger magicNumber unsafeDeserialiseCardanoAddress :: - forall (m :: Type -> Type). ( MonadError TokenomiaError m ) => Text -> m Address unsafeDeserialiseCardanoAddress = @@ -356,7 +356,6 @@ unsafeDeserialiseCardanoAddress = -- | Parse PrivateSale from a JSON file readPrivateSale :: - forall (m :: Type -> Type). ( MonadIO m , MonadError TokenomiaError m ) @@ -367,7 +366,6 @@ readPrivateSale path = -- | Parse PrivateSale from a JSON file and validate the data parsePrivateSale :: - forall (m :: Type -> Type). ( MonadIO m , MonadError TokenomiaError m ) @@ -377,7 +375,6 @@ parsePrivateSale path = do privateSale <$ validatePrivateSale privateSale generatePrivateSaleFiles :: - forall (m :: Type -> Type). ( MonadIO m , MonadError TokenomiaError m , MonadReader Environment m @@ -400,7 +397,6 @@ generatePrivateSaleFiles = do -- | Try to convert an Address to its PubKeyHash investorAddressPubKeyHash :: - forall (m :: Type -> Type). ( MonadError TokenomiaError m ) => InvestorAddress -> m PubKeyHash investorAddressPubKeyHash (InvestorAddress text) = do @@ -467,7 +463,6 @@ merge xxs@(x :| _) = -- | Reshape all tranches NativeScriptInfos into a DatabaseOutput toDatabaseOutput :: - forall (m :: Type -> Type). ( MonadError TokenomiaError m , MonadReader Environment m ) diff --git a/test/Spec/Tokenomia/Vesting/GenerateNative.hs b/test/Spec/Tokenomia/Vesting/GenerateNative.hs index 6d6a2623..1d36839d 100644 --- a/test/Spec/Tokenomia/Vesting/GenerateNative.hs +++ b/test/Spec/Tokenomia/Vesting/GenerateNative.hs @@ -3,7 +3,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TupleSections #-} module Spec.Tokenomia.Vesting.GenerateNative @@ -27,7 +26,6 @@ import Data.Either ( isRight ) import Data.Either.Combinators ( fromRight' ) import Data.Functor ( (<&>) ) import Data.Functor.Syntax ( (<$$>) ) -import Data.Kind ( Type ) import Data.Ratio ( (%) ) import GHC.Natural ( Natural, naturalFromInteger ) @@ -109,14 +107,14 @@ instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (NEMap k v) where arbitrary = NEMap.fromList <$> arbitrary shrink = fmap NEMap.fromList . shrinkAssocs . NEMap.toList where - shrinkAssocs :: forall a b. Arbitrary b => NonEmpty (a, b) -> [NonEmpty (a, b)] + shrinkAssocs :: Arbitrary b => NonEmpty (a, b) -> [NonEmpty (a, b)] shrinkAssocs xs = [ NEList.fromList xs' | xs' <- shrinkList shrinkPair (NEList.toList xs) , not (null xs') ] - shrinkPair :: forall a b. Arbitrary b => (a, b) -> [(a, b)] + shrinkPair :: Arbitrary b => (a, b) -> [(a, b)] shrinkPair (k, v) = (k,) <$> shrink v instance Arbitrary PrivateSale where @@ -225,7 +223,7 @@ instance Arbitrary (Restricted PrivateSale) where in Restricted <$> filter validPrivateSaleAllocations (tail shrinkedPrivateSale) where - shrink' :: forall a. Arbitrary a => a -> [a] + shrink' :: Arbitrary a => a -> [a] shrink' a = a : shrink a -- | Validate only allocations of a PrivateSale @@ -242,7 +240,6 @@ toInvestorAddress = InvestorAddress . convert . unPaymentAddress -- | Update a PrivateSale with valid generated testnet addresses useValidAddresses :: - forall (m :: Type -> Type). ( MonadIO m ) => PrivateSale -> m PrivateSale useValidAddresses PrivateSale{..} = @@ -251,7 +248,7 @@ useValidAddresses PrivateSale{..} = addresses <- toInvestorAddress <$$> generateAddresses "testnet" (indices allocations) pure PrivateSale{allocationByAddress=NEMap.fromList $ NEList.zip addresses allocations,..} where - indices :: forall (a :: Type). NonEmpty a -> NonEmpty Integer + indices :: NonEmpty a -> NonEmpty Integer indices = NEList.fromList . (\n -> [0..n-1]) . toInteger . length -- | Validate an arbitrary PrivateSale updated with valid addresses From fe04fc8d46a92354e1166cef7f3a7b9f8f9228ad Mon Sep 17 00:00:00 2001 From: devfull <26844641+devfull@users.noreply.github.com> Date: Thu, 6 Oct 2022 12:21:19 +0200 Subject: [PATCH 10/15] [vesting] fix slot conversion with local query --- src/Tokenomia/CardanoApi/FromPlutus/Time.hs | 47 ++++++++ src/Tokenomia/Common/Time.hs | 70 ++++++++++-- src/Tokenomia/Vesting/GenerateNative.hs | 76 ++++++++----- test/Spec/Tokenomia/Vesting/GenerateNative.hs | 102 ++++++++++++------ tokenomia.cabal | 1 + 5 files changed, 228 insertions(+), 68 deletions(-) create mode 100644 src/Tokenomia/CardanoApi/FromPlutus/Time.hs diff --git a/src/Tokenomia/CardanoApi/FromPlutus/Time.hs b/src/Tokenomia/CardanoApi/FromPlutus/Time.hs new file mode 100644 index 00000000..0bc2bf94 --- /dev/null +++ b/src/Tokenomia/CardanoApi/FromPlutus/Time.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Tokenomia.CardanoApi.FromPlutus.Time + ( fromPlutusSlot + , posixTimeToNominalDiffTime + , nominalDiffTimeToPosixTime + , posixTimeToRelativeTime + , relativeTimeToPosixTime + ) where + +import Data.Composition ( (.:) ) +import Data.Time.Clock ( NominalDiffTime, secondsToNominalDiffTime ) + +import Ledger ( POSIXTime(..), Slot (..) ) + +import Cardano.Api ( SlotNo(..) ) +import Cardano.Slotting.Time ( SystemStart ) + +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( RelativeTime(..) ) + +import Tokenomia.CardanoApi.Time ( relativeTimeToNominalDiffTime, nominalDiffTimeToRelativeTime ) + + +-- | Convert from Plutus to Cardano slot representation +fromPlutusSlot :: Slot -> SlotNo +fromPlutusSlot = SlotNo . fromInteger . getSlot + +-- | Convert from Plutus to Cardano POSIXTime +posixTimeToNominalDiffTime :: POSIXTime -> NominalDiffTime +posixTimeToNominalDiffTime = + secondsToNominalDiffTime . fromIntegral . (`div` 1000) . getPOSIXTime + +-- | Convert from Cardano to Plutus POSIXTime +nominalDiffTimeToPosixTime :: NominalDiffTime -> POSIXTime +nominalDiffTimeToPosixTime = + POSIXTime . truncate . (* 1000) + +-- | Convert from Plutus POSIXTime to RelativeTime +posixTimeToRelativeTime :: SystemStart -> POSIXTime -> RelativeTime +posixTimeToRelativeTime systemStart = + nominalDiffTimeToRelativeTime systemStart . posixTimeToNominalDiffTime + +-- | Convert from RelativeTime to Plutus POSIXTime +relativeTimeToPosixTime :: SystemStart -> RelativeTime -> POSIXTime +relativeTimeToPosixTime = + nominalDiffTimeToPosixTime .: relativeTimeToNominalDiffTime diff --git a/src/Tokenomia/Common/Time.hs b/src/Tokenomia/Common/Time.hs index 1560f152..128cd064 100644 --- a/src/Tokenomia/Common/Time.hs +++ b/src/Tokenomia/Common/Time.hs @@ -1,25 +1,40 @@ +{-# LANGUAGE ImportQualifiedPost #-} + module Tokenomia.Common.Time ( posixTimeToEnclosingSlotNo , slotAfterNextBeginPOSIXTime - , toCardanoSlotNo + , toNextBeginNominalDiffTime , toNextBeginPOSIXTime + , toNextBeginRelativeTime ) where -import Cardano.Api ( SlotNo(..) ) import Data.Default ( def ) -import Ledger ( POSIXTime, Slot (..) ) +import Data.Time.Clock ( NominalDiffTime ) + +import Control.Monad.Reader ( MonadIO(..) ) +import Control.Monad.Trans.Except ( ExceptT ) +import Control.Monad.Trans.Except.Extra ( secondExceptT ) + +import Ledger ( POSIXTime(..), Slot (..) ) import Ledger.TimeSlot ( posixTimeToEnclosingSlot, slotToBeginPOSIXTime ) +import Cardano.Api ( SlotNo(..) ) +import Cardano.Api.Shelley ( CardanoMode, LocalNodeConnectInfo ) +import Cardano.Slotting.Time ( SystemStart ) + +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( RelativeTime(..) ) + +import Tokenomia.CardanoApi.Query ( QueryFailure, querySlotToWallclock', queryWallclockToSlot' ) +import Tokenomia.CardanoApi.Time ( relativeTimeToNominalDiffTime, nominalDiffTimeToRelativeTime ) +import Tokenomia.CardanoApi.FromPlutus.Time ( fromPlutusSlot ) --- | Convert from Plutus to Cardano slot representation -toCardanoSlotNo :: Slot -> SlotNo -toCardanoSlotNo = SlotNo . fromInteger . getSlot -- | POSIXTime to enclosing SlotNo posixTimeToEnclosingSlotNo :: POSIXTime -> SlotNo -posixTimeToEnclosingSlotNo = toCardanoSlotNo . posixTimeToEnclosingSlot def +posixTimeToEnclosingSlotNo = fromPlutusSlot . posixTimeToEnclosingSlot def --- | Smaller slot whose starting POSIXTime is greater or equal to the given time +-- | Smallest slot whose starting POSIXTime is greater or equal than the given time slotAfterNextBeginPOSIXTime :: POSIXTime -> Slot slotAfterNextBeginPOSIXTime time = let n = posixTimeToEnclosingSlot def time @@ -28,6 +43,43 @@ slotAfterNextBeginPOSIXTime time = then n else n + 1 --- | Smaller POSIXTime starting a slot that is greater or equal to the given time +-- | Smallest POSIXTime starting a slot that is greater or equal than the given time toNextBeginPOSIXTime :: POSIXTime -> POSIXTime toNextBeginPOSIXTime = slotToBeginPOSIXTime def . slotAfterNextBeginPOSIXTime + +-- | Smallest slot whose starting time is greater or equal than the given time +slotAfterNextBeginRelativeTime :: + ( MonadIO m ) + => RelativeTime + -> LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m SlotNo +slotAfterNextBeginRelativeTime time localNodeConnectInfo = + do + n <- queryWallclockToSlot' time localNodeConnectInfo + beginTime <- querySlotToWallclock' n localNodeConnectInfo + pure $ + if time == beginTime + then n + else n + 1 + +-- | Smallest time starting a slot that is greater or equal than the given relative time +toNextBeginRelativeTime :: + ( MonadIO m ) + => RelativeTime + -> LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m RelativeTime +toNextBeginRelativeTime time localNodeConnectInfo = + do + n <- slotAfterNextBeginRelativeTime time localNodeConnectInfo + querySlotToWallclock' n localNodeConnectInfo + +-- | Smallest time starting a slot that is greater or equal than the given time +toNextBeginNominalDiffTime :: + ( MonadIO m ) + => SystemStart + -> NominalDiffTime + -> LocalNodeConnectInfo CardanoMode + -> ExceptT QueryFailure m NominalDiffTime +toNextBeginNominalDiffTime systemStart time = + secondExceptT (relativeTimeToNominalDiffTime systemStart) . + toNextBeginRelativeTime (nominalDiffTimeToRelativeTime systemStart time) diff --git a/src/Tokenomia/Vesting/GenerateNative.hs b/src/Tokenomia/Vesting/GenerateNative.hs index 7d4386f1..ee66fa55 100644 --- a/src/Tokenomia/Vesting/GenerateNative.hs +++ b/src/Tokenomia/Vesting/GenerateNative.hs @@ -30,6 +30,7 @@ module Tokenomia.Vesting.GenerateNative , minAllocation , nativeScriptAddress , parsePrivateSale + , queryError , readPrivateSale , scaleRatios , splitAllocation @@ -43,18 +44,19 @@ module Tokenomia.Vesting.GenerateNative ) where import Control.Error.Safe ( assertErr ) -import Control.Monad ( join ) +import Control.Monad ( join, (>=>) ) import Control.Monad.Except ( MonadError, liftEither ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import Control.Monad.Reader ( MonadReader, asks ) import Data.Bifunctor ( first ) -import Data.Either.Combinators ( fromRight, maybeToRight ) +import Data.Either.Combinators ( maybeToRight ) import Data.Foldable ( traverse_ ) import Data.Functor.Syntax ( (<$$>) ) import Data.Kind ( Type ) +import Data.Ratio ( Ratio, (%), numerator, denominator ) import Data.String ( fromString ) import Data.Text ( Text ) -import Data.Ratio ( Ratio, (%), numerator, denominator ) +import Data.Time.Clock ( NominalDiffTime ) import Data.List.NonEmpty ( NonEmpty((:|)), (<|) ) import Data.List.NonEmpty qualified @@ -67,7 +69,7 @@ import Data.Map.NonEmpty qualified import GHC.Generics ( Generic ) import GHC.Natural ( Natural, naturalFromInteger, naturalToInteger ) -import Ledger ( POSIXTime, PubKeyHash, toPubKeyHash ) +import Ledger ( PubKeyHash, toPubKeyHash ) import Ledger.Address ( Address ) import Ledger.Value ( AssetClass(..) ) import System.FilePath ( replaceFileName ) @@ -107,10 +109,14 @@ import Cardano.Api qualified import Tokenomia.CardanoApi.Fees ( calculateDefaultMinimumUTxOFromAssetId ) import Tokenomia.Common.Aeson.AssetClass ( assetClassToJSON ) +import Tokenomia.Common.AssetClass ( adaAssetClass ) import Tokenomia.Common.Data.List.Extra ( mapLastWith, transpose ) import Tokenomia.Common.Environment ( Environment(..) ) +import Tokenomia.Common.Environment.Query ( evalQueryWithSystemStart ) import Tokenomia.Common.Error ( TokenomiaError(InvalidPrivateSale, MalformedAddress) ) -import Tokenomia.Common.Time ( posixTimeToEnclosingSlotNo , toNextBeginPOSIXTime ) +import Tokenomia.Common.Time ( toNextBeginNominalDiffTime ) + +import Tokenomia.CardanoApi.Query ( QueryFailure, queryNominalDiffTimeToSlot ) import Tokenomia.CardanoApi.FromPlutus.Value ( assetClassAsAssetId ) @@ -214,7 +220,7 @@ newtype TranchesProportions data TrancheProperties = TrancheProperties { proportion :: Ratio Natural - , unlockTime :: POSIXTime + , unlockTime :: NominalDiffTime } deriving stock (Show, Generic) deriving anyclass (ToJSON, FromJSON) @@ -230,7 +236,7 @@ data PrivateSale data PrivateSaleTranche = PrivateSaleTranche - { trancheUnlockTime :: POSIXTime + { trancheUnlockTime :: NominalDiffTime , trancheAssetClass :: AssetClass , trancheAllocationByAddress :: NEMap InvestorAddress Allocation } @@ -240,7 +246,7 @@ data PrivateSaleTranche data NativeScript = NativeScript { requireSignature :: PubKeyHash - , requireTimeAfter :: POSIXTime + , requireTimeAfter :: NominalDiffTime } deriving stock (Show) @@ -283,6 +289,14 @@ instance ToJSON (WithNetworkId DatabaseOutput) where -------------------------------------------------------------------------------- +-- | Convert a generic failure to a TokenomiaError +invalidPrivateSale :: Show a => a -> TokenomiaError +invalidPrivateSale = InvalidPrivateSale . show + +-- | Convert a QueryFailure to a TokenomiaError +queryError :: QueryFailure -> TokenomiaError +queryError = invalidPrivateSale + -- | Preconditions on the input data validatePrivateSale :: ( MonadError TokenomiaError m ) @@ -300,8 +314,7 @@ validatePrivateSale PrivateSale{..} = calculateDefaultMinimumUTxOFromAssetClass :: AssetClass -> Either TokenomiaError Natural calculateDefaultMinimumUTxOFromAssetClass assetClass = do - assetId <- first - (InvalidPrivateSale . show) + assetId <- first invalidPrivateSale (assetClassAsAssetId assetClass) naturalFromInteger <$> maybeToRight (InvalidPrivateSale "Could not calculate minimum UTxO") @@ -410,17 +423,22 @@ nativeScriptAddress :: forall (m :: Type -> Type). ( MonadError TokenomiaError m , MonadReader Environment m + , MonadIO m ) => NativeScript -> m Address nativeScriptAddress = - simpleScriptAddress . toCardanoSimpleScript + toCardanoSimpleScript >=> simpleScriptAddress where - toCardanoSimpleScript :: NativeScript -> SimpleScript SimpleScriptV2 + toCardanoSimpleScript :: NativeScript -> m (SimpleScript SimpleScriptV2) toCardanoSimpleScript NativeScript{..} = - RequireAllOf - [ RequireSignature (fromString . show $ requireSignature) - , RequireTimeAfter TimeLocksInSimpleScriptV2 (posixTimeToEnclosingSlotNo requireTimeAfter) - ] + do + slotNo <- + evalQueryWithSystemStart queryError + queryNominalDiffTimeToSlot requireTimeAfter + pure $ RequireAllOf + [ RequireSignature (fromString . show $ requireSignature) + , RequireTimeAfter TimeLocksInSimpleScriptV2 slotNo + ] simpleScriptAddress :: SimpleScript SimpleScriptV2 -> m Address simpleScriptAddress script = do @@ -436,22 +454,31 @@ trancheNativeScriptInfos :: forall (m :: Type -> Type). ( MonadError TokenomiaError m , MonadReader Environment m + , MonadIO m ) => PrivateSaleTranche -> m (NEMap InvestorAddress NativeScriptInfo) trancheNativeScriptInfos PrivateSaleTranche{..} = traverseWithKey nativeScriptInfo trancheAllocationByAddress where nativeScriptInfo :: InvestorAddress -> Allocation -> m NativeScriptInfo - nativeScriptInfo investorAddress allocation = do - requiring <- nativeScript investorAddress - recipient <- (`Recipient` naturalToInteger allocation) - <$> nativeScriptAddress requiring - pure NativeScriptInfo{..} + nativeScriptInfo investorAddress allocation = + do + requiring <- nativeScript investorAddress + recipient <- + (`Recipient` naturalToInteger allocation) + <$> nativeScriptAddress requiring + + pure NativeScriptInfo{..} nativeScript :: InvestorAddress -> m NativeScript - nativeScript investorAddress = do - pubKeyHash <- investorAddressPubKeyHash investorAddress - pure $ NativeScript pubKeyHash (toNextBeginPOSIXTime trancheUnlockTime) + nativeScript investorAddress = + do + requireSignature <- investorAddressPubKeyHash investorAddress + requireTimeAfter <- + evalQueryWithSystemStart queryError + toNextBeginNominalDiffTime trancheUnlockTime + + pure NativeScript{..} -- | Merge a list of maps into a single map to list using the keys of the first map merge :: (Ord k) => NonEmpty (NEMap k v) -> NEMap k (NonEmpty v) @@ -465,6 +492,7 @@ merge xxs@(x :| _) = toDatabaseOutput :: ( MonadError TokenomiaError m , MonadReader Environment m + , MonadIO m ) => NonEmpty PrivateSaleTranche -> m DatabaseOutput toDatabaseOutput tranches = diff --git a/test/Spec/Tokenomia/Vesting/GenerateNative.hs b/test/Spec/Tokenomia/Vesting/GenerateNative.hs index 1d36839d..8b1f237d 100644 --- a/test/Spec/Tokenomia/Vesting/GenerateNative.hs +++ b/test/Spec/Tokenomia/Vesting/GenerateNative.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TupleSections #-} @@ -10,9 +11,9 @@ module Spec.Tokenomia.Vesting.GenerateNative ) where import Control.Applicative ( ZipList(..) ) -import Control.Monad.Except ( runExceptT ) +import Control.Monad.Except ( MonadError, runExceptT ) import Control.Monad.IO.Class ( MonadIO(..) ) -import Control.Monad.Reader ( runReaderT ) +import Control.Monad.Reader ( MonadReader, runReaderT ) import Data.List.NonEmpty ( NonEmpty(..), (<|) ) import Data.List.NonEmpty qualified as NEList ( fromList, toList, zip, zipWith ) @@ -52,17 +53,22 @@ import Test.Tasty.QuickCheck , withMaxSuccess ) -import Tokenomia.Common.Arbitrary.AssetClass () -import Tokenomia.Common.Arbitrary.Modifiers ( Restricted(..) ) -import Tokenomia.Common.Arbitrary.POSIXTime () -import Tokenomia.Common.Arbitrary.Wallet ( PaymentAddress(..), generateAddresses ) - -import Tokenomia.Common.Data.Convertible ( convert ) -import Tokenomia.Common.Data.List.Extra ( transpose ) -import Tokenomia.Common.Environment ( getTestnetEnvironmment ) -import Tokenomia.Common.Time ( toNextBeginPOSIXTime ) - -import Tokenomia.TokenDistribution.Distribution ( Distribution(recipients), Recipient(..) ) +import Tokenomia.Common.Arbitrary.AssetClass( ) +import Tokenomia.Common.Arbitrary.Modifiers ( Restricted(..) ) +import Tokenomia.Common.Arbitrary.POSIXTime ( ) +import Tokenomia.Common.Arbitrary.Wallet ( PaymentAddress(..), generateAddresses ) + +import Tokenomia.Common.Data.Convertible ( convert ) +import Tokenomia.Common.Data.List.Extra ( transpose ) +import Tokenomia.Common.Environment ( Environment(..), getTestnetEnvironmment ) +import Tokenomia.Common.Environment.Query ( evalQueryWithSystemStart ) +import Tokenomia.Common.Error ( TokenomiaError ) +import Tokenomia.Common.Time ( toNextBeginNominalDiffTime ) + +import Tokenomia.TokenDistribution.Distribution + ( Distribution(recipients) + , Recipient(..) + ) import Tokenomia.Vesting.GenerateNative ( DatabaseOutput(..) @@ -77,6 +83,7 @@ import Tokenomia.Vesting.GenerateNative , investorAddressPubKeyHash , merge , minAllocation + , queryError , scaleRatios , splitAllocation , splitInTranches @@ -88,10 +95,10 @@ import Tokenomia.Vesting.GenerateNative , validateTranchesProportions ) --- import Test.QuickCheck.Monadic ( assert ) --- import Tokenomia.Vesting.GenerateNativeRefacto ( getNetworkId ) --- import System.FilePath ( replaceFileName ) --- import Data.Aeson ( encodeFile ) +-- import Test.QuickCheck.Monadic ( assert ) +-- import Tokenomia.Vesting.GenerateNative ( getNetworkId ) +-- import System.FilePath ( replaceFileName ) +-- import Data.Aeson ( encodeFile ) -- import Tokenomia.TokenDistribution.Distribution ( WithNetworkId(..) ) @@ -174,7 +181,10 @@ instance Arbitrary (Restricted (NonEmpty TrancheProperties)) where Restricted <$> do proportions <- unTranchesProportions <$> arbitrary - unlockTimes <- vectorOf (length proportions) arbitrary + unlockTimes <- + vectorOf (length proportions) $ + fromInteger . (+1563999616) . getPositive -- testnet system start + <$> arbitrary pure $ NEList.fromList . getZipList $ TrancheProperties <$> ZipList (NEList.toList proportions) @@ -354,11 +364,21 @@ propertiesInvestorAddressPubKeyHash = traverse (runExceptT . investorAddressPubKeyHash) addresses ] -validTrancheNativeScriptUnlockTime :: PrivateSaleTranche -> NEMap InvestorAddress NativeScriptInfo -> Bool +validTrancheNativeScriptUnlockTime :: + ( MonadError TokenomiaError m + , MonadReader Environment m + , MonadIO m + ) + => PrivateSaleTranche + -> NEMap InvestorAddress NativeScriptInfo + -> m Bool validTrancheNativeScriptUnlockTime PrivateSaleTranche{..} xs = - all - (== toNextBeginPOSIXTime trancheUnlockTime) - (requireTimeAfter . requiring <$> NEMap.elems xs) + do + nextBeginTime <- evalQueryWithSystemStart queryError toNextBeginNominalDiffTime trancheUnlockTime + pure $ + all + (== nextBeginTime) + (requireTimeAfter . requiring <$> NEMap.elems xs) validTrancheNativeScriptAddress :: PrivateSaleTranche -> NEMap InvestorAddress NativeScriptInfo -> Bool validTrancheNativeScriptAddress PrivateSaleTranche{..} xs = @@ -380,23 +400,35 @@ propertiesTrancheNativeScriptInfos = monadicIO $ do env <- getTestnetEnvironmment 1097911063 validPrivateSale <- useValidAddresses ps - and - <$> traverse - (runValidTrancheNativeScriptInfos env) - (splitInTranches validPrivateSale) + and <$> + traverse + (runValidTrancheNativeScriptInfos env) + (splitInTranches validPrivateSale) ) ] where + validTrancheNativeScriptInfos :: + ( MonadError TokenomiaError m + , MonadReader Environment m + , MonadIO m + ) + => PrivateSaleTranche + -> m Bool + validTrancheNativeScriptInfos tranche = + do + xs <- trancheNativeScriptInfos tranche + validTrancheNativeScriptUnlockTime tranche xs + <&> ( && validTrancheNativeScriptAddress tranche xs + && validTrancheNativeScriptAllocation tranche xs + ) + + runValidTrancheNativeScriptInfos :: + ( MonadIO m ) + => Environment + -> PrivateSaleTranche + -> m Bool runValidTrancheNativeScriptInfos env tranche = - runExceptT (runReaderT (trancheNativeScriptInfos tranche) env) - <&> validTrancheNativeScriptInfos tranche - validTrancheNativeScriptInfos tranche e = - let xs = fromRight' e - in - isRight e - && validTrancheNativeScriptUnlockTime tranche xs - && validTrancheNativeScriptAddress tranche xs - && validTrancheNativeScriptAllocation tranche xs + fromRight' <$> runExceptT (runReaderT (validTrancheNativeScriptInfos tranche) env) newtype MapToTranspose k v = MapToTranspose diff --git a/tokenomia.cabal b/tokenomia.cabal index 5e5662d2..da11decc 100644 --- a/tokenomia.cabal +++ b/tokenomia.cabal @@ -73,6 +73,7 @@ library Tokenomia.Vesting.Sendings Tokenomia.Tokenomic.CLAP.Simulation Tokenomia.CardanoApi.FromPlutus.Error + Tokenomia.CardanoApi.FromPlutus.Time Tokenomia.CardanoApi.FromPlutus.Value Tokenomia.CardanoApi.Fees Tokenomia.CardanoApi.PParams From 3f7b1216afa8a436f94fc2679161475cfec296b3 Mon Sep 17 00:00:00 2001 From: devfull <26844641+devfull@users.noreply.github.com> Date: Thu, 6 Oct 2022 12:45:48 +0200 Subject: [PATCH 11/15] [vesting] fix min allocation for non-ada asset --- src/Tokenomia/Vesting/GenerateNative.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Tokenomia/Vesting/GenerateNative.hs b/src/Tokenomia/Vesting/GenerateNative.hs index ee66fa55..5842c902 100644 --- a/src/Tokenomia/Vesting/GenerateNative.hs +++ b/src/Tokenomia/Vesting/GenerateNative.hs @@ -305,7 +305,10 @@ validatePrivateSale PrivateSale{..} = let proportions = TranchesProportions $ proportion <$> tranchesProperties in liftEither $ do - ε <- calculateDefaultMinimumUTxOFromAssetClass assetClass + ε <- + if assetClass == adaAssetClass + then calculateDefaultMinimumUTxOFromAssetClass assetClass + else pure 1 validateTranchesProportions proportions validateAllocations ε proportions $ NEMap.elems allocationByAddress traverse_ (unsafeDeserialiseCardanoAddress . unInvestorAddress) $ NEMap.keys allocationByAddress From fba89687b6edd5793d3181860764d4d495d2666a Mon Sep 17 00:00:00 2001 From: devfull <26844641+devfull@users.noreply.github.com> Date: Mon, 10 Oct 2022 14:42:21 +0200 Subject: [PATCH 12/15] [network] rewrite tests for monadic functions --- src/Tokenomia/CLI.hs | 3 +- src/Tokenomia/CardanoApi/Arbitrary/Slot.hs | 17 +++ src/Tokenomia/CardanoApi/Arbitrary/Time.hs | 15 +++ src/Tokenomia/Common/Error.hs | 2 +- src/Tokenomia/Common/Time.hs | 28 +---- test/Spec/Tokenomia/Common/Time.hs | 119 ++++++++++++++------- tokenomia.cabal | 4 + 7 files changed, 117 insertions(+), 71 deletions(-) create mode 100644 src/Tokenomia/CardanoApi/Arbitrary/Slot.hs create mode 100644 src/Tokenomia/CardanoApi/Arbitrary/Time.hs diff --git a/src/Tokenomia/CLI.hs b/src/Tokenomia/CLI.hs index 08e19299..dd207b9c 100644 --- a/src/Tokenomia/CLI.hs +++ b/src/Tokenomia/CLI.hs @@ -145,6 +145,7 @@ recursiveMenu = do printLn $ "ICO - Whitelisting not valid index =" <> show index <> " retrieved= " <> show indexRetrieved InvalidTransaction e -> printLn $ "Invalid Transaction : " <> e InvalidPrivateSale e -> printLn $ "Invalid Private sale input : " <> e + QueryFailure e -> printLn $ "QueryFailure : " <> e ChildAddressNotIndexed w address -> printLn $ "Address not indexed " <> show (w,address) <>", please generate your indexes appropriately" MalformedAddress -> printLn "Sendings - Invalid treasury address" @@ -283,5 +284,3 @@ instance DisplayMenuItem Action where ICOExchangeRun -> "[ICO] - Funds Exchange Run" ICOUpdateWhiteListing -> "[ICO] - Update Whitelisting" ICOFundsDispatchSimulation -> "[ICO] - Funds Simulation (Dispatch ADAs on child addresses )" - - diff --git a/src/Tokenomia/CardanoApi/Arbitrary/Slot.hs b/src/Tokenomia/CardanoApi/Arbitrary/Slot.hs new file mode 100644 index 00000000..66285a7d --- /dev/null +++ b/src/Tokenomia/CardanoApi/Arbitrary/Slot.hs @@ -0,0 +1,17 @@ +module Tokenomia.CardanoApi.Arbitrary.Slot + () where + +import Cardano.Api + ( SlotNo(..) ) + +import Test.Tasty.QuickCheck + ( Arbitrary + , arbitrary + , genericShrink + , shrink + ) + + +instance Arbitrary SlotNo where + arbitrary = SlotNo <$> arbitrary + shrink = genericShrink diff --git a/src/Tokenomia/CardanoApi/Arbitrary/Time.hs b/src/Tokenomia/CardanoApi/Arbitrary/Time.hs new file mode 100644 index 00000000..89112250 --- /dev/null +++ b/src/Tokenomia/CardanoApi/Arbitrary/Time.hs @@ -0,0 +1,15 @@ +module Tokenomia.CardanoApi.Arbitrary.Time + () where + +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( RelativeTime(..) ) + +import Test.Tasty.QuickCheck + ( Arbitrary + , arbitrary + , getPositive + ) + + +instance Arbitrary RelativeTime where + arbitrary = RelativeTime . fromInteger . getPositive <$> arbitrary diff --git a/src/Tokenomia/Common/Error.hs b/src/Tokenomia/Common/Error.hs index 16d015c0..1e010215 100644 --- a/src/Tokenomia/Common/Error.hs +++ b/src/Tokenomia/Common/Error.hs @@ -48,6 +48,7 @@ data TokenomiaError | SendingsValueMismatch (Value, Value) | MalformedAddress | InvalidPrivateSale String + | QueryFailure String deriving Show whenNullThrow :: MonadError e m => e -> [a] -> m (NonEmpty a) @@ -64,4 +65,3 @@ whenNothingThrow err = maybe (throwError err) pure whenLeftThrow :: MonadError e m => (a -> e) -> Either a b -> m b whenLeftThrow toErr = either (throwError . toErr) pure - diff --git a/src/Tokenomia/Common/Time.hs b/src/Tokenomia/Common/Time.hs index 128cd064..a5001468 100644 --- a/src/Tokenomia/Common/Time.hs +++ b/src/Tokenomia/Common/Time.hs @@ -1,23 +1,15 @@ -{-# LANGUAGE ImportQualifiedPost #-} - module Tokenomia.Common.Time - ( posixTimeToEnclosingSlotNo - , slotAfterNextBeginPOSIXTime + ( slotAfterNextBeginRelativeTime , toNextBeginNominalDiffTime - , toNextBeginPOSIXTime , toNextBeginRelativeTime ) where -import Data.Default ( def ) import Data.Time.Clock ( NominalDiffTime ) import Control.Monad.Reader ( MonadIO(..) ) import Control.Monad.Trans.Except ( ExceptT ) import Control.Monad.Trans.Except.Extra ( secondExceptT ) -import Ledger ( POSIXTime(..), Slot (..) ) -import Ledger.TimeSlot ( posixTimeToEnclosingSlot, slotToBeginPOSIXTime ) - import Cardano.Api ( SlotNo(..) ) import Cardano.Api.Shelley ( CardanoMode, LocalNodeConnectInfo ) import Cardano.Slotting.Time ( SystemStart ) @@ -27,25 +19,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types import Tokenomia.CardanoApi.Query ( QueryFailure, querySlotToWallclock', queryWallclockToSlot' ) import Tokenomia.CardanoApi.Time ( relativeTimeToNominalDiffTime, nominalDiffTimeToRelativeTime ) -import Tokenomia.CardanoApi.FromPlutus.Time ( fromPlutusSlot ) - - --- | POSIXTime to enclosing SlotNo -posixTimeToEnclosingSlotNo :: POSIXTime -> SlotNo -posixTimeToEnclosingSlotNo = fromPlutusSlot . posixTimeToEnclosingSlot def - --- | Smallest slot whose starting POSIXTime is greater or equal than the given time -slotAfterNextBeginPOSIXTime :: POSIXTime -> Slot -slotAfterNextBeginPOSIXTime time = - let n = posixTimeToEnclosingSlot def time - in - if time == slotToBeginPOSIXTime def n - then n - else n + 1 --- | Smallest POSIXTime starting a slot that is greater or equal than the given time -toNextBeginPOSIXTime :: POSIXTime -> POSIXTime -toNextBeginPOSIXTime = slotToBeginPOSIXTime def . slotAfterNextBeginPOSIXTime -- | Smallest slot whose starting time is greater or equal than the given time slotAfterNextBeginRelativeTime :: diff --git a/test/Spec/Tokenomia/Common/Time.hs b/test/Spec/Tokenomia/Common/Time.hs index 9ae17d91..a909ed5b 100644 --- a/test/Spec/Tokenomia/Common/Time.hs +++ b/test/Spec/Tokenomia/Common/Time.hs @@ -4,76 +4,113 @@ module Spec.Tokenomia.Common.Time ( tests ) where -import Data.Default ( def ) -import Ledger ( POSIXTime, Slot(..) ) -import Ledger.TimeSlot ( posixTimeToEnclosingSlot, slotToBeginPOSIXTime ) +import Data.Either.Combinators ( fromRight' ) -import Test.Tasty.QuickCheck ( testProperty ) +import Control.Monad.Except ( ExceptT, runExceptT ) +import Control.Monad.Reader ( ReaderT, runReaderT ) + +import Test.QuickCheck.Monadic ( PropertyM, monadicIO ) +import Test.Tasty.QuickCheck ( Property, Testable, testProperty ) import Test.Tasty ( TestTree, testGroup ) -import Tokenomia.Common.Arbitrary.POSIXTime ( ) -import Tokenomia.Common.Arbitrary.Slot ( ) +import Cardano.Api ( SlotNo(..) ) + +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( RelativeTime(..) ) + +import Tokenomia.CardanoApi.Arbitrary.Time ( ) +import Tokenomia.CardanoApi.Arbitrary.Slot ( ) +import Tokenomia.CardanoApi.Query ( querySlotToWallclock', queryWallclockToSlot') + +import Tokenomia.Common.Error ( TokenomiaError(QueryFailure) ) +import Tokenomia.Common.Environment ( Environment(..), getTestnetEnvironmment ) +import Tokenomia.Common.Environment.Query ( evalQuery ) import Tokenomia.Common.Time - ( posixTimeToEnclosingSlotNo - , slotAfterNextBeginPOSIXTime - , toNextBeginPOSIXTime + ( slotAfterNextBeginRelativeTime + , toNextBeginRelativeTime ) tests :: TestTree tests = testGroup "Common.Time" [ properties ] -propertiesPosixTimeToEnclosingSlotNo :: [TestTree] -propertiesPosixTimeToEnclosingSlotNo = +queryFailure :: Show a => a -> TokenomiaError +queryFailure = QueryFailure . show + +runTest :: + ( Testable a ) + => ReaderT Environment (ExceptT e (PropertyM IO)) a + -> Property +runTest test = + monadicIO $ + do + env <- getTestnetEnvironmment 1097911063 + fromRight' <$> runExceptT (runReaderT test env) + +propertiesQueryWallclockToSlot' :: [TestTree] +propertiesQueryWallclockToSlot' = [ testProperty "preserve order" - ( \(a :: POSIXTime) (b :: POSIXTime) -> - let na = posixTimeToEnclosingSlotNo a - nb = posixTimeToEnclosingSlotNo b - in - elem (compare na nb) [EQ, compare a b] + ( \(a :: RelativeTime) (b :: RelativeTime) -> + runTest $ + do + na <- evalQuery queryFailure queryWallclockToSlot' a + nb <- evalQuery queryFailure queryWallclockToSlot' b + pure $ elem (compare na nb) [EQ, compare a b] ) ] -propertiesSlotAfterNextBeginPOSIXTime :: [TestTree] -propertiesSlotAfterNextBeginPOSIXTime = +propertiesSlotAfterNextBeginRelativeTime :: [TestTree] +propertiesSlotAfterNextBeginRelativeTime = [ testProperty "preserve order" - ( \(a :: POSIXTime) (b :: POSIXTime) -> - let na = slotAfterNextBeginPOSIXTime a - nb = slotAfterNextBeginPOSIXTime b - in - elem (compare na nb) [EQ, compare a b] + ( \(a :: RelativeTime) (b :: RelativeTime) -> + runTest $ + do + na <- evalQuery queryFailure slotAfterNextBeginRelativeTime a + nb <- evalQuery queryFailure slotAfterNextBeginRelativeTime b + pure $ elem (compare na nb) [EQ, compare a b] ) , testProperty "is after enclosing slot" - ( \(a :: POSIXTime) -> - posixTimeToEnclosingSlot def a <= slotAfterNextBeginPOSIXTime a + ( \(a :: RelativeTime) -> + runTest $ + do + n <- evalQuery queryFailure queryWallclockToSlot' a + na <- evalQuery queryFailure slotAfterNextBeginRelativeTime a + pure $ n <= na ) ] -propertiesToNextBeginPOSIXTime :: [TestTree] -propertiesToNextBeginPOSIXTime = +propertiesToNextBeginRelativeTime :: [TestTree] +propertiesToNextBeginRelativeTime = [ testProperty "is a future time" - ( \(time :: POSIXTime) -> - time <= toNextBeginPOSIXTime time + ( \(time :: RelativeTime) -> + runTest $ + do + begin <- evalQuery queryFailure toNextBeginRelativeTime time + pure $ time <= begin ) , testProperty "is a slot starting time" - ( \(time :: POSIXTime) -> - let begin = toNextBeginPOSIXTime time - n = posixTimeToEnclosingSlot def begin - in - begin == slotToBeginPOSIXTime def n + ( \(time :: RelativeTime) -> + runTest $ + do + begin <- evalQuery queryFailure toNextBeginRelativeTime time + n <- evalQuery queryFailure queryWallclockToSlot' begin + t <- evalQuery queryFailure querySlotToWallclock' n + pure $ begin == t ) , testProperty "is an identity of slots starting time" - ( \(n :: Slot) -> - let begin = slotToBeginPOSIXTime def n - in - begin == toNextBeginPOSIXTime begin + ( \(n :: SlotNo) -> + runTest $ + do + t <- evalQuery queryFailure querySlotToWallclock' n + begin <- evalQuery queryFailure toNextBeginRelativeTime t + pure $ begin == t ) ] properties :: TestTree properties = testGroup "Properties" - [ testGroup "posixTimeToEnclosingSlotNo" propertiesPosixTimeToEnclosingSlotNo - , testGroup "slotAfterNextBeginPOSIXTime" propertiesSlotAfterNextBeginPOSIXTime - , testGroup "toNextBeginPOSIXTime" propertiesToNextBeginPOSIXTime + [ testGroup "queryWallclockToSlot'" propertiesQueryWallclockToSlot' + , testGroup "slotAfterNextBeginRelativeTime" propertiesSlotAfterNextBeginRelativeTime + , testGroup "toNextBeginRelativeTime" propertiesToNextBeginRelativeTime ] diff --git a/tokenomia.cabal b/tokenomia.cabal index da11decc..ee7149fc 100644 --- a/tokenomia.cabal +++ b/tokenomia.cabal @@ -72,6 +72,8 @@ library Tokenomia.Vesting.Retrieve Tokenomia.Vesting.Sendings Tokenomia.Tokenomic.CLAP.Simulation + Tokenomia.CardanoApi.Arbitrary.Slot + Tokenomia.CardanoApi.Arbitrary.Time Tokenomia.CardanoApi.FromPlutus.Error Tokenomia.CardanoApi.FromPlutus.Time Tokenomia.CardanoApi.FromPlutus.Value @@ -282,6 +284,7 @@ test-suite tokenomia-tests blockfrost-client, bytestring, text, + time, ordered-containers, interpolatedstring-perl6, blockfrost-api, @@ -291,6 +294,7 @@ test-suite tokenomia-tests composition-extra, hex, cardano-api, + ouroboros-consensus, data-default From 01df2d63a29670d9a407661c4613f6781dee0e71 Mon Sep 17 00:00:00 2001 From: devfull <26844641+devfull@users.noreply.github.com> Date: Tue, 11 Oct 2022 10:16:06 +0200 Subject: [PATCH 13/15] [vesting] add SlotNo in NativeScriptInfo --- src/Tokenomia/Vesting/GenerateNative.hs | 28 +++++++++++++------------ 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/src/Tokenomia/Vesting/GenerateNative.hs b/src/Tokenomia/Vesting/GenerateNative.hs index 5842c902..32dce457 100644 --- a/src/Tokenomia/Vesting/GenerateNative.hs +++ b/src/Tokenomia/Vesting/GenerateNative.hs @@ -44,7 +44,7 @@ module Tokenomia.Vesting.GenerateNative ) where import Control.Error.Safe ( assertErr ) -import Control.Monad ( join, (>=>) ) +import Control.Monad ( join ) import Control.Monad.Except ( MonadError, liftEither ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import Control.Monad.Reader ( MonadReader, asks ) @@ -97,6 +97,7 @@ import Cardano.Api ) , SimpleScriptVersion(SimpleScriptV2) , SimpleScriptV2 + , SlotNo , StakeAddressReference(NoStakeAddress) , TimeLocksSupported(TimeLocksInSimpleScriptV2) , hashScript @@ -247,6 +248,7 @@ data NativeScript = NativeScript { requireSignature :: PubKeyHash , requireTimeAfter :: NominalDiffTime + , requireTimeAfterSlot :: SlotNo } deriving stock (Show) @@ -260,8 +262,9 @@ data NativeScriptInfo instance ToJSON NativeScript where toJSON NativeScript{..} = object - [ "requireSignature" .= toJSON (show requireSignature) - , "requireTimeAfter" .= toJSON requireTimeAfter + [ "requireSignature" .= toJSON (show requireSignature) + , "requireTimeAfter" .= toJSON requireTimeAfter + , "requireTimeAfterSlot" .= toJSON requireTimeAfterSlot ] instance ToJSON (WithNetworkId NativeScriptInfo) where @@ -426,21 +429,16 @@ nativeScriptAddress :: forall (m :: Type -> Type). ( MonadError TokenomiaError m , MonadReader Environment m - , MonadIO m ) => NativeScript -> m Address nativeScriptAddress = - toCardanoSimpleScript >=> simpleScriptAddress + simpleScriptAddress . toCardanoSimpleScript where - toCardanoSimpleScript :: NativeScript -> m (SimpleScript SimpleScriptV2) + toCardanoSimpleScript :: NativeScript -> SimpleScript SimpleScriptV2 toCardanoSimpleScript NativeScript{..} = - do - slotNo <- - evalQueryWithSystemStart queryError - queryNominalDiffTimeToSlot requireTimeAfter - pure $ RequireAllOf + RequireAllOf [ RequireSignature (fromString . show $ requireSignature) - , RequireTimeAfter TimeLocksInSimpleScriptV2 slotNo + , RequireTimeAfter TimeLocksInSimpleScriptV2 requireTimeAfterSlot ] simpleScriptAddress :: SimpleScript SimpleScriptV2 -> m Address @@ -476,10 +474,14 @@ trancheNativeScriptInfos PrivateSaleTranche{..} = nativeScript :: InvestorAddress -> m NativeScript nativeScript investorAddress = do - requireSignature <- investorAddressPubKeyHash investorAddress + requireSignature <- + investorAddressPubKeyHash investorAddress requireTimeAfter <- evalQueryWithSystemStart queryError toNextBeginNominalDiffTime trancheUnlockTime + requireTimeAfterSlot <- + evalQueryWithSystemStart queryError + queryNominalDiffTimeToSlot requireTimeAfter pure NativeScript{..} From f44f3c11f0e14a527bdc0f1ed1eddb4caa535e27 Mon Sep 17 00:00:00 2001 From: devfull <26844641+devfull@users.noreply.github.com> Date: Mon, 17 Oct 2022 14:29:50 +0200 Subject: [PATCH 14/15] [nix] update `cardano-node` to 1.35.3 --- cabal.project | 424 +++++++++++------- nix/pkgs/haskell/haskell.nix | 44 +- nix/sources.json | 8 +- src/Tokenomia/CardanoApi/Arbitrary/Slot.hs | 4 +- src/Tokenomia/CardanoApi/FromPlutus/Value.hs | 2 +- src/Tokenomia/Common/Arbitrary/AssetClass.hs | 13 +- src/Tokenomia/Common/Arbitrary/Builtins.hs | 6 - src/Tokenomia/Common/Parser/Address.hs | 28 +- src/Tokenomia/Common/Parser/TxOutRef.hs | 3 +- src/Tokenomia/Common/Token.hs | 2 +- .../ICO/Funds/Exchange/CardanoCLI/Command.hs | 4 +- src/Tokenomia/ICO/Funds/Exchange/Command.hs | 4 +- .../Funds/Validation/CardanoCLI/Command.hs | 2 +- .../Funds/Validation/ChildAddress/State.hs | 3 +- .../Funds/Validation/ChildAddress/Types.hs | 4 +- .../ICO/Funds/Validation/Investor/Command.hs | 4 +- .../ICO/Funds/Validation/Investor/Plan.hs | 7 +- .../Validation/Investor/Plan/Settings.hs | 2 +- src/Tokenomia/ICO/LocalRepository.hs | 3 +- src/Tokenomia/ICO/Round/Settings.hs | 4 +- src/Tokenomia/Script/LocalRepository.hs | 4 +- src/Tokenomia/Token/CLAPStyle/Mint.hs | 3 +- .../Token/CLAPStyle/MonetaryPolicy.hs | 17 +- .../TokenDistribution/Parser/Address.hs | 18 +- src/Tokenomia/Vesting/Contract.hs | 15 +- src/Tokenomia/Vesting/Sendings.hs | 1 - src/Tokenomia/Vesting/Vest.hs | 3 +- .../Tokenomia/CardanoApi/FromPlutus/Value.hs | 2 +- .../Tokenomia/ICO/Funds/Exchange/GenInputs.hs | 2 +- .../Funds/Validation/CardanoCLI/GenInputs.hs | 2 +- .../Funds/Validation/Investor/GenInputs.hs | 2 +- .../Token/CLAPStyle/MonetaryPolicy.hs | 4 +- test/Spec/Tokenomia/Vesting/Contract.hs | 2 +- test/Spec/Tokenomia/Vesting/Sendings.hs | 10 +- tokenomia.cabal | 300 +++++++------ 35 files changed, 526 insertions(+), 430 deletions(-) diff --git a/cabal.project b/cabal.project index 91fb7c3b..15cb39eb 100644 --- a/cabal.project +++ b/cabal.project @@ -1,28 +1,99 @@ -index-state: 2021-08-14T00:00:00Z +-- Bump this if you need newer packages. +index-state: 2022-02-09T00:00:00Z + +profiling: False +library-profiling: False +profiling-detail: all-functions +library-profiling-detail: all-functions packages: ./. --- You never, ever, want this. -write-ghc-environment-files: never +-- We never, ever, want this. +-- write-xghc-environment-files: never -- Always build tests and benchmarks. tests: true benchmarks: true --- Plutus revision from 2021/08/16 + +-- The only sensible test display option, since it allows us to have colourized +-- 'tasty' output. +test-show-details: direct + +-- cardano-addresses unit tests bring in some version constraint conflicts: +-- +-- * it has strict aeson < 1.5 dep - this will be fixed in the next release. +allow-newer: + *:aeson + , size-based:template-haskell + +constraints: + aeson >= 2 + , hedgehog >= 1.1 + +-- The plugin will typically fail when producing Haddock documentation. However, +-- in this instance you can simply tell it to defer any errors to runtime (which +-- will never happen since you're building documentation). +-- +-- So, any package using 'PlutusTx.compile' in the code for which you need to +-- generate haddock documentation should use the following 'haddock-options'. +package plutus-ledger + haddock-options: "--optghc=-fplugin-opt PlutusTx.Plugin:defer-errors" +package plutus-script-utils + haddock-options: "--optghc=-fplugin-opt PlutusTx.Plugin:defer-errors" +package plutus-contract + haddock-options: "--optghc=-fplugin-opt PlutusTx.Plugin:defer-errors" + +-- These packages appear in our dependency tree and are very slow to build. +-- Empirically, turning off optimization shaves off ~50% build time. +-- It also mildly improves recompilation avoidance. +-- For dev work we don't care about performance so much, so this is okay. +package cardano-ledger-alonzo + optimization: False +package ouroboros-consensus-shelley + optimization: False +package ouroboros-consensus-cardano + optimization: False +package cardano-api + optimization: False +package cardano-wallet + optimization: False +package cardano-wallet-core + optimization: False +package cardano-wallet-cli + optimization: False +package cardano-wallet-launcher + optimization: False +package cardano-wallet-core-integration + optimization: False + source-repository-package type: git - location: https://github.com/input-output-hk/plutus-apps.git + location: https://github.com/input-output-hk/plutus-apps + tag: 5ff40dafcdb07483442093efb4eaa39d12f34880 subdir: freer-extras + pab-blockfrost playground-common - plutus-contract plutus-chain-index + plutus-chain-index-core + plutus-contract + plutus-contract-certification plutus-ledger + plutus-ledger-constraints plutus-pab + plutus-script-utils plutus-use-cases - quickcheck-dynamic - tag: plutus-starter-devcontainer/v1.0.14 + rewindable-index +source-repository-package + type: git + location: https://github.com/blockfrost/blockfrost-haskell + tag: v0.4.0.0 + subdir: + blockfrost-api + blockfrost-client + blockfrost-client-core + blockfrost-pretty -- The following sections are copied from the 'plutus-apps' repository cabal.project at the revision -- given above. @@ -30,75 +101,84 @@ source-repository-package -- not on Hackage, and so need to be pulled in as `source-repository-package`s themselves. Make sure to -- re-update this section from the template when you do an upgrade. --- We never, ever, want this. -write-ghc-environment-files: never - --- Always build tests and benchmarks. -tests: true -benchmarks: true +-- Direct dependency. +-- Compared to others, cardano-wallet doesn't bump dependencies very often. +-- Making it a good place to start when bumping dependencies. +-- As, for example, bumping the node first highly risks breaking API with the wallet. +-- Unless early bug fixes are required, this is fine as the wallet tracks stable releases of the node. +-- And it is indeed nice for plutus-apps to track stable releases of the node too. +-- +-- The current version is dated 2022/08/10 +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-wallet + tag: 18a931648550246695c790578d4a55ee2f10463e + subdir: + lib/cli + lib/core + lib/core-integration + lib/dbvar + lib/launcher + lib/numeric + lib/shelley + lib/strict-non-empty-containers + lib/test-utils + lib/text-class --- The only sensible test display option -test-show-details: streaming +-- Direct dependency. +source-repository-package + type: git + location: https://github.com/input-output-hk/servant-purescript + tag: 44e7cacf109f84984cd99cd3faf185d161826963 -allow-newer: - -- Copied from plutus-core - size-based:template-haskell - , ouroboros-consensus-byron:formatting - , beam-core:aeson - , beam-sqlite:aeson - , beam-sqlite:dlist - , beam-migrate:aeson - --- Copied from plutus-core -constraints: - -- big breaking change here, inline-r doens't have an upper bound - singletons < 3.0 - -- bizarre issue: in earlier versions they define their own 'GEq', in newer - -- ones they reuse the one from 'some', but there isn't e.g. a proper version - -- constraint from dependent-sum-template (which is the library we actually use). - , dependent-sum > 0.6.2.0 +-- Direct dependency. +source-repository-package + type: git + location: https://github.com/input-output-hk/purescript-bridge + tag: 47a1f11825a0f9445e0f98792f79172efef66c00 --- These packages appear in our dependency tree and are very slow to build. --- Empirically, turning off optimization shaves off ~50% build time. --- It also mildly improves recompilation avoidance. --- For deve work we don't care about performance so much, so this is okay. -package cardano-ledger-alonzo - optimization: False -package ouroboros-consensus-shelley - optimization: False -package ouroboros-consensus-cardano - optimization: False -package cardano-api - optimization: False +-- Direct dependency. +source-repository-package + type: git + location: https://github.com/input-output-hk/quickcheck-dynamic + tag: c272906361471d684440f76c297e29ab760f6a1e --- Copied from plutus-core +-- TODO This is a compatibility shim to make it easier for our library dependencies to +-- be compatible with both aeson 1 & 2. Once downstream projects are all upgraded to +-- work with aeson-2, library dependencies will need to be updated to no longer use +-- this compatibility shim and have bounds to indicate they work with aeson-2 only. +-- After this, the dependency to hw-aeson can be dropped. source-repository-package type: git - location: https://github.com/Quid2/flat.git - tag: ee59880f47ab835dbd73bea0847dab7869fc20d8 + location: https://github.com/sevanspowell/hw-aeson + tag: b5ef03a7d7443fcd6217ed88c335f0c411a05408 --- Needs some patches, but upstream seems to be fairly dead (no activity in > 1 year) +-- Using a fork until our patches can be merged upstream source-repository-package type: git - location: https://github.com/input-output-hk/purescript-bridge.git - tag: 6a92d7853ea514be8b70bab5e72077bf5a510596 + location: https://github.com/input-output-hk/optparse-applicative + tag: 7497a29cb998721a9068d5725d49461f2bba0e7a +-- Should follow cardano-wallet. source-repository-package type: git - location: https://github.com/input-output-hk/servant-purescript.git - tag: a0c7c7e37c95564061247461aef4be505a853538 + location: https://github.com/input-output-hk/Win32-network + tag: 3825d3abf75f83f406c1f7161883c438dac7277d --- Copied from plutus-core +-- Should follow cardano-wallet. source-repository-package type: git - location: https://github.com/input-output-hk/cardano-crypto.git - tag: 07397f0e50da97eaa0575d93bee7ac4b2b2576ec + location: https://github.com/input-output-hk/cardano-addresses + tag: b7273a5d3c21f1a003595ebf1e1f79c28cd72513 + subdir: + command-line + core --- Copied from plutus-core +-- Should follow cardano-wallet. source-repository-package type: git location: https://github.com/input-output-hk/cardano-base - tag: 4ea7e2d927c9a7f78ddc69738409a5827ab66b98 + tag: 0f3a867493059e650cda69e20a5cbf1ace289a57 subdir: base-deriving-via binary @@ -111,148 +191,182 @@ source-repository-package slotting strict-containers --- Copied from plutus-core -source-repository-package - type: git - location: https://github.com/input-output-hk/cardano-prelude - tag: fd773f7a58412131512b9f694ab95653ac430852 - subdir: - cardano-prelude - cardano-prelude-test - +-- Should follow cardano-wallet. source-repository-package type: git - location: https://github.com/input-output-hk/cardano-addresses - tag: d2f86caa085402a953920c6714a0de6a50b655ec - subdir: - core + location: https://github.com/input-output-hk/cardano-crypto + tag: f73079303f663e028288f9f4a9e08bcca39a923e +-- Should follow cardano-node. +-- But in case there are failures with the plutus version, update to the latest +-- commit hash of the release/1.0.0 plutus branch. source-repository-package type: git - location: https://github.com/input-output-hk/cardano-wallet - tag: ae7569293e94241ef6829139ec02bd91abd069df + location: https://github.com/input-output-hk/plutus + tag: a56c96598b4b25c9e28215214d25189331087244 subdir: - lib/text-class - lib/strict-non-empty-containers - lib/core - lib/test-utils - lib/numeric + plutus-core + plutus-ledger-api + plutus-tx + plutus-tx-plugin + prettyprinter-configurable + stubs/plutus-ghc-stub + word-array +-- Should follow cardano-node source-repository-package type: git - location: https://github.com/input-output-hk/ouroboros-network - tag: 1f4973f36f689d6da75b5d351fb124d66ef1057d - subdir: - monoidal-synchronisation - typed-protocols - typed-protocols-cborg - typed-protocols-examples - ouroboros-network - ouroboros-network-testing - ouroboros-network-framework - ouroboros-consensus - ouroboros-consensus-byron - ouroboros-consensus-cardano - ouroboros-consensus-shelley - io-sim - io-classes - network-mux - ntp-client + location: https://github.com/input-output-hk/ekg-forward + tag: 297cd9db5074339a2fb2e5ae7d0780debb670c63 +-- Should follow cardano-node source-repository-package type: git - location: https://github.com/input-output-hk/iohk-monitoring-framework - -- Important Note: Read below, before changing this! - tag: 46f994e216a1f8b36fe4669b47b2a7011b0e153c - -- Are you thinking of updating this tag to some other commit? Please - -- ensure that the commit you are about to use is the latest one from - -- the *develop* branch of this repo: - -- * - -- (not master!) - -- - -- In particular we rely on the code from this PR: - -- * - -- being merged. - subdir: - iohk-monitoring - tracer-transformers - contra-tracer - plugins/backend-aggregation - plugins/backend-ekg - plugins/backend-monitoring - plugins/backend-trace-forwarder - plugins/scribe-systemd + location: https://github.com/input-output-hk/cardano-config + tag: 1646e9167fab36c0bff82317743b96efa2d3adaa +-- Should follow cardano-wallet. source-repository-package type: git - location: https://github.com/input-output-hk/cardano-ledger-specs - tag: bf008ce028751cae9fb0b53c3bef20f07c06e333 + location: https://github.com/input-output-hk/cardano-ledger + tag: c7c63dabdb215ebdaed8b63274965966f2bf408f subdir: - byron/ledger/impl - cardano-ledger-core - cardano-protocol-tpraos eras/alonzo/impl + eras/alonzo/test-suite + eras/babbage/impl + eras/babbage/test-suite eras/byron/chain/executable-spec eras/byron/crypto eras/byron/crypto/test eras/byron/ledger/executable-spec + eras/byron/ledger/impl eras/byron/ledger/impl/test - eras/shelley/impl eras/shelley-ma/impl + eras/shelley-ma/test-suite + eras/shelley/impl + eras/shelley/test-suite + libs/cardano-data + libs/cardano-ledger-core + libs/cardano-ledger-pretty + libs/cardano-protocol-tpraos libs/non-integral + libs/set-algebra libs/small-steps - semantics/small-steps-test + libs/small-steps-test + libs/vector-map --- A lot of plutus-apps dependencies have to be synchronized with the dependencies of --- cardano-node. If you update cardano-node, please make sure that all dependencies --- of cardano-node are also updated. +-- Should follow cardano-wallet. +-- More precisally, this should be a version compatible with the current +-- Cardano mainnet (>=1.35). source-repository-package type: git - location: https://github.com/input-output-hk/cardano-node.git - tag: b6ca519f97a0e795611a63174687e6bb70c9f752 + location: https://github.com/input-output-hk/cardano-node + tag: 1.35.3 subdir: cardano-api - cardano-node cardano-cli - cardano-config + cardano-git-rev + cardano-node + cardano-submit-api + cardano-testnet + trace-dispatcher + trace-forward + trace-resources +-- Should follow cardano-wallet. source-repository-package type: git - location: https://github.com/input-output-hk/optparse-applicative - tag: 7497a29cb998721a9068d5725d49461f2bba0e7a + location: https://github.com/input-output-hk/cardano-prelude + tag: bb4ed71ba8e587f672d06edf9d2e376f4b055555 + subdir: + cardano-prelude + cardano-prelude-test +-- Should follow cardano-wallet. source-repository-package type: git - location: https://github.com/input-output-hk/Win32-network - tag: 3825d3abf75f83f406c1f7161883c438dac7277d + location: https://github.com/input-output-hk/goblins + tag: cde90a2b27f79187ca8310b6549331e59595e7ba +-- Direct dependency. +-- Are you thinking of updating this tag to some other commit? +-- Please ensure that the commit you are about to use is the latest one from +-- the *develop* branch of this repo: +-- * +-- (not master!) +-- +-- In particular we rely on the code from this PR: +-- * +-- being merged. source-repository-package type: git - location: https://github.com/input-output-hk/goblins - tag: cde90a2b27f79187ca8310b6549331e59595e7ba + location: https://github.com/input-output-hk/iohk-monitoring-framework + tag: 066f7002aac5a0efc20e49643fea45454f226caa + subdir: + contra-tracer + iohk-monitoring + plugins/backend-aggregation + plugins/backend-ekg + plugins/backend-monitoring + plugins/backend-trace-forwarder + plugins/scribe-systemd + tracer-transformers --- A lot of plutus-apps dependencies have to be syncronized with the dependencies of --- plutus. If you update plutus, please make sure that all dependencies of plutus --- are also updated +-- Should follow cardano-wallet. source-repository-package type: git - location: https://github.com/input-output-hk/plutus - tag: 3f089ccf0ca746b399c99afe51e063b0640af547 + location: https://github.com/input-output-hk/ouroboros-network + tag: cb9eba406ceb2df338d8384b35c8addfe2067201 subdir: - plutus-core - plutus-ledger-api - plutus-tx - plutus-tx-plugin - word-array - prettyprinter-configurable - stubs/plutus-ghc-stub + monoidal-synchronisation + network-mux + ntp-client + ouroboros-consensus + ouroboros-consensus-byron + ouroboros-consensus-cardano + ouroboros-consensus-protocol + ouroboros-consensus-shelley + ouroboros-network + ouroboros-network-framework + ouroboros-network-testing +-- Should follow cardano-node. source-repository-package type: git - location: https://github.com/smart-chain-fr/blockfrost-haskell - tag: 175cf5da3c173f89dbeec06c64d136be215d2439 + location: https://github.com/input-output-hk/io-sim + tag: 57e888b1894829056cb00b7b5785fdf6a74c3271 subdir: - blockfrost-client - blockfrost-api - blockfrost-client-core - blockfrost-pretty \ No newline at end of file + io-classes + io-sim + strict-stm + +-- Should follow cardano-node. +source-repository-package + type: git + location: https://github.com/input-output-hk/typed-protocols + tag: 181601bc3d9e9d21a671ce01e0b481348b3ca104 + subdir: + typed-protocols + typed-protocols-cborg + typed-protocols-examples + +-- Should follow plutus. +-- https://github.com/Quid2/flat/pull/22 fixes a potential exception +-- when decoding invalid (e.g. malicious) text literals. +source-repository-package + type: git + location: https://github.com/Quid2/flat + tag: ee59880f47ab835dbd73bea0847dab7869fc20d8 + +-- Should follow cardano-wallet. +-- Until https://github.com/tibbe/ekg-json/pull/12 gets merged with aeson2 support +source-repository-package + type: git + location: https://github.com/vshabanov/ekg-json + tag: 00ebe7211c981686e65730b7144fbf5350462608 + +-- Should follow cardano-wallet +source-repository-package + type: git + location: https://github.com/input-output-hk/hedgehog-extras + tag: 714ee03a5a786a05fc57ac5d2f1c2edce4660d85 diff --git a/nix/pkgs/haskell/haskell.nix b/nix/pkgs/haskell/haskell.nix index 173195a1..7a8c2c02 100644 --- a/nix/pkgs/haskell/haskell.nix +++ b/nix/pkgs/haskell/haskell.nix @@ -19,29 +19,37 @@ let inherit compiler-nix-name; sha256map = { - "https://github.com/input-output-hk/plutus-apps.git"."plutus-starter-devcontainer/v1.0.14" = "0j3hphj4b21vwdj900233d67qsaj91mppwsx1vv0ichnmnw2bmir"; - "https://github.com/Quid2/flat.git"."ee59880f47ab835dbd73bea0847dab7869fc20d8" = "1lrzknw765pz2j97nvv9ip3l1mcpf2zr4n56hwlz0rk7wq7ls4cm"; - "https://github.com/input-output-hk/purescript-bridge.git"."6a92d7853ea514be8b70bab5e72077bf5a510596" = "13j64vv116in3c204qsl1v0ajphac9fqvsjp7x3zzfr7n7g61drb"; - "https://github.com/input-output-hk/servant-purescript.git"."a0c7c7e37c95564061247461aef4be505a853538" = "177na04jf6wf18kandzsah40lw3xswmmccpr3hkb8wb4hypcffnf"; - "https://github.com/input-output-hk/cardano-base"."4ea7e2d927c9a7f78ddc69738409a5827ab66b98" = "0n0hxbr0l95cdc25jmmgs7apmmw17i91chhj5rzzv1k7f3iymf6d"; - "https://github.com/input-output-hk/cardano-crypto.git"."07397f0e50da97eaa0575d93bee7ac4b2b2576ec" = "06sdx5ndn2g722jhpicmg96vsrys89fl81k8290b3lr6b1b0w4m3"; - "https://github.com/input-output-hk/cardano-ledger-specs"."bf008ce028751cae9fb0b53c3bef20f07c06e333" = "0my3801w1vinc0kf5yh9lxl6saqxgwm6ccg0vvzi104pafcwwcqx"; - "https://github.com/input-output-hk/cardano-prelude"."fd773f7a58412131512b9f694ab95653ac430852" = "02jddik1yw0222wd6q0vv10f7y8rdgrlqaiy83ph002f9kjx7mh6"; - "https://github.com/input-output-hk/goblins"."cde90a2b27f79187ca8310b6549331e59595e7ba" = "17c88rbva3iw82yg9srlxjv2ia5wjb9cyqw44hik565f5v9svnyg"; - "https://github.com/input-output-hk/iohk-monitoring-framework"."46f994e216a1f8b36fe4669b47b2a7011b0e153c" = "1il8fx3misp3650ryj368b3x95ksz01zz3x0z9k00807j93d0ka0"; + "https://github.com/input-output-hk/plutus-apps"."5ff40dafcdb07483442093efb4eaa39d12f34880" = "sha256-QjPVzU11a5izlir6BFzStds+UPBTlGgd4PfD+mlHz4M="; + "https://github.com/blockfrost/blockfrost-haskell"."v0.4.0.0" = "sha256-3DIl6XBfoOQQ20JYA1EozN+j+7ahgTpFbb6a2LsMBPE="; + "https://github.com/input-output-hk/cardano-wallet"."18a931648550246695c790578d4a55ee2f10463e" = "sha256-3Rnj/g3KLzOW5YSieqsUa9IF1Td22Eskk5KuVsOFgEQ="; + "https://github.com/input-output-hk/servant-purescript"."44e7cacf109f84984cd99cd3faf185d161826963" = "sha256-DH9ISydu5gxvN4xBuoXVv1OhYCaqGOtzWlACdJ0H64I="; + "https://github.com/input-output-hk/purescript-bridge"."47a1f11825a0f9445e0f98792f79172efef66c00" = "sha256-/SbnmXrB9Y2rrPd6E79Iu5RDaKAKozIl685HQ4XdQTU="; + "https://github.com/input-output-hk/quickcheck-dynamic"."c272906361471d684440f76c297e29ab760f6a1e" = "sha256-TioJQASNrQX6B3n2Cv43X2olyT67//CFQqcpvNW7N60="; + "https://github.com/sevanspowell/hw-aeson"."b5ef03a7d7443fcd6217ed88c335f0c411a05408" = "sha256-v0SyVxeVBTtW1tuej4P+Kf4roO/rr2tBI7RthTlInbc="; "https://github.com/input-output-hk/optparse-applicative"."7497a29cb998721a9068d5725d49461f2bba0e7a" = "1gvsrg925vynwgqwplgjmp53vj953qyh3wbdf34pw21c8r47w35r"; - "https://github.com/input-output-hk/ouroboros-network"."1f4973f36f689d6da75b5d351fb124d66ef1057d" = "186056rvzdzy4jhvamjjbcmjyr94hs5hcyr8x6a0ch21hv5f014p"; - "https://github.com/input-output-hk/cardano-node.git"."b6ca519f97a0e795611a63174687e6bb70c9f752" = "0z5lpmqc98fwg3xzpzxkfslbxdjwfyyw8bn8yq0574sf4942vqdn"; "https://github.com/input-output-hk/Win32-network"."3825d3abf75f83f406c1f7161883c438dac7277d" = "19wahfv726fa3mqajpqdqhnl9ica3xmf68i254q45iyjcpj1psqx"; - "https://github.com/input-output-hk/hedgehog-extras"."edf6945007177a638fbeb8802397f3a6f4e47c14" = "0wc7qzkc7j4ns2rz562h6qrx2f8xyq7yjcb7zidnj7f6j0pcd0i9"; - "https://github.com/input-output-hk/cardano-wallet"."ae7569293e94241ef6829139ec02bd91abd069df" = "1mv1dhpkdj9ridm1fvq6jc85qs6zvbp172228rq72gyawjwrgvi6"; - "https://github.com/input-output-hk/cardano-addresses"."d2f86caa085402a953920c6714a0de6a50b655ec" = "0p6jbnd7ky2yf7bwb1350k8880py8dgqg39k49q02a6ij4ld01ay"; - "https://github.com/input-output-hk/plutus"."3f089ccf0ca746b399c99afe51e063b0640af547" = "1nx8xmdgwmnsla4qg4k67f5md8vm3p1p9i25ndalrqdg40z90486"; - "https://github.com/smart-chain-fr/blockfrost-haskell"."175cf5da3c173f89dbeec06c64d136be215d2439" = "0x0529rl99jsvkcy28m7bg5lq2z7yjj8pbcc0yz1lkfccnmpv7g1"; + "https://github.com/input-output-hk/cardano-addresses"."b7273a5d3c21f1a003595ebf1e1f79c28cd72513" = "sha256-91F9+ckA3lBCE4dAVLDnMSpwRLa7zRUEEBYEHv0sOYk="; + "https://github.com/input-output-hk/cardano-base"."0f3a867493059e650cda69e20a5cbf1ace289a57" = "sha256-4b0keLjRaVSdEwfBXB1iT3QPlsutdxSltGfBufT4Clw="; + "https://github.com/input-output-hk/cardano-crypto"."f73079303f663e028288f9f4a9e08bcca39a923e" = "sha256-2Fipex/WjIRMrvx6F3hjJoAeMtFd2wGnZECT0kuIB9k="; + "https://github.com/input-output-hk/plutus"."a56c96598b4b25c9e28215214d25189331087244" = "sha256-coD/Kpl7tutwXb6ukQCH5XojBjquYkW7ob0BWZtdpok="; + "https://github.com/input-output-hk/ekg-forward"."297cd9db5074339a2fb2e5ae7d0780debb670c63" = "sha256-jwj/gh/A/PXhO6yVESV27k4yx9I8Id8fTa3m4ofPnP0="; + "https://github.com/input-output-hk/cardano-config"."1646e9167fab36c0bff82317743b96efa2d3adaa" = "sha256-TNbpnR7llUgBN2WY7CryMxNVupBIUH01h1hRNHoxboY="; + "https://github.com/input-output-hk/cardano-ledger"."c7c63dabdb215ebdaed8b63274965966f2bf408f" = "sha256-zTQbMOGPD1Oodv6VUsfF6NUiXkbN8SWI98W3Atv4wbI="; + "https://github.com/input-output-hk/cardano-node"."1.35.3" = "020fwimsm24yblr1fmnwx240wj8r3x715p89cpjgnnd8axwf32p0"; + "https://github.com/input-output-hk/cardano-prelude"."bb4ed71ba8e587f672d06edf9d2e376f4b055555" = "sha256-kgX3DKyfjBb8/XcDEd+/adlETsFlp5sCSurHWgsFAQI="; + "https://github.com/input-output-hk/goblins"."cde90a2b27f79187ca8310b6549331e59595e7ba" = "17c88rbva3iw82yg9srlxjv2ia5wjb9cyqw44hik565f5v9svnyg"; + "https://github.com/input-output-hk/iohk-monitoring-framework"."066f7002aac5a0efc20e49643fea45454f226caa" = "sha256-0ia5UflYEmBYepj2gkJy9msknklI0UPtUavMEGwk3Wg="; + "https://github.com/input-output-hk/ouroboros-network"."cb9eba406ceb2df338d8384b35c8addfe2067201" = "sha256-3ElbHM1B5u1QD0aes1KbaX2FxKJzU05H0OzJ36em1Bg="; + "https://github.com/input-output-hk/io-sim"."57e888b1894829056cb00b7b5785fdf6a74c3271" = "sha256-TviSvCBEYtlKEo9qJmE8pCE25nMjDi8HeIAFniunaM8="; + "https://github.com/input-output-hk/typed-protocols"."181601bc3d9e9d21a671ce01e0b481348b3ca104" = "sha256-5Wof5yTKb12EPY6B8LfapX18xNZZpF+rvhnQ88U6KdM="; + "https://github.com/Quid2/flat"."ee59880f47ab835dbd73bea0847dab7869fc20d8" = "1lrzknw765pz2j97nvv9ip3l1mcpf2zr4n56hwlz0rk7wq7ls4cm"; + "https://github.com/vshabanov/ekg-json"."00ebe7211c981686e65730b7144fbf5350462608" = "sha256-VT8Ur585TCn03P2TVi6t92v2Z6tl8vKijICjse6ocv8="; + "https://github.com/input-output-hk/hedgehog-extras"."714ee03a5a786a05fc57ac5d2f1c2edce4660d85" = "sha256-6KQFEzb9g2a0soVvwLKESEbA+a8ygpROcMr6bkatROE="; }; modules = [ { + enableLibraryProfiling = true; packages = { # Broken due to haddock errors. Refer to https://github.com/input-output-hk/plutus/blob/master/nix/pkgs/haskell/haskell.nix plutus-ledger.doHaddock = false; @@ -55,4 +63,4 @@ let ]; }; in - project \ No newline at end of file + project diff --git a/nix/sources.json b/nix/sources.json index 57108282..c07decb0 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -5,10 +5,10 @@ "homepage": "", "owner": "input-output-hk", "repo": "plutus", - "rev": "plutus-starter-devcontainer/v1.0.10", - "sha256": "06c3jhsbjmzqv951yi1spq1jihija48vss2b8gx9b1fqnz50dbnm", + "rev": "a56c96598b4b25c9e28215214d25189331087244", + "sha256": "12d6bndmj0dxl6xlaqmf78326yp5hw093bmybmqfpdkvk4mgz03j", "type": "tarball", - "url": "https://github.com/input-output-hk/plutus/archive/plutus-starter-devcontainer/v1.0.10.tar.gz", + "url": "https://github.com/input-output-hk/plutus/archive/a56c96598b4b25c9e28215214d25189331087244.tar.gz", "url_template": "https://github.com///archive/.tar.gz" } -} \ No newline at end of file +} diff --git a/src/Tokenomia/CardanoApi/Arbitrary/Slot.hs b/src/Tokenomia/CardanoApi/Arbitrary/Slot.hs index 66285a7d..c7788296 100644 --- a/src/Tokenomia/CardanoApi/Arbitrary/Slot.hs +++ b/src/Tokenomia/CardanoApi/Arbitrary/Slot.hs @@ -6,12 +6,14 @@ import Cardano.Api import Test.Tasty.QuickCheck ( Arbitrary + , Small(..) , arbitrary , genericShrink + , resize , shrink ) instance Arbitrary SlotNo where - arbitrary = SlotNo <$> arbitrary + arbitrary = SlotNo . getSmall <$> resize 128 arbitrary shrink = genericShrink diff --git a/src/Tokenomia/CardanoApi/FromPlutus/Value.hs b/src/Tokenomia/CardanoApi/FromPlutus/Value.hs index 7eddbe8a..b389369e 100644 --- a/src/Tokenomia/CardanoApi/FromPlutus/Value.hs +++ b/src/Tokenomia/CardanoApi/FromPlutus/Value.hs @@ -24,7 +24,7 @@ import Cardano.Api ) import PlutusTx.Builtins ( fromBuiltin ) -import Plutus.V1.Ledger.Ada ( adaSymbol, adaToken ) +import Plutus.V1.Ledger.Value ( adaSymbol, adaToken ) import Plutus.V1.Ledger.Value qualified as Plutus ( Value ) import Plutus.V1.Ledger.Value diff --git a/src/Tokenomia/Common/Arbitrary/AssetClass.hs b/src/Tokenomia/Common/Arbitrary/AssetClass.hs index 9db8acfe..2eb0fc23 100644 --- a/src/Tokenomia/Common/Arbitrary/AssetClass.hs +++ b/src/Tokenomia/Common/Arbitrary/AssetClass.hs @@ -8,18 +8,17 @@ module Tokenomia.Common.Arbitrary.AssetClass () where import Data.String ( fromString ) -import Plutus.V1.Ledger.Ada ( adaSymbol, adaToken ) import Plutus.V1.Ledger.Value ( AssetClass(..) , CurrencySymbol (..) , TokenName (..) + , adaSymbol + , adaToken , assetClass ) import Test.Tasty.QuickCheck ( Arbitrary - , CoArbitrary - , Function , arbitrary , frequency , resize @@ -43,14 +42,6 @@ instance Arbitrary AssetClass where arbitrary = AssetClass <$> arbitrary shrink x = AssetClass <$> shrink (unAssetClass x) -instance CoArbitrary CurrencySymbol -instance CoArbitrary TokenName -instance CoArbitrary AssetClass - -instance Function CurrencySymbol -instance Function TokenName -instance Function AssetClass - instance Arbitrary (Restricted CurrencySymbol) where arbitrary = frequency [ (3, pure $ Restricted adaSymbol) diff --git a/src/Tokenomia/Common/Arbitrary/Builtins.hs b/src/Tokenomia/Common/Arbitrary/Builtins.hs index c016599d..3d28f185 100644 --- a/src/Tokenomia/Common/Arbitrary/Builtins.hs +++ b/src/Tokenomia/Common/Arbitrary/Builtins.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} module Tokenomia.Common.Arbitrary.Builtins @@ -22,8 +21,6 @@ import Tokenomia.Common.Data.ByteString ( unsafeDecodeHex, encode ) import Test.QuickCheck.Instances.ByteString () import Test.Tasty.QuickCheck ( Arbitrary - , CoArbitrary - , Function , Gen , arbitrary , elements @@ -48,9 +45,6 @@ instance Arbitrary BuiltinByteString where arbitrary = fromHexString <$> arbitrary shrink x = fromHexString <$> shrink (toHexString x) -instance CoArbitrary BuiltinByteString -instance Function BuiltinByteString - arbitraryHexSymbol :: Gen Char arbitraryHexSymbol = elements $ ['0'..'9'] ++ ['a' .. 'f'] diff --git a/src/Tokenomia/Common/Parser/Address.hs b/src/Tokenomia/Common/Parser/Address.hs index fe7cef04..069b5ba1 100644 --- a/src/Tokenomia/Common/Parser/Address.hs +++ b/src/Tokenomia/Common/Parser/Address.hs @@ -26,8 +26,8 @@ import Prelude hiding ( length ) import Plutus.Contract.CardanoAPI ( ToCardanoError - , fromCardanoAddress - , toCardanoAddress + , fromCardanoAddressInEra + , toCardanoAddressInEra ) import Cardano.Chain.Common ( decodeAddressBase58 ) @@ -36,12 +36,12 @@ import Cardano.Api.Byron qualified as Bryon ( Address(ByronAddress) ) import Cardano.Api - ( AsType(AsAddressInEra, AsAlonzoEra, AsByronEra) + ( AsType(AsAddressInEra, AsBabbageEra, AsByronEra) , IsCardanoEra , NetworkId , AddressInEra(AddressInEra) , AddressTypeInEra(ByronAddressInAnyEra) - , AlonzoEra + , BabbageEra , deserialiseAddress , serialiseAddress ) @@ -52,28 +52,26 @@ import Tokenomia.Common.Data.Convertible ( convert ) deserialiseAddressInEra :: forall (era :: Type). IsCardanoEra era => AsType era -> Text -> Either Text Address -deserialiseAddressInEra era address = do - cardanoAddress <- maybeToRight "deserialisation failed" $ - deserialiseAddress (AsAddressInEra era) address - mapLeft (const "not a cardano address") $ - fromCardanoAddress cardanoAddress +deserialiseAddressInEra era address = + maybeToRight "deserialisation failed" $ fromCardanoAddressInEra + <$> deserialiseAddress (AsAddressInEra era) address deserialiseCardanoAddress :: Text -> Either Text Address deserialiseCardanoAddress address - | "addr" `isPrefixOf` address = deserialiseAddressInEra AsAlonzoEra address + | "addr" `isPrefixOf` address = deserialiseAddressInEra AsBabbageEra address | otherwise = deserialiseAddressInEra AsByronEra address -serialiseAlonzoAddress :: NetworkId -> Address -> Either Text (AddressInEra AlonzoEra) -serialiseAlonzoAddress networdId address = +serialiseBabbageAddress :: NetworkId -> Address -> Either Text (AddressInEra BabbageEra) +serialiseBabbageAddress networdId address = mapLeft showError $ - toCardanoAddress networdId address + toCardanoAddressInEra networdId address where showError :: ToCardanoError -> Text showError err = (convert . show . pretty $ err) <> (convert . show $ address) -serialiseByronAddress :: Address -> Either Text (AddressInEra AlonzoEra) +serialiseByronAddress :: Address -> Either Text (AddressInEra BabbageEra) serialiseByronAddress (Address (PubKeyCredential (PubKeyHash bytes)) _) = do base58 <- mapLeft (convert . show) $ @@ -86,7 +84,7 @@ serialiseCardanoAddress _ address@(Address (PubKeyCredential (PubKeyHash bytes)) | length bytes > 28 = serialiseAddress <$> serialiseByronAddress address serialiseCardanoAddress networkId address = - serialiseAddress <$> serialiseAlonzoAddress networkId address + serialiseAddress <$> serialiseBabbageAddress networkId address unsafeSerialiseCardanoAddress :: NetworkId -> Address -> Text unsafeSerialiseCardanoAddress networkId address = diff --git a/src/Tokenomia/Common/Parser/TxOutRef.hs b/src/Tokenomia/Common/Parser/TxOutRef.hs index aaa0d571..2579cd98 100644 --- a/src/Tokenomia/Common/Parser/TxOutRef.hs +++ b/src/Tokenomia/Common/Parser/TxOutRef.hs @@ -16,8 +16,7 @@ import Prelude hiding ( take ) import Data.Char ( isSpace ) import Data.String ( fromString ) -import Ledger ( TxOutRef(TxOutRef) ) -import Ledger.TxId ( TxId ) +import Ledger ( TxOutRef(TxOutRef), TxId ) txOutRef :: Parser TxOutRef diff --git a/src/Tokenomia/Common/Token.hs b/src/Tokenomia/Common/Token.hs index 306f53be..21fe5e62 100644 --- a/src/Tokenomia/Common/Token.hs +++ b/src/Tokenomia/Common/Token.hs @@ -9,7 +9,7 @@ module Tokenomia.Common.Token , getMinimumUTxOAdaRequired) where import Plutus.V1.Ledger.Value hiding (assetClass) -import Plutus.V1.Ledger.Ada +import Ledger.Ada import Tokenomia.ICO.Balanceable data Token diff --git a/src/Tokenomia/ICO/Funds/Exchange/CardanoCLI/Command.hs b/src/Tokenomia/ICO/Funds/Exchange/CardanoCLI/Command.hs index 400e041b..e4a04ad3 100644 --- a/src/Tokenomia/ICO/Funds/Exchange/CardanoCLI/Command.hs +++ b/src/Tokenomia/ICO/Funds/Exchange/CardanoCLI/Command.hs @@ -9,7 +9,7 @@ {-# LANGUAGE NamedFieldPuns #-} module Tokenomia.ICO.Funds.Exchange.CardanoCLI.Command ( Command (..)) where -import Plutus.V1.Ledger.Ada +import Ledger.Ada import Ledger ( Slot(..) ) import Tokenomia.Wallet.UTxO @@ -126,4 +126,4 @@ getTokenAmount RefundBecauseTokensSoldOut {} = 0 getTokenAmount MoveToNextRoundBecauseTokensSoldOut {} = 0 getTokenAmount Exchange {tokens = Token {..}} = amount getTokenAmount ExchangeAndPartiallyRefund {tokens = Token {..}} = amount -getTokenAmount ExchangeAndPartiallyMoveToNextRound {tokens = Token {..}} = amount \ No newline at end of file +getTokenAmount ExchangeAndPartiallyMoveToNextRound {tokens = Token {..}} = amount diff --git a/src/Tokenomia/ICO/Funds/Exchange/Command.hs b/src/Tokenomia/ICO/Funds/Exchange/Command.hs index a4db90ab..cbe3e602 100644 --- a/src/Tokenomia/ICO/Funds/Exchange/Command.hs +++ b/src/Tokenomia/ICO/Funds/Exchange/Command.hs @@ -15,7 +15,7 @@ module Tokenomia.ICO.Funds.Exchange.Command import Prelude hiding (round,print) -import Plutus.V1.Ledger.Ada +import Ledger.Ada import Ledger ( Slot(..) ) @@ -91,4 +91,4 @@ getTokensSum xs = sum (getTokenAmount <$> toAscList xs) getTokenAmount :: Command -> Integer getTokenAmount RejectBecauseTokensSoldOut {} = 0 getTokenAmount Exchange {tokens = Token {..}} = amount -getTokenAmount ExchangeAndPartiallyReject {tokens = Token {..}} = amount \ No newline at end of file +getTokenAmount ExchangeAndPartiallyReject {tokens = Token {..}} = amount diff --git a/src/Tokenomia/ICO/Funds/Validation/CardanoCLI/Command.hs b/src/Tokenomia/ICO/Funds/Validation/CardanoCLI/Command.hs index 86a61d93..99d4e8d0 100644 --- a/src/Tokenomia/ICO/Funds/Validation/CardanoCLI/Command.hs +++ b/src/Tokenomia/ICO/Funds/Validation/CardanoCLI/Command.hs @@ -11,7 +11,7 @@ module Tokenomia.ICO.Funds.Validation.CardanoCLI.Command import Prelude hiding (round,print) -import Plutus.V1.Ledger.Ada +import Ledger.Ada import Ledger ( Slot(..) ) import Tokenomia.Wallet.UTxO diff --git a/src/Tokenomia/ICO/Funds/Validation/ChildAddress/State.hs b/src/Tokenomia/ICO/Funds/Validation/ChildAddress/State.hs index 03425646..f9e486b1 100644 --- a/src/Tokenomia/ICO/Funds/Validation/ChildAddress/State.hs +++ b/src/Tokenomia/ICO/Funds/Validation/ChildAddress/State.hs @@ -20,7 +20,7 @@ module Tokenomia.ICO.Funds.Validation.ChildAddress.State import Prelude hiding (round,print) import Data.Set.Ordered as OS ( fromList, OSet, filter ) -import Plutus.V1.Ledger.Ada ( Ada(..) ) +import Ledger.Ada ( Ada(..) ) import Ledger.Ada as Ada ( lovelaceOf ) @@ -168,4 +168,3 @@ fetchAddressVolumes (Address addr) = do filterOnlyLovelaces :: Amount -> Ada filterOnlyLovelaces (AdaAmount x) = Ada.lovelaceOf (fromIntegral x) filterOnlyLovelaces (AssetAmount _) = Ada.lovelaceOf 0 - diff --git a/src/Tokenomia/ICO/Funds/Validation/ChildAddress/Types.hs b/src/Tokenomia/ICO/Funds/Validation/ChildAddress/Types.hs index f8422c2c..1840a5d6 100644 --- a/src/Tokenomia/ICO/Funds/Validation/ChildAddress/Types.hs +++ b/src/Tokenomia/ICO/Funds/Validation/ChildAddress/Types.hs @@ -25,7 +25,7 @@ import Prelude hiding (round,print) import Data.List (intersperse) import Data.Set.Ordered ( OSet, toAscList ) -import Plutus.V1.Ledger.Ada ( Ada(Lovelace) ) +import Ledger.Ada ( Ada(Lovelace) ) import Ledger.Ada as Ada ( Ada(Lovelace) ) @@ -131,4 +131,4 @@ filterOnlyLovelaces (AssetAmount _) = 0 isNativeTokenFund :: ReceivedFunds -> Bool isNativeTokenFund ReceivedFunds {funds = Left _} = True -isNativeTokenFund _ = False \ No newline at end of file +isNativeTokenFund _ = False diff --git a/src/Tokenomia/ICO/Funds/Validation/Investor/Command.hs b/src/Tokenomia/ICO/Funds/Validation/Investor/Command.hs index b8ce49e8..81a3cb4c 100644 --- a/src/Tokenomia/ICO/Funds/Validation/Investor/Command.hs +++ b/src/Tokenomia/ICO/Funds/Validation/Investor/Command.hs @@ -21,7 +21,7 @@ module Tokenomia.ICO.Funds.Validation.Investor.Command import Prelude hiding (round,print) -import Plutus.V1.Ledger.Ada +import Ledger.Ada import Ledger ( Slot(..) ) @@ -124,4 +124,4 @@ getAdasToRejectBecauseOutOfRange _ = 0 getAdas:: Command -> Ada getAdas Reject {..} = amountToReject getAdas SendOnExchangeAddressWithPartialReject {..} = adasToSendOnExchange + amountToReject -getAdas SendOnExchangeAddress {..} = adasToSendOnExchange \ No newline at end of file +getAdas SendOnExchangeAddress {..} = adasToSendOnExchange diff --git a/src/Tokenomia/ICO/Funds/Validation/Investor/Plan.hs b/src/Tokenomia/ICO/Funds/Validation/Investor/Plan.hs index a11f4b62..62f00121 100644 --- a/src/Tokenomia/ICO/Funds/Validation/Investor/Plan.hs +++ b/src/Tokenomia/ICO/Funds/Validation/Investor/Plan.hs @@ -17,7 +17,7 @@ import Prelude hiding (round,print) import Data.Set.Ordered -import Plutus.V1.Ledger.Ada +import Ledger.Ada import Plutus.V1.Ledger.Interval as I import Tokenomia.ICO.Funds.Validation.Investor.Command as C @@ -103,8 +103,3 @@ transition sumAdaFunds :: [Command] -> Ada sumAdaFunds xs = sum (getAdas <$> xs) - - - - - diff --git a/src/Tokenomia/ICO/Funds/Validation/Investor/Plan/Settings.hs b/src/Tokenomia/ICO/Funds/Validation/Investor/Plan/Settings.hs index ee9de624..b449c0f6 100644 --- a/src/Tokenomia/ICO/Funds/Validation/Investor/Plan/Settings.hs +++ b/src/Tokenomia/ICO/Funds/Validation/Investor/Plan/Settings.hs @@ -14,7 +14,7 @@ import Prelude hiding (round,print) import Tokenomia.ICO.Round.Settings -import Plutus.V1.Ledger.Ada +import Ledger.Ada import Ledger ( Slot(..) ) import Plutus.V1.Ledger.Interval diff --git a/src/Tokenomia/ICO/LocalRepository.hs b/src/Tokenomia/ICO/LocalRepository.hs index feab5c8e..49291a0f 100644 --- a/src/Tokenomia/ICO/LocalRepository.hs +++ b/src/Tokenomia/ICO/LocalRepository.hs @@ -16,7 +16,7 @@ module Tokenomia.ICO.LocalRepository import Prelude hiding (round,print) -import Plutus.V1.Ledger.Ada +import Ledger.Ada import Plutus.V1.Ledger.Value import Plutus.V1.Ledger.Interval import Data.List.NonEmpty @@ -166,4 +166,3 @@ getPublicSaleSettings = do , tokens = tokens , adaSink = "DdzFFzCqrhsuG7R4n5w9vr2Zo6quuzVbqQbfcDm8BZV29p5T8yTfBnz4Jx3mmgsXCoDtjpCVyB61ttV4MVsVivnQHMKEzFozBHVE8Emq" , fees } }}) - diff --git a/src/Tokenomia/ICO/Round/Settings.hs b/src/Tokenomia/ICO/Round/Settings.hs index ed8a3832..68f726c7 100644 --- a/src/Tokenomia/ICO/Round/Settings.hs +++ b/src/Tokenomia/ICO/Round/Settings.hs @@ -27,7 +27,7 @@ module Tokenomia.ICO.Round.Settings import Prelude hiding (round,print) -import Plutus.V1.Ledger.Ada +import Ledger.Ada import Plutus.V1.Ledger.Value import Ledger ( Slot(..) ) import Plutus.V1.Ledger.Interval @@ -130,5 +130,3 @@ getRoundAddresses , fees = IndexedAddress {address = fees} , tokens = IndexedAddress {address = tokens}} = [exchange,fees,collateral,tokens] - - diff --git a/src/Tokenomia/Script/LocalRepository.hs b/src/Tokenomia/Script/LocalRepository.hs index 73fe7dcf..ea42e3d2 100644 --- a/src/Tokenomia/Script/LocalRepository.hs +++ b/src/Tokenomia/Script/LocalRepository.hs @@ -37,9 +37,10 @@ import Cardano.Api hiding (Testnet,Mainnet,Address,Hash) import qualified Cardano.Api.Shelley as Shelley -import Ledger hiding (Address) +import Ledger hiding (Address, scriptCurrencySymbol, validatorHash) import qualified Plutus.V1.Ledger.Scripts as Script +import Plutus.Script.Utils.V1.Scripts (scriptCurrencySymbol, validatorHash) import Tokenomia.Common.Environment import Tokenomia.Common.Folder (getFolderPath,Folder (..)) @@ -107,4 +108,3 @@ toPlutusScriptV1 . SBS.toShort . LB.toStrict . serialise - diff --git a/src/Tokenomia/Token/CLAPStyle/Mint.hs b/src/Tokenomia/Token/CLAPStyle/Mint.hs index f48694e8..d0a6977c 100644 --- a/src/Tokenomia/Token/CLAPStyle/Mint.hs +++ b/src/Tokenomia/Token/CLAPStyle/Mint.hs @@ -23,7 +23,8 @@ import qualified Data.ByteString.UTF8 as BSU import Control.Monad.Except -import Ledger hiding (mint,Address,Mint) +import Ledger hiding (mint, Address, Mint, Params, scriptCurrencySymbol) +import Plutus.Script.Utils.V1.Scripts (scriptCurrencySymbol) import qualified Ledger.Value as L import Ledger.Ada diff --git a/src/Tokenomia/Token/CLAPStyle/MonetaryPolicy.hs b/src/Tokenomia/Token/CLAPStyle/MonetaryPolicy.hs index 3bbe7748..6e3c0836 100644 --- a/src/Tokenomia/Token/CLAPStyle/MonetaryPolicy.hs +++ b/src/Tokenomia/Token/CLAPStyle/MonetaryPolicy.hs @@ -58,15 +58,16 @@ import Plutus.Contract.Wallet (getUnspentOutput) import Ledger ( TxOutRef(..), - scriptCurrencySymbol, pubKeyHashAddress, mkMintingPolicyScript, + PaymentPubKeyHash(..), PubKeyHash, MintingPolicy, CurrencySymbol, getCardanoTxId ) import qualified Ledger.Constraints as Constraints -import qualified Ledger.Contexts as V +import qualified Plutus.V1.Ledger.Contexts as V +import Plutus.Script.Utils.V1.Scripts (scriptCurrencySymbol) import PlutusTx ( BuiltinData, applyCode, liftCode, compile ) import qualified Ledger.Typed.Scripts as Scripts @@ -97,7 +98,7 @@ PlutusTx.makeLift ''Params mkMonetaryPolicyScript :: Params -> MintingPolicy mkMonetaryPolicyScript param = mkMintingPolicyScript $ - $$(PlutusTx.compile [|| \c -> Scripts.wrapMintingPolicy (monetaryPolicy c) ||]) + $$(PlutusTx.compile [|| Scripts.mkUntypedMintingPolicy . monetaryPolicy ||]) `PlutusTx.applyCode` PlutusTx.liftCode param @@ -153,10 +154,10 @@ burnContract burnerPK monetaryPolicyParams@Params {..} amountToBurn = let policyHash = (scriptCurrencySymbol . mkMonetaryPolicyScript) monetaryPolicyParams monetaryPolicyScript = mkMonetaryPolicyScript monetaryPolicyParams valueToBurn = singleton policyHash tokenName amountToBurn - utxosInBurnerWallet <- Contract.utxosAt (pubKeyHashAddress burnerPK) + utxosInBurnerWallet <- Contract.utxosAt (pubKeyHashAddress (PaymentPubKeyHash burnerPK) Haskell.Nothing) submitTxConstraintsWith @Scripts.Any - (Constraints.mintingPolicy monetaryPolicyScript <> Constraints.unspentOutputs utxosInBurnerWallet) + (Constraints.plutusV1MintingPolicy monetaryPolicyScript <> Constraints.unspentOutputs utxosInBurnerWallet) (Constraints.mustMintValue valueToBurn) >>= awaitTxConfirmed . getCardanoTxId @@ -177,12 +178,10 @@ mintContract pk tokenName amount = policyHash = (scriptCurrencySymbol . mkMonetaryPolicyScript) monetaryPolicyParams monetaryPolicyScript = mkMonetaryPolicyScript monetaryPolicyParams valueToMint = singleton policyHash tokenName amount - utxosInWallet <- utxosAt (pubKeyHashAddress pk) + utxosInWallet <- utxosAt (pubKeyHashAddress (PaymentPubKeyHash pk) Haskell.Nothing) submitTxConstraintsWith @Scripts.Any - (Constraints.mintingPolicy monetaryPolicyScript <> Constraints.unspentOutputs utxosInWallet) + (Constraints.plutusV1MintingPolicy monetaryPolicyScript <> Constraints.unspentOutputs utxosInWallet) (Constraints.mustSpendPubKeyOutput txOutRefToConsume <> Constraints.mustMintValue valueToMint) >>= awaitTxConfirmed . getCardanoTxId >> pure (policyHash,monetaryPolicyParams) - - diff --git a/src/Tokenomia/TokenDistribution/Parser/Address.hs b/src/Tokenomia/TokenDistribution/Parser/Address.hs index ac1fec23..52295d7a 100644 --- a/src/Tokenomia/TokenDistribution/Parser/Address.hs +++ b/src/Tokenomia/TokenDistribution/Parser/Address.hs @@ -26,8 +26,8 @@ import Prelude hiding ( length ) import Plutus.Contract.CardanoAPI ( ToCardanoError - , fromCardanoAddress - , toCardanoAddress + , fromCardanoAddressInEra + , toCardanoAddressInEra ) import Cardano.Chain.Common ( decodeAddressBase58 ) @@ -41,7 +41,7 @@ import Cardano.Api , NetworkId , AddressInEra(AddressInEra) , AddressTypeInEra(ByronAddressInAnyEra) - , AlonzoEra + , BabbageEra , deserialiseAddress , serialiseAddress ) @@ -53,27 +53,25 @@ deserialiseAddressInEra :: forall (era :: Type). IsCardanoEra era => AsType era -> Text -> Either Text Address deserialiseAddressInEra era address = do - cardanoAddress <- maybeToRight "deserialisation failed" $ - deserialiseAddress (AsAddressInEra era) address - mapLeft (const "not a cardano address") $ - fromCardanoAddress cardanoAddress + maybeToRight "deserialisation failed" $ fromCardanoAddressInEra + <$> deserialiseAddress (AsAddressInEra era) address deserialiseCardanoAddress :: Text -> Either Text Address deserialiseCardanoAddress address | "addr" `isPrefixOf` address = deserialiseAddressInEra AsAlonzoEra address | otherwise = deserialiseAddressInEra AsByronEra address -serialiseAlonzoAddress :: NetworkId -> Address -> Either Text (AddressInEra AlonzoEra) +serialiseAlonzoAddress :: NetworkId -> Address -> Either Text (AddressInEra BabbageEra) serialiseAlonzoAddress networdId address = mapLeft showError $ - toCardanoAddress networdId address + toCardanoAddressInEra networdId address where showError :: ToCardanoError -> Text showError err = (convert . show . pretty $ err) <> (convert . show $ address) -serialiseByronAddress :: Address -> Either Text (AddressInEra AlonzoEra) +serialiseByronAddress :: Address -> Either Text (AddressInEra BabbageEra) serialiseByronAddress (Address (PubKeyCredential (PubKeyHash bytes)) _) = do base58 <- mapLeft (convert . show) $ diff --git a/src/Tokenomia/Vesting/Contract.hs b/src/Tokenomia/Vesting/Contract.hs index 036bd961..55e1b2fe 100644 --- a/src/Tokenomia/Vesting/Contract.hs +++ b/src/Tokenomia/Vesting/Contract.hs @@ -35,10 +35,10 @@ import qualified Data.Map as Map import Prelude (Semigroup (..),Show) import GHC.Generics (Generic) -import Ledger (Address, POSIXTime, POSIXTimeRange, PubKeyHash (..), Validator) -import Ledger.Constraints (TxConstraints, mustBeSignedBy, mustPayToTheScript, mustValidateIn) -import Ledger.Contexts (ScriptContext (..), TxInfo (..)) -import qualified Ledger.Contexts as Validation +import Ledger (Address, POSIXTime, POSIXTimeRange, PubKeyHash (..), PaymentPubKeyHash(..), Validator) +import Ledger.Constraints (TxConstraints, mustBeSignedBy, mustPayToTheScript, mustValidateIn, collectFromTheScript) +import Plutus.V1.Ledger.Contexts (ScriptContext (..), TxInfo (..)) +import qualified Plutus.V1.Ledger.Contexts as Validation import qualified Ledger.Interval as Interval import qualified Ledger.Tx as Tx import Ledger.Typed.Scripts (ValidatorTypes (..)) @@ -60,7 +60,6 @@ import Plutus.Contract selectList, throwError, Promise(awaitPromise) ) -import qualified Plutus.Contract.Typed.Tx as Typed import qualified PlutusTx import PlutusTx.Prelude ( return, @@ -179,7 +178,7 @@ typedValidator = Scripts.mkTypedValidatorParam @Vesting $$(PlutusTx.compile [|| validate ||]) $$(PlutusTx.compile [|| wrap ||]) where - wrap = Scripts.wrapValidator + wrap = Scripts.mkUntypedValidator contractAddress :: VestingParams -> Address contractAddress = Scripts.validatorAddress . typedValidator @@ -244,10 +243,10 @@ retrieveFundsC vesting payment = mapError (review _VestingError) $ do remainingOutputs = case liveness of Alive -> payIntoContract remainingValue Dead -> mempty - tx = Typed.collectFromScript unspentOutputs () + tx = collectFromTheScript unspentOutputs () <> remainingOutputs <> mustValidateIn (Interval.from nextTime) - <> mustBeSignedBy (vestingOwner vesting) + <> mustBeSignedBy (PaymentPubKeyHash $ vestingOwner vesting) -- we don't need to add a pubkey output for 'vestingOwner' here -- because this will be done by the wallet when it balances the -- transaction. diff --git a/src/Tokenomia/Vesting/Sendings.hs b/src/Tokenomia/Vesting/Sendings.hs index 6fe50717..859f2fdd 100644 --- a/src/Tokenomia/Vesting/Sendings.hs +++ b/src/Tokenomia/Vesting/Sendings.hs @@ -60,7 +60,6 @@ data Sendings = Sendings deriving stock (Generic, Show) deriving anyclass (ToJSON, FromJSON) -deriving stock instance Ord TxHash deriving newtype instance ToJSONKey TxHash deriving newtype instance FromJSONKey TxHash diff --git a/src/Tokenomia/Vesting/Vest.hs b/src/Tokenomia/Vesting/Vest.hs index d3ee46ca..0a101e28 100644 --- a/src/Tokenomia/Vesting/Vest.hs +++ b/src/Tokenomia/Vesting/Vest.hs @@ -19,8 +19,9 @@ import qualified Data.Time.Clock.POSIX as POSIX import Control.Monad.Reader hiding (ask) import Control.Monad.Except +import Ledger.Ada import Ledger.Value -import Plutus.V1.Ledger.Ada +import Plutus.V1.Ledger.Value import qualified Tokenomia.Common.Datum as Script diff --git a/test/Spec/Tokenomia/CardanoApi/FromPlutus/Value.hs b/test/Spec/Tokenomia/CardanoApi/FromPlutus/Value.hs index f7d1d4a2..6650c91b 100644 --- a/test/Spec/Tokenomia/CardanoApi/FromPlutus/Value.hs +++ b/test/Spec/Tokenomia/CardanoApi/FromPlutus/Value.hs @@ -4,7 +4,7 @@ module Spec.Tokenomia.CardanoApi.FromPlutus.Value import Data.Either ( isRight ) -import Plutus.V1.Ledger.Ada ( adaSymbol ) +import Ledger.Ada ( adaSymbol ) import Plutus.V1.Ledger.Value ( CurrencySymbol(..) ) import Test.Tasty.QuickCheck ( testProperty, shrink ) diff --git a/test/Spec/Tokenomia/ICO/Funds/Exchange/GenInputs.hs b/test/Spec/Tokenomia/ICO/Funds/Exchange/GenInputs.hs index fe84d986..62f156cb 100644 --- a/test/Spec/Tokenomia/ICO/Funds/Exchange/GenInputs.hs +++ b/test/Spec/Tokenomia/ICO/Funds/Exchange/GenInputs.hs @@ -14,7 +14,7 @@ import Prelude hiding ((+),(-), print) import PlutusTx.Prelude (AdditiveSemigroup((+))) import Ledger ( TxOutRef (..), Slot (..)) -import Plutus.V1.Ledger.Ada +import Ledger.Ada import Plutus.V1.Ledger.Value import Test.QuickCheck import System.Random diff --git a/test/Spec/Tokenomia/ICO/Funds/Validation/CardanoCLI/GenInputs.hs b/test/Spec/Tokenomia/ICO/Funds/Validation/CardanoCLI/GenInputs.hs index e3874bc6..6c695d1e 100644 --- a/test/Spec/Tokenomia/ICO/Funds/Validation/CardanoCLI/GenInputs.hs +++ b/test/Spec/Tokenomia/ICO/Funds/Validation/CardanoCLI/GenInputs.hs @@ -12,7 +12,7 @@ module Spec.Tokenomia.ICO.Funds.Validation.CardanoCLI.GenInputs import Prelude hiding ((+), print) import Ledger ( TxOutRef (..), Slot (..)) -import Plutus.V1.Ledger.Ada +import Ledger.Ada import Test.QuickCheck import System.Random import Tokenomia.Wallet.ChildAddress.ChildAddressRef diff --git a/test/Spec/Tokenomia/ICO/Funds/Validation/Investor/GenInputs.hs b/test/Spec/Tokenomia/ICO/Funds/Validation/Investor/GenInputs.hs index b62bb941..eeb4e1fe 100644 --- a/test/Spec/Tokenomia/ICO/Funds/Validation/Investor/GenInputs.hs +++ b/test/Spec/Tokenomia/ICO/Funds/Validation/Investor/GenInputs.hs @@ -12,7 +12,7 @@ import Prelude hiding ((+),(-), print) import PlutusTx.Prelude (AdditiveSemigroup((+))) import Ledger ( TxOutRef (..), Slot (..)) -import Plutus.V1.Ledger.Ada +import Ledger.Ada import Plutus.V1.Ledger.Interval import Test.QuickCheck import System.Random diff --git a/test/Spec/Tokenomia/Token/CLAPStyle/MonetaryPolicy.hs b/test/Spec/Tokenomia/Token/CLAPStyle/MonetaryPolicy.hs index d5262b8f..58c62a1e 100644 --- a/test/Spec/Tokenomia/Token/CLAPStyle/MonetaryPolicy.hs +++ b/test/Spec/Tokenomia/Token/CLAPStyle/MonetaryPolicy.hs @@ -72,10 +72,10 @@ tests = testGroup "Monetary CLAP Policy" burnContract' :: Wallet -> Params -> Integer -> Contract () EmptySchema CLAPMonetaryPolicyError () burnContract' wallet params amountGiven = void $ burnContract @() @EmptySchema @CLAPMonetaryPolicyError - (walletPubKeyHash wallet) params amountGiven + (Ledger.unPaymentPubKeyHash $ mockWalletPaymentPubKeyHash wallet) params amountGiven mintCLAPContract' :: Contract (Maybe (Last (CurrencySymbol,Params))) EmptySchema CLAPMonetaryPolicyError (CurrencySymbol,Params) mintCLAPContract' = do - result <- mintContract (walletPubKeyHash w1) (TokenName "CLAP") (1000000000000 :: Integer) + result <- mintContract (Ledger.unPaymentPubKeyHash $ mockWalletPaymentPubKeyHash w1) (TokenName "CLAP") (1000000000000 :: Integer) (tell . Just . Last) result pure result diff --git a/test/Spec/Tokenomia/Vesting/Contract.hs b/test/Spec/Tokenomia/Vesting/Contract.hs index 19431a93..ecc6e8c5 100644 --- a/test/Spec/Tokenomia/Vesting/Contract.hs +++ b/test/Spec/Tokenomia/Vesting/Contract.hs @@ -81,7 +81,7 @@ vesting startTime = VestingParams { vestingTranche1 = VestingTranche (startTime + 10000) (Ada.lovelaceValueOf 20) , vestingTranche2 = VestingTranche (startTime + 20000) (Ada.lovelaceValueOf 40) - , vestingOwner = walletPubKeyHash w1 } + , vestingOwner = Ledger.unPaymentPubKeyHash $ mockWalletPaymentPubKeyHash w1 } retrieveFundsTrace :: EmulatorTrace () retrieveFundsTrace = do diff --git a/test/Spec/Tokenomia/Vesting/Sendings.hs b/test/Spec/Tokenomia/Vesting/Sendings.hs index c18f210f..ac96c477 100644 --- a/test/Spec/Tokenomia/Vesting/Sendings.hs +++ b/test/Spec/Tokenomia/Vesting/Sendings.hs @@ -77,8 +77,6 @@ newtype FakeBlockfrost (m :: Type -> Type) (a :: Type) = FakeBlockfrost {runFake deriving via (IdentityT m) instance (MonadState a m) => MonadState a (FakeBlockfrost m) deriving via (IdentityT m) instance (MonadError e m) => MonadError e (FakeBlockfrost m) -deriving newtype instance Ord Address - instance (Monad m, MonadState TestState m, MonadError TokenomiaError m) => MonadRunBlockfrost (FakeBlockfrost m) where getAddressTransactions addr = do atsMap <- gets fst @@ -127,7 +125,7 @@ invalidInputTests = valueTest = testBuilder $ testDataBuilder sendingsAddress emptyValueSendingsTxs bfAddrTxMap bfUtxos sendingsAddress = testAddress - bfAddr = [AddressTransaction (TxHash "abcd") 0 0, AddressTransaction (TxHash "wxyz") 0 0] + bfAddr = [AddressTransaction (TxHash "abcd") 0 0 0, AddressTransaction (TxHash "wxyz") 0 0 0] sendingsTxs = NonEmpty.fromList [ (TxHash "abcd", lovelaceValueOf 10000000) @@ -165,7 +163,7 @@ validTxHashTests = where -- All request TxHashes exist passTest = testBuilder $ testDataBuilder sendingsAddress sendingsTxs (bfAddrTxMap goodBfAddr) bfUtxos - goodBfAddr = [AddressTransaction (TxHash "abcd") 0 0, AddressTransaction (TxHash "wxyz") 0 0] + goodBfAddr = [AddressTransaction (TxHash "abcd") 0 0 0, AddressTransaction (TxHash "wxyz") 0 0 0] -- Some TxHash doesn't exist failTest = testBuilder $ testDataBuilder sendingsAddress sendingsTxs (bfAddrTxMap badBfAddr) bfUtxos @@ -232,8 +230,8 @@ valueCheckTests = [ ( Address sendingsAddress , - [ AddressTransaction (TxHash "abcd") 0 0 - , AddressTransaction (TxHash "wxyz") 0 0 + [ AddressTransaction (TxHash "abcd") 0 0 0 + , AddressTransaction (TxHash "wxyz") 0 0 0 ] ) ] diff --git a/tokenomia.cabal b/tokenomia.cabal index ee7149fc..f6f61ec1 100644 --- a/tokenomia.cabal +++ b/tokenomia.cabal @@ -30,7 +30,7 @@ common lang ghc-options: -Wall -Wnoncanonical-monad-instances -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints -Widentities -rtsopts + -Wredundant-constraints -Widentities -Wcompat -Wmissing-export-lists -Wmissing-deriving-strategies -Wno-orphans @@ -42,46 +42,19 @@ common lang library import: lang exposed-modules: - Tokenomia.CLI - Tokenomia.Node.Status - Tokenomia.Token.CLAPStyle.Mint - Tokenomia.Token.CLAPStyle.Burn - Tokenomia.Token.CLAPStyle.MonetaryPolicy - Tokenomia.ICO.Funds.Validation.CardanoCLI.Command - Tokenomia.Script.LocalRepository - Tokenomia.Script.ChainIndex - Tokenomia.Script.UTxO - Tokenomia.Wallet.Type - Tokenomia.Common.TxOutRef - Tokenomia.Wallet.CLI - Tokenomia.Wallet.LocalRepository - Tokenomia.Wallet.LocalRepository.Folder - Tokenomia.Wallet.ChildAddress.ChainIndex - Tokenomia.Wallet.UTxO - Tokenomia.Wallet.WalletUTxO - Tokenomia.Wallet.Collateral.Write - Tokenomia.Wallet.Collateral.Read - Tokenomia.Wallet.ChildAddress.ChildAddressRef - Tokenomia.Wallet.ChildAddress.LocalRepository Tokenomia.Ada.Transfer - Tokenomia.Common.Error - Tokenomia.Token.Transfer - Tokenomia.Vesting.Contract - Tokenomia.Vesting.Repository - Tokenomia.Vesting.Vest - Tokenomia.Vesting.Retrieve - Tokenomia.Vesting.Sendings - Tokenomia.Tokenomic.CLAP.Simulation + Tokenomia.CLI Tokenomia.CardanoApi.Arbitrary.Slot Tokenomia.CardanoApi.Arbitrary.Time + Tokenomia.CardanoApi.Fees Tokenomia.CardanoApi.FromPlutus.Error Tokenomia.CardanoApi.FromPlutus.Time Tokenomia.CardanoApi.FromPlutus.Value - Tokenomia.CardanoApi.Fees Tokenomia.CardanoApi.PParams Tokenomia.CardanoApi.Query Tokenomia.CardanoApi.Time Tokenomia.CardanoApi.Value + Tokenomia.Common.Address Tokenomia.Common.Aeson.AssetClass Tokenomia.Common.Arbitrary.AssetClass Tokenomia.Common.Arbitrary.Builtins @@ -91,150 +64,181 @@ library Tokenomia.Common.Arbitrary.Utils Tokenomia.Common.Arbitrary.Value Tokenomia.Common.Arbitrary.Wallet + Tokenomia.Common.Asset Tokenomia.Common.AssetClass Tokenomia.Common.Blockfrost - Tokenomia.Common.Value - Tokenomia.Common.Serialise - Tokenomia.Common.Node - Tokenomia.Common.Transacting - Tokenomia.Common.Folder - Tokenomia.Common.Shell.InteractiveMenu - Tokenomia.Common.Shell.Console - Tokenomia.Common.Environment - Tokenomia.Common.Environment.Query - Tokenomia.Common.Datum - Tokenomia.Common.Address - Tokenomia.Common.Asset - Tokenomia.Common.Hash - Tokenomia.Common.Time - Tokenomia.Common.Token - Tokenomia.Common.PageNumber Tokenomia.Common.Data.ByteString Tokenomia.Common.Data.Convertible Tokenomia.Common.Data.Either.Extra Tokenomia.Common.Data.List.Extra Tokenomia.Common.Data.List.NonEmpty + Tokenomia.Common.Datum + Tokenomia.Common.Environment + Tokenomia.Common.Environment.Query + Tokenomia.Common.Error + Tokenomia.Common.Folder + Tokenomia.Common.Hash + Tokenomia.Common.Node + Tokenomia.Common.PageNumber Tokenomia.Common.Parser Tokenomia.Common.Parser.Address Tokenomia.Common.Parser.AssetClass Tokenomia.Common.Parser.MinRequiredUTxO - Tokenomia.Common.Parser.Value Tokenomia.Common.Parser.TxOutDatumHash Tokenomia.Common.Parser.TxOutRef Tokenomia.Common.Parser.Utxo - Tokenomia.TokenDistribution.Main + Tokenomia.Common.Parser.Value + Tokenomia.Common.Serialise + Tokenomia.Common.Shell.Console + Tokenomia.Common.Shell.InteractiveMenu + Tokenomia.Common.Time + Tokenomia.Common.Token + Tokenomia.Common.Transacting + Tokenomia.Common.TxOutRef + Tokenomia.Common.Value + Tokenomia.ICO.Balanceable + Tokenomia.ICO.Funds.Exchange.CardanoCLI.Command + Tokenomia.ICO.Funds.Exchange.CardanoCLI.Convert + Tokenomia.ICO.Funds.Exchange.CardanoCLI.Transact + Tokenomia.ICO.Funds.Exchange.Command + Tokenomia.ICO.Funds.Exchange.Plan + Tokenomia.ICO.Funds.Exchange.Plan.Settings + Tokenomia.ICO.Funds.Exchange.ReceivedFunds + Tokenomia.ICO.Funds.Exchange.Run + Tokenomia.ICO.Funds.Exchange.Tokens + Tokenomia.ICO.Funds.Validation.CardanoCLI.Command + Tokenomia.ICO.Funds.Validation.CardanoCLI.Convert + Tokenomia.ICO.Funds.Validation.CardanoCLI.Datum + Tokenomia.ICO.Funds.Validation.CardanoCLI.Plan + Tokenomia.ICO.Funds.Validation.CardanoCLI.Transact + Tokenomia.ICO.Funds.Validation.ChildAddress.State + Tokenomia.ICO.Funds.Validation.ChildAddress.Types + Tokenomia.ICO.Funds.Validation.Investor.Command + Tokenomia.ICO.Funds.Validation.Investor.Plan + Tokenomia.ICO.Funds.Validation.Investor.Plan.Settings + Tokenomia.ICO.Funds.Validation.Run + Tokenomia.ICO.Funds.Validation.Simulation.Transfer + Tokenomia.ICO.Funds.Validation.Status + Tokenomia.ICO.Funds.WhiteListing.Repository + Tokenomia.ICO.Funds.WhiteListing.Types + Tokenomia.ICO.LocalRepository + Tokenomia.ICO.Round.Settings + Tokenomia.ICO.Status + Tokenomia.Node.Status + Tokenomia.Script.ChainIndex + Tokenomia.Script.LocalRepository + Tokenomia.Script.UTxO + Tokenomia.Token.CLAPStyle.Burn + Tokenomia.Token.CLAPStyle.Mint + Tokenomia.Token.CLAPStyle.MonetaryPolicy + Tokenomia.Token.Transfer Tokenomia.TokenDistribution.CLI Tokenomia.TokenDistribution.CLI.Parameters Tokenomia.TokenDistribution.CLI.Parser - Tokenomia.TokenDistribution.Parser.Address Tokenomia.TokenDistribution.Distribution + Tokenomia.TokenDistribution.Main + Tokenomia.TokenDistribution.Parser.Address Tokenomia.TokenDistribution.PreValidation - Tokenomia.TokenDistribution.Transfer Tokenomia.TokenDistribution.Split.EstimateFees - Tokenomia.TokenDistribution.Split.SplitDistribution Tokenomia.TokenDistribution.Split.SplitAdaSource + Tokenomia.TokenDistribution.Split.SplitDistribution Tokenomia.TokenDistribution.Split.SplitTokenSource + Tokenomia.TokenDistribution.Transfer Tokenomia.TokenDistribution.Wallet.ChildAddress.ChainIndex Tokenomia.TokenDistribution.Wallet.ChildAddress.ChildAddressRef Tokenomia.TokenDistribution.Wallet.ChildAddress.LocalRepository - Tokenomia.ICO.Status - Tokenomia.ICO.Round.Settings - Tokenomia.ICO.LocalRepository - Tokenomia.ICO.Balanceable - Tokenomia.ICO.Funds.Validation.Run - Tokenomia.ICO.Funds.Validation.Investor.Command - Tokenomia.ICO.Funds.Validation.Investor.Plan - Tokenomia.ICO.Funds.Validation.ChildAddress.State - Tokenomia.ICO.Funds.Validation.ChildAddress.Types - Tokenomia.ICO.Funds.Validation.CardanoCLI.Transact - Tokenomia.ICO.Funds.Validation.CardanoCLI.Datum - Tokenomia.ICO.Funds.Validation.CardanoCLI.Convert - Tokenomia.ICO.Funds.Validation.Simulation.Transfer - Tokenomia.ICO.Funds.Exchange.Run - Tokenomia.ICO.Funds.Exchange.ReceivedFunds - Tokenomia.ICO.Funds.Exchange.Command - Tokenomia.ICO.Funds.Exchange.Plan - Tokenomia.ICO.Funds.Exchange.CardanoCLI.Command - Tokenomia.ICO.Funds.Exchange.CardanoCLI.Convert - Tokenomia.ICO.Funds.Exchange.CardanoCLI.Transact - Tokenomia.ICO.Funds.WhiteListing.Repository - Tokenomia.ICO.Funds.WhiteListing.Types - Tokenomia.ICO.Funds.Exchange.Tokens - Tokenomia.ICO.Funds.Exchange.Plan.Settings - Tokenomia.ICO.Funds.Validation.Status - Tokenomia.ICO.Funds.Validation.CardanoCLI.Plan - Tokenomia.ICO.Funds.Validation.Investor.Plan.Settings + Tokenomia.Tokenomic.CLAP.Simulation + Tokenomia.Vesting.Contract Tokenomia.Vesting.GenerateNative + Tokenomia.Vesting.Repository + Tokenomia.Vesting.Retrieve + Tokenomia.Vesting.Sendings + Tokenomia.Vesting.Vest + Tokenomia.Wallet.CLI + Tokenomia.Wallet.ChildAddress.ChainIndex + Tokenomia.Wallet.ChildAddress.ChildAddressRef + Tokenomia.Wallet.ChildAddress.LocalRepository + Tokenomia.Wallet.Collateral.Read + Tokenomia.Wallet.Collateral.Write + Tokenomia.Wallet.LocalRepository + Tokenomia.Wallet.LocalRepository.Folder + Tokenomia.Wallet.Type + Tokenomia.Wallet.UTxO + Tokenomia.Wallet.WalletUTxO build-depends: base >= 4.9 && < 5, Cabal, - base16-bytestring, - lens, + Unique, aeson, async, attoparsec, + base16-bytestring, + blockfrost-api, + blockfrost-client, + blockfrost-client-core, + blockfrost-pretty, + bytestring, + cardano-api, + cardano-cli, + cardano-ledger-alonzo, + cardano-ledger-byron, + cardano-ledger-core, + cardano-ledger-shelley, + cardano-slotting, composition, composition-extra, + containers, + data-default, + deepseq, + directory, either, errors, + exceptions, extra, filepath, - memory, - text, - time, - mtl, - shh, - split, - directory, - random, - exceptions, - lifted-base, - utf8-string, - Unique, + freer-extras, freer-simple, - data-default, + hashable, + hex, + hex-text, iso8601-time, - unordered-containers, + lens, + lifted-base, + memory, + mtl, + nonempty-containers, + optparse-applicative, + ordered-containers, ouroboros-consensus, ouroboros-network, - bytestring, - containers, - cardano-api, - cardano-cli, - cardano-ledger-core, - cardano-ledger-alonzo, - cardano-ledger-byron, - cardano-ledger-shelley, - cardano-slotting, - plutus-ledger-api, - serialise, - freer-extras, playground-common, plutus-chain-index, + plutus-chain-index-core, plutus-contract, plutus-core, - plutus-tx-plugin, - plutus-tx, plutus-ledger, + plutus-ledger-api, + plutus-ledger-api, + plutus-ledger-constraints, + plutus-script-utils, + plutus-tx, + plutus-tx-plugin, pretty-simple, - blockfrost-client, - blockfrost-api, - blockfrost-client-core, - blockfrost-pretty, prettyprinter, + quickcheck-instances, + random, safe-money, - optparse-applicative, - ordered-containers, - nonempty-containers, + serialise, + shh, + split, streamly, + tasty-quickcheck, + text, + time, transformers, transformers-except, - deepseq, - hashable, - hex, - hex-text, - tasty-quickcheck, - quickcheck-instances + unordered-containers, + utf8-string hs-source-dirs: src test-suite tokenomia-tests @@ -243,25 +247,25 @@ test-suite tokenomia-tests main-is: Spec.hs hs-source-dirs: test other-modules: - Spec.Tokenomia.CardanoApi.FromPlutus.Value Spec.Tokenomia.CardanoApi.Fees - Spec.Tokenomia.Vesting.GenerateNative + Spec.Tokenomia.CardanoApi.FromPlutus.Value Spec.Tokenomia.Common.Arbitrary.Builtins Spec.Tokenomia.Common.Arbitrary.Utils Spec.Tokenomia.Common.Data.List.Extra Spec.Tokenomia.Common.Parser.Address Spec.Tokenomia.Common.Time - Spec.Tokenomia.Token.CLAPStyle.MonetaryPolicy - Spec.Tokenomia.Vesting.Contract - Spec.Tokenomia.Vesting.Sendings - Spec.Tokenomia.Wallet.UTxO Spec.Tokenomia.Common.Value - Spec.Tokenomia.ICO.Funds.Exchange.Plan Spec.Tokenomia.ICO.Funds.Exchange.GenInputs - Spec.Tokenomia.ICO.Funds.Validation.Investor.GenInputs - Spec.Tokenomia.ICO.Funds.Validation.Investor.Plan + Spec.Tokenomia.ICO.Funds.Exchange.Plan Spec.Tokenomia.ICO.Funds.Validation.CardanoCLI.GenInputs Spec.Tokenomia.ICO.Funds.Validation.CardanoCLI.Plan + Spec.Tokenomia.ICO.Funds.Validation.Investor.GenInputs + Spec.Tokenomia.ICO.Funds.Validation.Investor.Plan + Spec.Tokenomia.Token.CLAPStyle.MonetaryPolicy + Spec.Tokenomia.Vesting.Contract + Spec.Tokenomia.Vesting.GenerateNative + Spec.Tokenomia.Vesting.Sendings + Spec.Tokenomia.Wallet.UTxO build-depends: plutus-tx -any, plutus-tx-plugin, @@ -272,30 +276,30 @@ test-suite tokenomia-tests mtl build-depends: base >=4.9 && <5, - tasty -any, - tasty-hunit -any, - tasty-hedgehog >=0.2.0.0, - tasty-quickcheck, - quickcheck-instances, QuickCheck, - random, - nonempty-containers, - freer-simple -any, + blockfrost-api, blockfrost-client, bytestring, - text, - time, - ordered-containers, - interpolatedstring-perl6, - blockfrost-api, - safe-money, + cardano-api, + composition-extra, containers, + data-default, either, - composition-extra, + freer-simple -any, hex, - cardano-api, + interpolatedstring-perl6, + nonempty-containers, + ordered-containers, ouroboros-consensus, - data-default + quickcheck-instances, + random, + safe-money, + tasty -any, + tasty-hedgehog >=0.2.0.0, + tasty-hunit -any, + tasty-quickcheck, + text, + time executable tokenomia-cli From 469e88277debf5b5d0e7424ca85a25ce1af7d9dc Mon Sep 17 00:00:00 2001 From: Charles Augu Date: Thu, 19 Jan 2023 10:32:34 +0100 Subject: [PATCH 15/15] add missing parameters in preprod env config --- src/Tokenomia/Common/Environment.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Tokenomia/Common/Environment.hs b/src/Tokenomia/Common/Environment.hs index 347c673a..9eb14058 100644 --- a/src/Tokenomia/Common/Environment.hs +++ b/src/Tokenomia/Common/Environment.hs @@ -95,6 +95,7 @@ getPreprodEnvironmment magicNumber = do byronSlotsPerEpoch = 21600 byronSecondsPerSlot = 20 systemStart <- ExternalPosix.utcTimeToPOSIXSeconds . coerce <$> getSystemStart' localNodeConnectInfo + systemStart' <- getSystemStart' localNodeConnectInfo return $ Testnet {..}