Issue #792 #793 #798 key hashes and genesis deleg

shelley/chain-and-ledger/executable-spec/src/Delegation/Certificates.hs

@@ -16,7 +16,7 @@ module Delegation.Certificates
   ) where
 
 import           Coin (Coin (..))
-import           Keys (DSIGNAlgorithm, HashAlgorithm, KeyHash, hashKey)
+import           Keys (KeyHash)
 import           PParams (PParams (..), keyDecayRate, keyDeposit, keyMinRefund, poolDecayRate,
                      poolDeposit, poolMinRefund)
 import           Slot (Duration (..))
@@ -32,16 +32,13 @@ import           Data.Ratio (approxRational)
 import           Lens.Micro ((^.))
 
 -- |Determine the certificate author
-cwitness
-  :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
-  => DCert hashAlgo dsignAlgo
-  -> StakeCredential hashAlgo dsignAlgo
+cwitness :: DCert hashAlgo dsignAlgo -> StakeCredential hashAlgo dsignAlgo
 cwitness (RegKey hk)               = hk
 cwitness (DeRegKey hk)             = hk
-cwitness (RegPool pool)            = KeyHashObj . hashKey $ pool ^. poolPubKey
+cwitness (RegPool pool)            = KeyHashObj $ pool ^. poolPubKey
 cwitness (RetirePool k _)          = KeyHashObj k
 cwitness (Delegate delegation)     = delegation ^. delegator
-cwitness (GenesisDelegate (gk, _)) = GenesisHashObj $ hashKey gk
+cwitness (GenesisDelegate (gk, _)) = GenesisHashObj gk
 
 -- |Retrieve the deposit amount for a certificate
 dvalue :: DCert hashAlgo dsignAlgo -> PParams -> Coin

shelley/chain-and-ledger/executable-spec/src/Keys.hs

@@ -25,6 +25,7 @@ module Keys
   , KeyHash
   , pattern KeyHash
   , GenKeyHash
+  , pattern AnyKeyHash
   , AnyKeyHash
   , undiscriminateKeyHash
   , KeyPair(..)

shelley/chain-and-ledger/executable-spec/src/LedgerState.hs

@@ -134,7 +134,7 @@ import           EpochBoundary (BlocksMade (..), SnapShots (..), Stake (..), agg
                      baseStake, emptySnapShots, maxPool, poolRefunds, poolStake, ptrStake,
                      rewardStake)
 import           Keys (AnyKeyHash, DSIGNAlgorithm, Dms (..), GenKeyHash, HashAlgorithm,
-                     KeyDiscriminator (..), KeyHash, KeyPair, Signable, hash, hashKey,
+                     KeyDiscriminator (..), KeyHash, KeyPair, Signable, hash,
                      undiscriminateKeyHash)
 import           PParams (PParams (..), activeSlotCoeff, d, emptyPParams, keyDecayRate, keyDeposit,
                      keyMinRefund, minfeeA, minfeeB)
@@ -143,8 +143,8 @@ import           Slot (Duration (..), Epoch (..), Slot (..), epochFromSlot, firs
 import           Tx (extractKeyHash)
 import           TxData (Addr (..), Credential (..), Delegation (..), Ix, PoolParams, Ptr (..),
                      RewardAcnt (..), StakeCredential, Tx (..), TxBody (..), TxId (..), TxIn (..),
-                     TxOut (..), WitVKey (..), body, certs, getRwdHK, inputs, poolOwners,
-                     poolPledge, poolPubKey, poolRAcnt, ttl, txfee, wdrls)
+                     TxOut (..), body, certs, getRwdHK, inputs, poolOwners, poolPledge, poolPubKey,
+                     poolRAcnt, ttl, txfee, wdrls, witKeyHash)
 import           Updates (AVUpdate (..), Applications, PPUpdate (..), Update (..), emptyUpdate,
                      emptyUpdateState)
 import           UTxO (UTxO (..), balance, deposits, txinLookup, txins, txouts, txup, verifyWitVKey)
@@ -435,26 +435,15 @@ validInputs tx u =
     else Invalid [BadInputs]
 
 -- |Implementation of abstract transaction size
-txsize
-  :: DSIGNAlgorithm dsignAlgo
-  => TxBody hashAlgo dsignAlgo
-  -> Integer
+txsize :: TxBody hashAlgo dsignAlgo -> Integer
 txsize = toEnum . length . show
 
 -- |Minimum fee calculation
