Skip to content

Commit

Permalink
wip: add utxo rules to mock ledger
Browse files Browse the repository at this point in the history
  • Loading branch information
@Anviking
Anviking committed May 5, 2021
1 parent 1ac9f2b commit 289095f
Show file tree
Hide file tree
Showing 2 changed files with 120 additions and 55 deletions.
59 changes: 41 additions & 18 deletions lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery/Delegation.hs
View file
Expand Up @@ -7,6 +7,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

Expand Down Expand Up @@ -47,7 +48,10 @@ import Cardano.Wallet.Primitive.AddressDerivation
, DerivationIndex (..)
, DerivationType (..)
, Index (..)
, MkKeyFingerprint (paymentKeyFingerprint)
, NetworkDiscriminant
, Passphrase (..)
, PaymentAddress (..)
, Role (..)
, SoftDerivation (..)
, ToRewardAccount (..)
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
116 changes: 79 additions & 37 deletions lib/core/test/unit/Cardano/Wallet/Primitive/AddressDiscovery/DelegationSpec.hs
View file
Expand Up @@ -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 #-}
Expand All @@ -16,6 +19,9 @@ import Cardano.Wallet.Primitive.AddressDerivation
( Depth (..)
, DerivationType (..)
, HardDerivation (..)
, KeyFingerprint (..)
, MkKeyFingerprint (..)
, MkKeyFingerprint
, RewardAccount (..)
, RewardAccount
, SoftDerivation (..)
Expand All @@ -29,16 +35,18 @@ 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
import Crypto.Hash.Utils
( blake2b224 )
import Data.Either
( isRight )
import Data.Map
( Map )
import Data.Maybe
( isNothing )
import Data.Set
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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))
Expand All @@ -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
Expand Down Expand Up @@ -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
--
Expand Down Expand Up @@ -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

0 comments on commit 289095f

Please sign in to comment.