From 289095f60d30b00195071b491744bd9c1e837d4c Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Wed, 5 May 2021 17:30:18 +0200 Subject: [PATCH] wip: add utxo rules to mock ledger --- .../Primitive/AddressDiscovery/Delegation.hs | 59 ++++++--- .../AddressDiscovery/DelegationSpec.hs | 116 ++++++++++++------ 2 files changed, 120 insertions(+), 55 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery/Delegation.hs b/lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery/Delegation.hs index 673c8ee5ce4..458148d62ec 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery/Delegation.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery/Delegation.hs @@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -47,7 +48,10 @@ import Cardano.Wallet.Primitive.AddressDerivation , DerivationIndex (..) , DerivationType (..) , Index (..) + , MkKeyFingerprint (paymentKeyFingerprint) + , NetworkDiscriminant , Passphrase (..) + , PaymentAddress (..) , Role (..) , SoftDerivation (..) , ToRewardAccount (..) @@ -56,22 +60,29 @@ import Cardano.Wallet.Primitive.Types.Address ( Address ) import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) +import Cardano.Wallet.Primitive.Types.Hash + ( Hash (..) ) import Cardano.Wallet.Primitive.Types.RewardAccount ( RewardAccount ) import Cardano.Wallet.Primitive.Types.Tx - ( TxIn, TxOut (..) ) + ( TxIn (..), TxOut (..) ) +import Control.Arrow + ( second ) import Control.DeepSeq ( NFData ) +import Crypto.Hash.Utils + ( blake2b224 ) import Data.List.NonEmpty ( NonEmpty ) import Data.Maybe - ( maybeToList ) + ( fromJust, maybeToList ) import GHC.Generics ( Generic ) import Quiet ( Quiet (..) ) import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TB +import qualified Data.ByteString.Char8 as B8 -------------------------------------------------------------------------------- -- Delegation State @@ -210,14 +221,14 @@ setPortfolioOf s mkAddress isReg n = let s' = s { nextKeyIx = toEnum n } mkTxIn (PointerUTxO i c _) = (i, c) - -- TODO: What if the minUTxOValue changes? We should use it in the - -- output here. - mkTxOut (PointerUTxO _i c ix) = - TxOut (mkAddress $ keyAtIx s ix) (TB.fromCoin c) + minUTxOVal = Coin 1 -- FIXME + -- TODO: Need to rely on wallet to return as change, if the minUTxOVal + -- changes. Not sure if this is the case. + pointerOut = + [ TxOut (mkAddress $ keyAtIx s $ nextKeyIx s') (TB.fromCoin minUTxOVal) + ] pointerIn = maybeToList (mkTxIn <$> pointer s) - pointerOut = maybeToList (mkTxOut <$> pointer s) - -- TODO: Does this actually make sense? in case compare (toEnum n) (nextKeyIx s) of GT -> Just $ Tx @@ -246,22 +257,34 @@ setPortfolioOf s mkAddress isReg n = ] acct = toRewardAccount . keyAtIx s +-- FIXME: For testing only +txid :: Tx -> Hash "Tx" +txid = Hash . blake2b224 . B8.pack . show + applyTx - :: (SoftDerivation k, ToRewardAccount k) + :: forall k. ( SoftDerivation k + , ToRewardAccount k + , MkKeyFingerprint k Address + , MkKeyFingerprint k (k 'AddressK XPub)) => Tx -> DelegationState k -> DelegationState k -applyTx (Tx cs _ins outs) s0 = +applyTx tx@(Tx cs _ins outs) s0 = let s = foldl (flip applyCert) s0 cs - fingerprint _ix = error "todo" - isOurOut = error "todo" - pointerOuts ix = filter (isOurOut (fingerprint ix)) $ zip [0..] outs - in case pointerOuts <$> lastActiveIx s of - Nothing -> s -- TODO - Just [] -> s --error "panic: no pointer utxo on-chain" -- What should we do? - Just [x] -> error "todo" - Just (x:_) -> error "todo" + isOurOut (TxOut addr _b) = case (paymentKeyFingerprint @k . keyAtIx s $ nextKeyIx s, paymentKeyFingerprint addr) of + (Right fp, Right fp') + | fp == fp' -> True + | otherwise -> False + _ -> False + pointerOuts = filter (isOurOut . snd) $ zip [0..] outs + h = txid tx + pointerIx = nextKeyIx s -- FIXME! + in case pointerOuts of + [] -> s --error "panic: no pointer utxo on-chain" -- What should we do? + [(ix,TxOut _addr tb)] + -> s { pointer = Just $ PointerUTxO (TxIn h ix) (TB.getCoin tb) pointerIx } + (_x:_) -> error "todo" -- There shouldn't be more than one pointer, but theoretically -- possible. If a user sends funds to an address corresponding to -- the stake key (why would they do this though?), we could mistake diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/AddressDiscovery/DelegationSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/AddressDiscovery/DelegationSpec.hs index 28ddb00bb30..03e9d8e78c9 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/AddressDiscovery/DelegationSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/AddressDiscovery/DelegationSpec.hs @@ -2,8 +2,11 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -16,6 +19,9 @@ import Cardano.Wallet.Primitive.AddressDerivation ( Depth (..) , DerivationType (..) , HardDerivation (..) + , KeyFingerprint (..) + , MkKeyFingerprint (..) + , MkKeyFingerprint , RewardAccount (..) , RewardAccount , SoftDerivation (..) @@ -29,9 +35,9 @@ import Cardano.Wallet.Primitive.Types.Coin import Cardano.Wallet.Primitive.Types.Hash ( Hash (..) ) import Cardano.Wallet.Primitive.Types.Tx - ( TxIn, TxOut ) + ( TxIn (..), TxOut ) import Control.Arrow - ( second ) + ( first, second ) import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.State.Strict @@ -39,6 +45,8 @@ import Crypto.Hash.Utils ( blake2b224 ) import Data.Either ( isRight ) +import Data.Map + ( Map ) import Data.Maybe ( isNothing ) import Data.Set @@ -66,6 +74,8 @@ import Test.QuickCheck.Arbitrary.Generic ( genericArbitrary ) import qualified Data.ByteString.Char8 as B8 +import qualified Data.Map as Map +import qualified Data.Map.Internal as Map import qualified Data.Set as Set spec :: Spec @@ -176,7 +186,7 @@ spec = do let l = applyLedger subChain initialLedger cover 0.5 (isRight l) "valid chain" $ case l of - Right (Ledger regs) -> counterexample + Right (Ledger regs _) -> counterexample "valid chain => expecting the wallet's activeKeys \ \to match all registered keys in the ledger" $ Set.fromList (fmap toRewardAccount (activeKeys s)) @@ -189,23 +199,21 @@ accK = StakeKey' 0 apply :: [Tx] -> DelegationState StakeKey' -> DelegationState StakeKey' apply txs s = foldl (flip applyTx) s txs - -- txid = Hash . blake2b224 . B8.pack $ show tx - -- + + + +txid :: Tx -> Hash "Tx" +txid = Hash . blake2b224 . B8.pack . show applyLedger :: [Tx] -> Ledger -> Either String Ledger -applyLedger txs = execStateT (mapM_ applyTxLedger txs) +applyLedger txs = execStateT (mapM_ ledgerApplyTx' txs) where - applyTxLedger - :: Tx - -> StateT Ledger (Either String) () - applyTxLedger tx = mapM_ applyCert' (certs tx) - -- TODO: mock ledger also needs to check UTxO rules - applyCert' c = do + ledgerApplyTx' c = do l <- get - l' <- lift (ledgerApplyCert c l) + l' <- lift (ledgerApplyTx c l) put l' isConsecutiveRange :: (Eq a, Num a) => [a] -> Bool @@ -240,6 +248,12 @@ instance HardDerivation StakeKey' where instance SoftDerivation StakeKey' where deriveAddressPublicKey _acc _role i = StakeKey' $ toEnum $ fromEnum i +instance MkKeyFingerprint StakeKey' Address where + paymentKeyFingerprint (Address addr) = Right $ KeyFingerprint addr + +instance MkKeyFingerprint StakeKey' (StakeKey' 'AddressK XPub) where + paymentKeyFingerprint k = Right $ KeyFingerprint $ "addr" <> unRewardAccount (toRewardAccount k) + -- -- Mock chain of delegation certificates -- @@ -322,42 +336,70 @@ applyCmds = second reverse . foldl step ((s0, initialLedger), []) step ((s,l), accTxs) (CmdAdversarialReg k) = let tx = Tx [RegisterKey k] [] [] in ((s,applyLedger' tx l), tx:accTxs) - step ((s, Ledger l), accTxs) CmdOldWalletToggleFirstKey = + step ((s, l@(Ledger regs _)), accTxs) CmdOldWalletToggleFirstKey = let key0 = toRewardAccount (keyAtIx s minBound) - isReg = key0 `Set.member` l + isReg = key0 `Set.member` regs tx = Tx [if isReg then DeRegisterKey key0 else RegisterKey key0] [] [] - in ((applyTx tx s, applyLedger' tx (Ledger l)), tx:accTxs) + in ((applyTx tx s, applyLedger' tx l), tx:accTxs) s0 = initialDelegationState accK - applyLedger' tx l = either (error . show) id $ applyLedger [tx] l + applyLedger' tx l = either (error . show) id $ ledgerApplyTx tx l mkAddr k = Address $ "addr" <> unRewardAccount (toRewardAccount k) -- -- Mock ledger -- -newtype Ledger = Ledger (Set RewardAccount) +data Ledger = Ledger + { regs :: Set RewardAccount + , utxos :: Map TxIn TxOut + } deriving (Show, Eq) initialLedger :: Ledger -initialLedger = Ledger Set.empty +initialLedger = Ledger Set.empty Map.empty acctIsReg :: Ledger -> RewardAccount -> Bool -acctIsReg (Ledger l) a = a `Set.member` l - -ledgerApplyCert :: Cert -> Ledger -> Either String Ledger -ledgerApplyCert (Delegate k) (Ledger l) - | k `Set.member` l - = pure $ Ledger l - | otherwise - = Left $ "Can't delegate: " <> show k <> " not in " <> show l -ledgerApplyCert (RegisterKey k) (Ledger l) - | k `Set.member` l - = Left $ "Can't register: " <> show k <> " already in: " <> show l - | otherwise - = pure $ Ledger $ Set.insert k l -ledgerApplyCert (DeRegisterKey k) (Ledger l) - | k `Set.member` l - = pure $ Ledger $ Set.delete k l - | otherwise - = Left $ "Can't deregister: " <> show k <> " not in " <> show l +acctIsReg l a = a `Set.member` (regs l) + +ledgerApplyTx :: Tx -> Ledger -> Either String Ledger +ledgerApplyTx tx l' = + (foldl (\x y -> x >>= ledgerApplyCert y) (Right l') (certs tx)) + >>= ledgerApplyInsOus + where + ledgerApplyInsOus :: Ledger -> Either String Ledger + ledgerApplyInsOus (Ledger r utxo) = + let + -- TODO: There could be duplicates, which we should forbid + ins = Set.fromList $ map fst $ inputs tx + h = txid tx + newOuts = Map.fromList $ + zipWith + (curry $ first (TxIn h)) + [0 ..] + (outputs tx) + + canSpend = ins `Set.isSubsetOf` Map.keysSet utxo + + in + if canSpend + then Right $ Ledger r $ Map.union newOuts $ utxo `Map.withoutKeys` ins + else Left "invalid utxo spending" + + + ledgerApplyCert :: Cert -> Ledger -> Either String Ledger + ledgerApplyCert (Delegate k) l + | k `Set.member` (regs l) + = pure l + | otherwise + = Left $ "Can't delegate: " <> show k <> " not in " <> show l + ledgerApplyCert (RegisterKey k) l + | k `Set.member` (regs l) + = Left $ "Can't register: " <> show k <> " already in: " <> show l + | otherwise + = pure $ l { regs = Set.insert k (regs l) } + ledgerApplyCert (DeRegisterKey k) l + | k `Set.member` (regs l) + = pure $ l { regs = Set.delete k (regs l) } + | otherwise + = Left $ "Can't deregister: " <> show k <> " not in " <> show l