-minfee
-  :: DSIGNAlgorithm dsignAlgo
-  => PParams
-  -> TxBody hashAlgo dsignAlgo
-  -> Coin
+minfee :: PParams -> TxBody hashAlgo dsignAlgo -> Coin
 minfee pc tx = Coin $ pc ^. minfeeA * txsize tx + fromIntegral (pc ^. minfeeB)
 
 -- |Determine if the fee is large enough
-validFee
-  :: DSIGNAlgorithm dsignAlgo
-  => PParams
-  -> TxBody hashAlgo dsignAlgo
-  -> Validity
+validFee :: PParams -> TxBody hashAlgo dsignAlgo -> Validity
 validFee pc tx =
   if needed <= given
     then Valid
@@ -576,8 +565,7 @@ correctWithdrawals accs withdrawals =
 -- given transaction. This set consists of the txin owners,
 -- certificate authors, and withdrawal reward accounts.
 witsVKeyNeeded
-  :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
-  => UTxO hashAlgo dsignAlgo
+  :: UTxO hashAlgo dsignAlgo
   -> Tx hashAlgo dsignAlgo
   -> Dms hashAlgo dsignAlgo
   -> Set (AnyKeyHash hashAlgo dsignAlgo)
@@ -631,8 +619,7 @@ enoughWits tx@(Tx _ wits _) d' u =
     then Valid
     else Invalid [MissingWitnesses]
   where
-    signers = Set.map (\(WitVKey vkey _) ->
-      undiscriminateKeyHash $ hashKey vkey) wits
+    signers = Set.map witKeyHash wits
 
 validRuleUTXO
   :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
@@ -790,8 +777,7 @@ asStateTransition slot pp ls tx d' =
 -- apply the certificate as a state transition function on the ledger state.
 -- Otherwise, return a list of validation errors.
 certAsStateTransition
-  :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
-  => Slot
+  :: Slot
   -> Ix
   -> LedgerState hashAlgo dsignAlgo
   -> (Ix, DCert hashAlgo dsignAlgo)
@@ -839,8 +825,7 @@ retirePools ls@(LedgerState _ ds _) epoch =
 
 -- |Calculate the change to the deposit pool for a given transaction.
 depositPoolChange
-  :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
-  => LedgerState hashAlgo dsignAlgo
+  :: LedgerState hashAlgo dsignAlgo
   -> PParams
   -> TxBody hashAlgo dsignAlgo
   -> Coin
@@ -887,8 +872,7 @@ applyUTxOUpdate u tx = u & utxo .~ txins tx ⋪ (u ^. utxo) ∪ txouts tx
 
 -- |Apply a delegation certificate as a state transition function on the ledger state.
 applyDCert
-  :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
-  => Ptr
+  :: Ptr
   -> DCert hashAlgo dsignAlgo
   -> DPState hashAlgo dsignAlgo
   -> DPState hashAlgo dsignAlgo
@@ -936,8 +920,7 @@ applyDCertDState _ (Delegate (Delegation source target)) ds =
 applyDCertDState _ _ ds = ds
 
 applyDCertPState
-  :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
-  => Ptr
+  :: Ptr
   -> DCert hashAlgo dsignAlgo
   -> PState hashAlgo dsignAlgo
   -> PState hashAlgo dsignAlgo
@@ -946,7 +929,7 @@ applyDCertPState (Ptr slot _ _ ) (RegPool sp) ps =
        & pParams  %~ Map.insert hsk sp
        & cCounters  %~ Map.insert hsk c
        & retiring %~ Map.delete hsk
-  where hsk = hashKey $ sp ^. poolPubKey
+  where hsk = sp ^. poolPubKey
         (StakePools pools) = ps ^. stPools
         slot' = fromMaybe slot (Map.lookup hsk pools)
         c = fromMaybe 0 (Map.lookup hsk (ps ^. cCounters))

shelley/chain-and-ledger/executable-spec/src/STS/Deleg.hs

@@ -13,7 +13,7 @@ import           BlockChain (slotsPrior)
 import           Coin (Coin (..))
 import           Delegation.Certificates
 import           Keys
-import           Ledger.Core (dom, singleton, (∈), (∉), (∪), (⋪), (⋫),(⨃))
+import           Ledger.Core (dom, singleton, (∈), (∉), (∪), (⋪), (⋫), (⨃))
 import           LedgerState
 import           Slot
 import           TxData
@@ -22,9 +22,7 @@ import           Control.State.Transition
 
 data DELEG hashAlgo dsignAlgo
 
