[vesting] rewrite the private sale module

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[@]}"

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

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)

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)

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

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

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
+            ]