Merge pull request #297 from mlabs-haskell/nazrhom/fee-escrow

Nazrhom/fee escrow

doc/on_chain_spec.md

@@ -625,9 +625,8 @@ Under the **distribute fees** redeemer, we enforce that:
 
 - There is one input spent from the fee escrow validator,
 defining the delegates.
-- There is one output per delegate.
-The conditions in `validFeeDistribution` are satisfied
-when applied to these outputs and the transaction fee.
+- There is at least one output per delegate such that
+the ada contained in that output is >= `auctionFeePerDelegate`
 - No tokens are minted or burned.
 
 ```mermaid
@@ -643,26 +642,6 @@ flowchart LR
 
 The fee distribution to delegates must satisfy the following conditions:
 
-```haskell
-validFeeDistribution :: AuctionTerms -> [TxOut] -> Value -> Bool
-validFeeDistribution AuctionTerms{..} outputsToDelegates txFee =
-    allAdaDistributed
-      && adaDistributedEvenly
-  where
-    -- Each delegate received the `auctionFeePerDelegate`,
-    -- after deducting the transaction fees from the total.
-    allAdaDistributed = actualTotalAda == expectedTotalAda
-    actualTotalAda = sum actualAdaValues + adaValueOf txFee
-    expectedTotalAda = length delegates * auctionFeePerDelegate
-
-    -- The amount received by any delegate differs by at most one lovelace
-    -- from what any other delegate received.
-    adaDistributedEvenly = 1 > maximum actualAdaValues - minimum actualAdaValues
-
-    adaValueOf = valueOf adaSymbol adaToken
-    actualAdaValues = adaValueOf . txOutValue <$> outputsToDelegates
-```
-
 To keep things simple in this design, we require
 the number of delegates in an auction to be small enough
 that distributing their respective portions of the auction fee

hydra-auction.cabal

@@ -211,6 +211,7 @@ library
     HydraAuction.Tx.Common
     HydraAuction.Tx.Deposit
     HydraAuction.Tx.Escrow
+    HydraAuction.Tx.FeeEscrow
     HydraAuction.Tx.StandingBid
     HydraAuction.Tx.TermsConfig
     HydraAuction.Tx.TestNFT
@@ -220,6 +221,7 @@ library
   other-modules:
     HydraAuction.OnChain.Deposit
     HydraAuction.OnChain.Escrow
+    HydraAuction.OnChain.FeeEscrow
     HydraAuction.OnChain.StandingBid
     HydraAuction.OnChain.StateToken
 

src/HydraAuction/OnChain.hs

@@ -20,7 +20,7 @@ import Prelude qualified
 
 -- Plutus imports
 import Plutus.V1.Ledger.Value (AssetClass (..))
-import Plutus.V2.Ledger.Api (CurrencySymbol, MintingPolicy, ScriptContext, Validator, mkMintingPolicyScript, mkValidatorScript)
+import Plutus.V2.Ledger.Api (CurrencySymbol, MintingPolicy, Validator, mkMintingPolicyScript, mkValidatorScript)
 import PlutusTx qualified
 
 -- Hydra auction imports
@@ -32,6 +32,7 @@ import HydraAuction.Addresses (
  )
 import HydraAuction.OnChain.Deposit (mkDepositValidator)
 import HydraAuction.OnChain.Escrow (mkEscrowValidator)
+import HydraAuction.OnChain.FeeEscrow (mkFeeEscrowValidator)
 import HydraAuction.OnChain.StandingBid (mkStandingBidValidator)
 import HydraAuction.OnChain.StateToken (
   StateTokenKind (..),
@@ -104,9 +105,6 @@ standingBidAddress = StandingBidAddress . validatorAddress . standingBidValidato
 
 -- Fee escrow
 
-mkFeeEscrowValidator :: AuctionTerms -> () -> () -> ScriptContext -> Bool
-mkFeeEscrowValidator _terms _datum () _context = True -- FIXUP: Implement
-
 {-# INLINEABLE feeEscrowValidator #-}
 feeEscrowValidator :: AuctionTerms -> Validator
 feeEscrowValidator terms =

src/HydraAuction/OnChain/FeeEscrow.hs

@@ -0,0 +1,58 @@
+{-# OPTIONS_GHC -fno-specialise #-}
+
+module HydraAuction.OnChain.FeeEscrow (mkFeeEscrowValidator) where
+
+-- Prelude imports
+import PlutusTx.Prelude
+
+-- import Prelude (quot)
+
+-- Plutus imports
+import Plutus.V1.Ledger.Address (pubKeyHashAddress, scriptHashAddress)
+import Plutus.V1.Ledger.Value (valueOf)
+import Plutus.V2.Ledger.Api (TxInfo (..), TxOut (..), Value, adaSymbol, adaToken, scriptContextTxInfo, txInInfoResolved)
+import Plutus.V2.Ledger.Contexts (ScriptContext, ownHash)
+
+-- Hydra auction imports
+import HydraAuction.Types (
+  AuctionTerms (..),
+  FeeEscrowDatum,
+  FeeEscrowRedeemer (..),
+ )
+import HydraAuctionUtils.Plutus (
+  byAddress,
+  nothingForged,
+ )
+import HydraAuctionUtils.Types.Natural (naturalToInt)
+
+{-# INLINEABLE mkFeeEscrowValidator #-}
+mkFeeEscrowValidator :: AuctionTerms -> FeeEscrowDatum -> FeeEscrowRedeemer -> ScriptContext -> Bool
+mkFeeEscrowValidator terms () DistributeFees context =
+  -- There is one input spent from the fee escrow validator with enough ADA to pay the fees
+  adaValueOf singleFeeInputValue >= expectedFeePerDelegeate * length (delegates terms)
+    -- Every delegate is payed at least the expected proportion of fee
+    && all receivesProportionOfFee (delegates terms)
+    -- No tokens are minted or burned.
+    && nothingForged info
+  where
+    info :: TxInfo
+    info = scriptContextTxInfo context
+
+    outputs :: [TxOut]
+    outputs = txInfoOutputs info
+
+    adaValueOf v = valueOf v adaSymbol adaToken
+
+    expectedFeePerDelegeate = naturalToInt $ auctionFeePerDelegate terms
+
+    receivesProportionOfFee delegatePKH = case byAddress (pubKeyHashAddress delegatePKH) outputs of
+      [] -> traceError "Delegate does not receive proportion of fee"
+      outsToDelegate ->
+        traceIfFalse "Delegate does not receive proportion of fee" $
+          any (\txOut -> adaValueOf (txOutValue txOut) >= naturalToInt (auctionFeePerDelegate terms)) outsToDelegate
+
+    singleFeeInputValue :: Value
+    singleFeeInputValue = case byAddress (scriptHashAddress $ ownHash context) $ txInInfoResolved <$> txInfoInputs info of
+      [] -> traceError "Missing input for fee escrow"
+      [feeOut] -> txOutValue feeOut
+      _ : _ -> traceError "More than single input from fee escrow validator"

src/HydraAuction/Tx/Escrow.hs

@@ -250,7 +250,7 @@ bidderBuys terms = do
               <> lovelaceToValue minLovelace
 
       txOutFeeEscrow =
-        TxOut (ShelleyAddressInEra feeEscrowAddress) value TxOutDatumNone ReferenceScriptNone
+        TxOut (ShelleyAddressInEra feeEscrowAddress) value (mkInlineDatum ()) ReferenceScriptNone
         where
           value = lovelaceToValue $ Lovelace $ calculateTotalFee terms
 
@@ -328,7 +328,7 @@ sellerReclaims terms = do
         TxOut
           (ShelleyAddressInEra feeEscrowAddress)
           value
-          TxOutDatumNone
+          (mkInlineDatum ())
           ReferenceScriptNone
         where
           value = lovelaceToValue $ Lovelace $ calculateTotalFee terms

src/HydraAuction/Tx/FeeEscrow.hs

@@ -0,0 +1,117 @@
+module HydraAuction.Tx.FeeEscrow (
+  distributeFee,
+) where
+
+-- Prelude imports
+import Prelude
+
+-- Haskell imports
+import Control.Monad (void)
+
+-- Plutus imports
+import Plutus.V1.Ledger.Address (pubKeyHashAddress)
+import Plutus.V2.Ledger.Api (PubKeyHash)
+
+-- Cardano node imports
+import Cardano.Api.UTxO qualified as UTxO
+
+-- Hydra imports
+import Hydra.Cardano.Api (
+  Lovelace (..),
+  Value,
+  lovelaceToValue,
+  txOutValue,
+  valueToLovelace,
+  pattern ReferenceScriptNone,
+  pattern TxMintValueNone,
+  pattern TxOut,
+  pattern TxOutDatumNone,
+ )
+
+-- Hydra auction imports
+import HydraAuction.OnChain (AuctionScript (..))
+import HydraAuction.Tx.Common (
+  scriptPlutusScript,
+  scriptUtxos,
+ )
+import HydraAuction.Types (
+  AuctionTerms (..),
+  FeeEscrowRedeemer (..),
+ )
+import HydraAuctionUtils.L1.Runner (L1Runner)
+import HydraAuctionUtils.Monads (
+  fromPlutusAddressInMonad,
+  logMsg,
+ )
+import HydraAuctionUtils.Monads.Actors (
+  actorTipUtxo,
+  addressAndKeys,
+ )
+import HydraAuctionUtils.Tx.AutoCreateTx (
+  AutoCreateParams (..),
+  autoSubmitAndAwaitTx,
+ )
+import HydraAuctionUtils.Tx.Build (
+  mkInlinedDatumScriptWitness,
+ )
+import HydraAuctionUtils.Tx.Utxo (
+  filterAdaOnlyUtxo,
+ )
+
+distributeFee :: AuctionTerms -> L1Runner ()
+distributeFee terms = do
+  logMsg "Distributing fees to delegates"
+
+  (actorAddress, _, actorSk) <- addressAndKeys
+
+  actorMoneyUtxo <- filterAdaOnlyUtxo <$> actorTipUtxo
+
+  feeEscrowUtxo <- scriptUtxos FeeEscrow terms
+
+  feeEscrowValue <- case UTxO.pairs feeEscrowUtxo of
+    [(_, txOut)] -> pure $ txOutValue txOut
+    _ -> fail "wrong number of utxos in fee escrow script"
+
+  lovelaceAmt <- case valueToLovelace feeEscrowValue of
+    Just l -> pure l
+    Nothing -> fail "fee escrow asset does not contain ada-only"
+
+  delegateOuts <- mapM mkFeeOut (zipDistributingValue lovelaceAmt (delegates terms))
+
+  void $
+    autoSubmitAndAwaitTx $
+      AutoCreateParams
+        { signedUtxos = [(actorSk, actorMoneyUtxo)]
+        , additionalSigners = []
+        , referenceUtxo = mempty
+        , witnessedUtxos = [(feeWitness, feeEscrowUtxo)]
+        , collateral = Nothing
+        , outs = delegateOuts
+        , toMint = TxMintValueNone
+        , changeAddress = actorAddress
+        , validityBound = (Nothing, Nothing)
+        }
+  where
+    feeScript = scriptPlutusScript FeeEscrow terms
+    feeWitness = mkInlinedDatumScriptWitness feeScript DistributeFees
+
+    mkFeeOut (delegatePKH, valuePerDelegate) = do
+      delegateAddress <- fromPlutusAddressInMonad $ pubKeyHashAddress delegatePKH
+      pure $
+        TxOut
+          delegateAddress
+          valuePerDelegate
+          TxOutDatumNone
+          ReferenceScriptNone
+
+zipDistributingValue :: Lovelace -> [PubKeyHash] -> [(PubKeyHash, Value)]
+zipDistributingValue (Lovelace lovelaceAmt) delegatePKHs = zip delegatePKHs (lovelaceToValue . Lovelace <$> distributedLovelace)
+  where
+    delegateNumber = length delegatePKHs
+    (quotient, remainder) = divMod lovelaceAmt (toInteger delegateNumber)
+
+    spread _ [] = []
+    spread 0 xs = xs
+    spread k (x : xs) = (x + 1) : spread (k - 1) xs
+
+    distributedLovelace = spread remainder (replicate delegateNumber quotient)

src/HydraAuction/Tx/TermsConfig.hs

@@ -16,22 +16,25 @@ import Control.Monad.IO.Class (MonadIO (liftIO))
 import Control.Monad.TimeMachine (MonadTime)
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Kind (Type)
+import Data.Map qualified as Map
 import GHC.Generics (Generic)
 
 -- Plutus imports
 import Plutus.V1.Ledger.Crypto (PubKeyHash)
 import Plutus.V1.Ledger.Time (POSIXTime (..))
-import Plutus.V1.Ledger.Value (AssetClass, CurrencySymbol (..))
+import Plutus.V1.Ledger.Value (AssetClass, CurrencySymbol (..), unCurrencySymbol)
+import Plutus.V2.Ledger.Api (fromBuiltin)
 import Plutus.V2.Ledger.Contexts (TxOutRef)
 
 -- Hydra imports
 import Hydra.Cardano.Api (TxIn, toPlutusTxOutRef)
+import Hydra.Chain (HeadId (..))
 
 -- Hydra auction imports
 import HydraAuction.OnChain.TestNFT (testNftAssetClass)
 import HydraAuction.Types (AuctionTerms (..))
 import HydraAuctionUtils.Extras.PlutusOrphans ()
-import HydraAuctionUtils.Fixture (Actor, getActorPubKeyHash)
+import HydraAuctionUtils.Fixture (Actor, ActorKind (..), actorsByKind, getActorPubKeyHash, getActorsPubKeyHash)
 import HydraAuctionUtils.Time (currentTimeSeconds)
 import HydraAuctionUtils.Types.Natural (Natural)
 
@@ -67,8 +70,8 @@ instance ToJSON AuctionTermsDynamic
 instance FromJSON AuctionTermsDynamic
 
 -- | Stub for tests not checking MoveToHyda. Something not existent.
-nonExistentHeadIdStub :: CurrencySymbol
-nonExistentHeadIdStub = "DEADBEEF"
+nonExistentHeadIdStub :: HeadId
+nonExistentHeadIdStub = HeadId . fromBuiltin . unCurrencySymbol $ "DEADBEEF"
 
 constructTermsDynamic ::
   forall (timedMonad :: Type -> Type).
@@ -79,14 +82,13 @@ constructTermsDynamic ::
   timedMonad AuctionTermsDynamic
 constructTermsDynamic sellerActor utxoNonce headId = do
   currentTimeSeconds' <- currentTimeSeconds
-  sellerVkHash <- liftIO $ getActorPubKeyHash sellerActor
+  configDelegates <- liftIO $ getActorsPubKeyHash $ (Map.!) actorsByKind HydraNodeActor
   return $
     AuctionTermsDynamic
       { configAuctionLot = testNftAssetClass
       , configSellerActor = sellerActor
       , configHeadId = headId
-      , -- FIXME: get actual list of delegates
-        configDelegates = [sellerVkHash]
+      , configDelegates
       , configUtxoNonce = toPlutusTxOutRef utxoNonce
       , -- Convert to miliseconds and add one more second to have some time for submiting Tx
         configAnnouncementTime = POSIXTime $ currentTimeSeconds' * 1000 + 1000

src/HydraAuction/Types.hs

@@ -17,7 +17,8 @@ module HydraAuction.Types (
   AuctionEscrowDatum (..),
   EscrowRedeemer (..),
   StandingBidRedeemer (..),
-  AuctionFeeEscrowDatum,
+  FeeEscrowDatum,
+  FeeEscrowRedeemer (..),
   VoucherForgingRedeemer (..),
   calculateTotalFee,
   AuctionStage (..),
@@ -245,7 +246,7 @@ instance Eq BidDepositDatum where
 PlutusTx.makeIsDataIndexed ''BidDepositDatum [('BidDepositDatum, 0)]
 PlutusTx.makeLift ''BidDepositDatum
 
-type AuctionFeeEscrowDatum = ()
+type FeeEscrowDatum = ()
 
 -- Redeemers
 
@@ -260,3 +261,6 @@ PlutusTx.makeIsDataIndexed ''VoucherForgingRedeemer [('MintVoucher, 0), ('BurnVo
 
 data BidDepositRedeemer = LosingBidder | WinningBidder | SellerClaimsDeposit | CleanupDeposit
 PlutusTx.makeIsDataIndexed ''BidDepositRedeemer [('LosingBidder, 0), ('WinningBidder, 1), ('SellerClaimsDeposit, 2), ('CleanupDeposit, 3)]
+
+data FeeEscrowRedeemer = DistributeFees
+PlutusTx.makeIsDataIndexed ''FeeEscrowRedeemer [('DistributeFees, 0)]

test/EndToEnd/CLI.hs

@@ -13,13 +13,6 @@ import System.Directory (removeFile)
 import Test.Tasty (TestTree, testGroup, withResource)
 import Test.Tasty.HUnit (Assertion, testCase)
 
--- Plutus imports
-import Plutus.V1.Ledger.Value (unCurrencySymbol)
-import Plutus.V2.Ledger.Api (fromBuiltin)
-
--- Hydra imports
-import Hydra.Chain (HeadId (..))
-
 -- Hydra auction imports
 
 import HydraAuction.Delegate.Interface (DelegateState (..), InitializedState (..))
@@ -58,7 +51,7 @@ testSuite =
       removeFile fn
 
 mockDelegateState :: DelegateState
-mockDelegateState = Initialized (HeadId . fromBuiltin . unCurrencySymbol $ nonExistentHeadIdStub) (Open Nothing)
+mockDelegateState = Initialized nonExistentHeadIdStub (Open Nothing)
 
 auctionName :: AuctionName
 auctionName = "test"