-instance
-  (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
-  => STS (DELEG hashAlgo dsignAlgo)
+instance STS (DELEG hashAlgo dsignAlgo)
  where
   type State (DELEG hashAlgo dsignAlgo) = DState hashAlgo dsignAlgo
   type Signal (DELEG hashAlgo dsignAlgo) = DCert hashAlgo dsignAlgo
@@ -42,8 +40,7 @@ instance
   transitionRules = [delegationTransition]
 
 delegationTransition
-  :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
-  => TransitionRule (DELEG hashAlgo dsignAlgo)
+  :: TransitionRule (DELEG hashAlgo dsignAlgo)
 delegationTransition = do
   TRC ((slot_, ptr_), ds, c) <- judgmentContext
 
@@ -78,14 +75,11 @@ delegationTransition = do
 
     GenesisDelegate (gkey, vk) -> do
       let s' = slot_ +* slotsPrior
-          gkeyHash = hashKey gkey
-          vkeyHash = hashKey vk
           (Dms dms_) = _dms ds
 
-      gkeyHash ∈ dom dms_ ?! GenesisKeyNotInpMappingDELEG
-
+      gkey ∈ dom dms_ ?! GenesisKeyNotInpMappingDELEG
       pure $ ds
-        { _fdms = _fdms ds ⨃ [((s', gkeyHash), vkeyHash)]}
+        { _fdms = _fdms ds ⨃ [((s', gkey), vk)]}
 
     _ -> do
       failBecause WrongCertificateTypeDELEG -- this always fails

shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs

@@ -9,7 +9,6 @@ module STS.Delegs
   )
 where
 
-import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 
 import           Data.Sequence (Seq (..))
@@ -58,27 +57,13 @@ delegsTransition = do
     Empty -> do
       let ds       = _dstate dpstate
           rewards_ = _rewards ds
-          fdms_    = _fdms ds
-          Dms dms_ = _dms ds
           wdrls_   = _wdrls txbody
 
       wdrls_ ⊆ rewards_ ?! WithrawalsNotInRewardsDELEGS
 
       let rewards' = rewards_ ⨃ [(w, 0) | w <- Set.toList (dom wdrls_)]
 
-      let (curr, fdmsMinCurr) =
-            if Map.null fdms_
-              then (Map.empty, fdms_)
-              else
-                -- maximum exists as fdms isn't empty here
-                let sMax = maximum [s | (s, _) <- Set.toList (dom fdms_)] in
-                Map.partitionWithKey (\(s, _) _ -> s >= _slot && s == sMax) fdms_
-
-      let dms' = [(gk, vk) | ((_, gk), vk) <- Map.toList curr]
-
-      pure $ dpstate { _dstate = ds { _rewards = rewards'
-                                    , _fdms = fdmsMinCurr
-                                    , _dms = Dms $ dms_ ⨃ dms'}}
+      pure $ dpstate { _dstate = ds { _rewards = rewards' } }
 
     certs_ :|> cert -> do
       dpstate' <-

shelley/chain-and-ledger/executable-spec/src/STS/Ledgers.hs

@@ -15,6 +15,7 @@ import           Control.Monad (foldM)
 import           Data.Foldable (toList)
 import qualified Data.Map.Strict as Map
 import           Data.Sequence (Seq)
+import qualified Data.Set as Set
 
 import           Keys
 import           Ledger.Core ((⨃))
@@ -70,7 +71,23 @@ ledgersTransition = do
   let (favs', ready) = Map.partitionWithKey (\s _ -> s > slot) favs
   let avs' = Applications $ apps avs ⨃ (Map.toList . apps $ newAVs avs ready)
   let u''' = UTxOState utxo' dep fee (ppup, aup, favs', avs')
-  pure $ LedgerState u''' dw'' (_txSlotIx ls)
+
+  let ds = _dstate dw''
+      fdms_    = _fdms ds
+      Dms dms_ = _dms ds
+      (fdms', curr) = Map.partitionWithKey (\(s, _) _ -> slot <= s) fdms_
+  let maxSlot = maximum . Set.map fst . Map.keysSet
+  let latestPerGKey gk =
+        ( (maxSlot . Map.filterWithKey (\(_, c) _ -> c == gk)) curr
+        , gk)
+  let dmsKeys = Set.map
+                  latestPerGKey
+                  (Set.map snd (Map.keysSet curr))
+  let dms' = Map.mapKeys snd $ Map.filterWithKey  (\a _ -> a `Set.member` dmsKeys) curr
+  let dw''' = dw'' { _dstate = (_dstate dw'') { _fdms = fdms'
+                                              , _dms = Dms $ dms_ ⨃ Map.toList dms'}}
+
+  pure $ LedgerState u''' dw''' (_txSlotIx ls)
 
 instance
   ( HashAlgorithm hashAlgo

shelley/chain-and-ledger/executable-spec/src/STS/Pool.hs

@@ -21,9 +21,7 @@ import           Control.State.Transition
 
 data POOL hashAlgo dsignAlgo
 
-instance
-  (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
-  => STS (POOL hashAlgo dsignAlgo)
+instance STS (POOL hashAlgo dsignAlgo)
  where
   type State (POOL hashAlgo dsignAlgo) = PState hashAlgo dsignAlgo
   type Signal (POOL hashAlgo dsignAlgo) = DCert hashAlgo dsignAlgo
@@ -37,15 +35,13 @@ instance
   initialRules = [pure emptyPState]
   transitionRules = [poolDelegationTransition]
 
-poolDelegationTransition
-  :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
-  => TransitionRule (POOL hashAlgo dsignAlgo)
+poolDelegationTransition :: TransitionRule (POOL hashAlgo dsignAlgo)
 poolDelegationTransition = do
   TRC ((slot, pp), ps, c) <- judgmentContext
   let StakePools stPools_ = _stPools ps
   case c of
     RegPool poolParam -> do
-      let hk = hashKey (poolParam ^. poolPubKey)
+      let hk = poolParam ^. poolPubKey
 
       if hk ∉ dom stPools_
         then -- register new

shelley/chain-and-ledger/executable-spec/src/STS/Utxow.hs

@@ -21,6 +21,7 @@ import           LedgerState hiding (dms)
 import           PParams
 import           Slot
 import           Tx
+import           TxData
 import           UTxO
 
 import           Control.State.Transition
@@ -78,9 +79,7 @@ utxoWitnessed = do
   TRC ((slot, pp, stakeKeys, stakePools, _dms), u, tx@(Tx _ wits _))
     <- judgmentContext
   verifiedWits tx == Valid ?! InvalidWitnessesUTXOW
-  let witnessKeys = Set.map (\(WitVKey vk _)
-                              -> undiscriminateKeyHash $ hashKey vk
-                            ) wits
+  let witnessKeys = Set.map witKeyHash wits
   let needed = witsVKeyNeeded (_utxo u) tx _dms
   needed `Set.isSubsetOf` witnessKeys  ?! MissingVKeyWitnessesUTXOW
 

shelley/chain-and-ledger/executable-spec/src/Tx.hs

@@ -32,7 +32,7 @@ module Tx
 where
 
 
-import           Keys (AnyKeyHash, KeyHash, hashKey, undiscriminateKeyHash)
+import           Keys (AnyKeyHash, undiscriminateKeyHash)
 
 import           Cardano.Binary (ToCBOR (toCBOR), encodeWord8)
 
@@ -49,8 +49,8 @@ import qualified Data.Set as Set
 
 import           TxData (Credential (..), MultiSig (..), ScriptHash (..), StakeCredential, Tx (..),
                      TxBody (..), TxId (..), TxIn (..), TxOut (..), WitVKey (..), body, certs,
-                     inputs, outputs, ttl, txUpdate, txfee, wdrls, witnessMSigMap, witnessVKeySet
-                     )
+                     inputs, outputs, ttl, txUpdate, txfee, wdrls, witKeyHash, witnessMSigMap,
+                     witnessVKeySet)
 
 -- | Typeclass for multis-signature script data types. Allows for script
 -- validation and hashing.
@@ -63,7 +63,7 @@ class (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo, ToCBOR a) =>
 -- key hashes that signed the transaction to be validated.
 evalNativeMultiSigScript
   :: MultiSig hashAlgo dsignAlgo
-  -> Set (KeyHash hashAlgo dsignAlgo)
+  -> Set (AnyKeyHash hashAlgo dsignAlgo)
   -> Bool
 evalNativeMultiSigScript (RequireSignature hk) vhks = Set.member hk vhks
 evalNativeMultiSigScript (RequireAllOf msigs) vhks =
@@ -82,7 +82,7 @@ validateNativeMultiSigScript
 validateNativeMultiSigScript msig tx =
   evalNativeMultiSigScript msig vhks
   where witsSet = _witnessVKeySet tx
-        vhks    = Set.map (\(WitVKey vk _) -> hashKey vk) witsSet
+        vhks    = Set.map witKeyHash witsSet
 
 -- | Hashes native multi-signature script, appending the 'nativeMultiSigTag' in
 -- front and then calling the script CBOR function.