Use StakeObject in delegation

- also fix use of `stPools` / `stkeys` which was used in reverse
IntersectMBO · Jul 16, 2019 · 0815915 · 0815915
1 parent 0815265
commit 0815915
Show file tree

Hide file tree

Showing 10 changed files with 127 additions and 149 deletions.
diff --git a/shelley/chain-and-ledger/executable-spec/src/Address.hs b/shelley/chain-and-ledger/executable-spec/src/Address.hs
@@ -7,13 +7,13 @@ where
 
 import           Cardano.Crypto.Hash   (HashAlgorithm)
 
-import           Delegation.PoolParams (RewardAcnt(..))
 import           Keys
+import           TxData
 
 mkRwdAcnt
   :: ( HashAlgorithm hashAlgo
      , DSIGNAlgorithm dsignAlgo
      )
   => KeyPair dsignAlgo
   -> RewardAcnt hashAlgo dsignAlgo
-mkRwdAcnt keys = RewardAcnt $ hashKey $ vKey keys
+mkRwdAcnt keys = RewardAcnt $ KeyHashStake (hashKey $ vKey keys)
diff --git a/shelley/chain-and-ledger/executable-spec/src/Delegation/Certificates.hs b/shelley/chain-and-ledger/executable-spec/src/Delegation/Certificates.hs
@@ -24,8 +24,6 @@ import           PParams (PParams (..), keyDecayRate, keyDeposit, keyMinRefund,
 import           Slot (Duration (..))
 import           TxData
 
-import           Delegation.PoolParams
-
 import           BaseTypes
 import           NonIntegral (exp')
 
@@ -38,15 +36,13 @@ import           Lens.Micro ((^.))
 cwitness
   :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
   => DCert hashAlgo dsignAlgo
-  -> KeyHash hashAlgo dsignAlgo
-cwitness (RegKey (KeyHashStake hk))           = hk
-cwitness (DeRegKey (KeyHashStake hk))         = hk
-cwitness (RegKey (ScriptHashStake _))         = undefined
-cwitness (DeRegKey (ScriptHashStake _))       = undefined
-cwitness (RegPool pool)        = hashKey $ pool ^. poolPubKey
-cwitness (RetirePool k _)      = k
-cwitness (Delegate delegation) = hashKey $ delegation ^. delegator
-cwitness (GenesisDelegate (gk, _)) = hashGenesisKey gk
+  -> StakeObject hashAlgo dsignAlgo
+cwitness (RegKey hk)           = hk
+cwitness (DeRegKey hk)         = hk
+cwitness (RegPool pool)        = KeyHashStake $ hashKey $ pool ^. poolPubKey
+cwitness (RetirePool k _)      = KeyHashStake k
+cwitness (Delegate delegation) = delegation ^. delegator
+cwitness (GenesisDelegate (gk, _)) = KeyHashStake $ hashGenesisKey gk
 
 -- |Retrieve the deposit amount for a certificate
 dvalue :: DCert hashAlgo dsignAlgo -> PParams -> Coin

diff --git a/shelley/chain-and-ledger/executable-spec/src/Delegation/PoolParams.hs b/shelley/chain-and-ledger/executable-spec/src/Delegation/PoolParams.hs
@@ -3,86 +3,14 @@
 {-# LANGUAGE TemplateHaskell #-}
 
 module Delegation.PoolParams
-  ( PoolParams(..)
-  , Delegation(..)
-  , RewardAcnt(..)
-  -- lenses
-  , poolPubKey
-  , poolPledge
-  , poolPledges
-  , poolCost
-  , poolMargin
-  , poolAltAcnt
-  , poolSpec
-  , poolRAcnt
-  , poolOwners
-    -- Delegation
-  , delegator
-  , delegatee
+  ( poolSpec
   ) where
 
-import           Data.Map.Strict (Map)
-import           Data.Set      (Set)
-
 import           Lens.Micro    ((^.))
-import           Lens.Micro.TH (makeLenses)
-
-import           Cardano.Binary (ToCBOR(toCBOR), encodeListLen)
 
 import           BaseTypes
 import           Coin          (Coin)
-import           Keys
-
--- |An account based address for a rewards
-newtype RewardAcnt hashAlgo signAlgo = RewardAcnt
-  { getRwdHK :: KeyHash hashAlgo signAlgo
-  } deriving (Show, Eq, Ord, ToCBOR)
-
-
--- |A stake pool.
-data PoolParams hashAlgo dsignAlgo =
-  PoolParams
-    { _poolPubKey  :: VKey dsignAlgo
-    , _poolPledge  :: Coin
-    , _poolPledges :: Map (VKey dsignAlgo) Coin -- TODO not updated currently
-    , _poolCost    :: Coin
-    , _poolMargin  :: UnitInterval
-    , _poolAltAcnt :: Maybe (KeyHash hashAlgo dsignAlgo)
-    , _poolRAcnt   :: RewardAcnt hashAlgo dsignAlgo
-    , _poolOwners  :: Set (KeyHash hashAlgo dsignAlgo)
-    } deriving (Show, Eq, Ord)
-
-makeLenses ''PoolParams
-
-instance
-  (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
-  => ToCBOR (PoolParams hashAlgo dsignAlgo)
- where
-  toCBOR poolParams =
-    encodeListLen 8
-      <> toCBOR (_poolPubKey poolParams)
-      <> toCBOR (_poolPledge poolParams)
-      <> toCBOR (_poolPledges poolParams)
-      <> toCBOR (_poolCost poolParams)
-      <> toCBOR (_poolMargin poolParams)
-      <> toCBOR (_poolAltAcnt poolParams)
-      <> toCBOR (_poolRAcnt poolParams)
-      <> toCBOR (_poolOwners poolParams)
-
+import           TxData
 
 poolSpec :: PoolParams hashAlgo dsignAlgo -> (Coin, UnitInterval, Coin)
 poolSpec pool = (pool ^. poolCost, pool ^. poolMargin, pool ^. poolPledge)
-
--- |The delegation of one stake key to another.
-data Delegation dsignAlgo = Delegation
-  { _delegator :: VKey dsignAlgo
-  , _delegatee :: VKey dsignAlgo
-  } deriving (Show, Eq, Ord)
-
-instance DSIGNAlgorithm dsignAlgo => ToCBOR (Delegation dsignAlgo) where
-  toCBOR delegation =
-    encodeListLen 2
-      <> toCBOR (_delegator delegation)
-      <> toCBOR (_delegatee delegation)
-
-makeLenses ''Delegation
diff --git a/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs b/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs
@@ -33,7 +33,6 @@ module EpochBoundary
 import           Coin
 import           Delegation.Certificates (StakeKeys (..), StakePools (..),
                                           decayKey, decayPool, refund)
-import           Delegation.PoolParams   (RewardAcnt (..), PoolParams(..))
 import           Keys
 import           PParams hiding (a0, nOpt)
 import           Slot
@@ -59,12 +58,13 @@ newtype BlocksMade hashAlgo dsignAlgo
 
 -- | Type of stake as map from hash key to coins associated.
 newtype Stake hashAlgo dsignAlgo
-  = Stake (Map.Map (KeyHash hashAlgo dsignAlgo) Coin)
+  = Stake (Map.Map (StakeObject hashAlgo dsignAlgo) Coin)
   deriving (Show, Eq, Ord)
 
 -- | Extract hash of staking key from base address.
-getStakeHK :: Addr hashAlgo dsignAlgo -> Maybe (KeyHash hashAlgo dsignAlgo)
-getStakeHK (AddrVKey _ hk) = Just hk
+getStakeHK :: Addr hashAlgo dsignAlgo -> Maybe (StakeObject hashAlgo dsignAlgo)
+getStakeHK (AddrVKey _ hk) = Just $ KeyHashStake hk
+getStakeHK (AddrScr _ hs) = Just $ ScriptHashStake hs
 getStakeHK _               = Nothing
 
 consolidate :: UTxO hashAlgo dsignAlgo -> Map.Map (Addr hashAlgo dsignAlgo) Coin
@@ -78,7 +78,7 @@ baseStake vals =
  where
    convert
      :: (Addr hashAlgo dsignAlgo, Coin)
-     -> Maybe (KeyHash hashAlgo dsignAlgo, Coin)
+     -> Maybe (StakeObject hashAlgo dsignAlgo, Coin)
    convert (a, c) =
      (,c) <$> getStakeHK a
 
@@ -91,14 +91,14 @@ getStakePtr _             = Nothing
 ptrStake
   :: forall hashAlgo dsignAlgo
    . Map.Map (Addr hashAlgo dsignAlgo) Coin
-  -> Map.Map Ptr (KeyHash hashAlgo dsignAlgo)
+  -> Map.Map Ptr (StakeObject hashAlgo dsignAlgo)
   -> Stake hashAlgo dsignAlgo
 ptrStake vals pointers =
   Stake $ Map.fromListWith (+) (mapMaybe convert $ Map.toList vals)
   where
     convert
       :: (Addr hashAlgo dsignAlgo, Coin)
-      -> Maybe (KeyHash hashAlgo dsignAlgo, Coin)
+      -> Maybe (StakeObject hashAlgo dsignAlgo, Coin)
     convert (a, c) =
       case getStakePtr a of
         Nothing -> Nothing
@@ -117,7 +117,7 @@ rewardStake rewards =
 -- | Get stake of one pool
 poolStake
   :: KeyHash hashAlgo dsignAlgo
-  -> Map.Map (KeyHash hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo)
+  -> Map.Map (StakeObject hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo)
   -> Stake hashAlgo dsignAlgo
   -> Stake hashAlgo dsignAlgo
 poolStake hk delegs (Stake stake) =
@@ -183,15 +183,15 @@ data SnapShots hashAlgo dsignAlgo
   = SnapShots
     { _pstakeMark
       :: ( Stake hashAlgo dsignAlgo
-         , Map.Map (KeyHash hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo)
+         , Map.Map (StakeObject hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo)
          )
     , _pstakeSet
       :: ( Stake hashAlgo dsignAlgo
-         , Map.Map (KeyHash hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo)
+         , Map.Map (StakeObject hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo)
          )
     , _pstakeGo
       :: ( Stake hashAlgo dsignAlgo
-         , Map.Map (KeyHash hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo)
+         , Map.Map (StakeObject hashAlgo dsignAlgo) (KeyHash hashAlgo dsignAlgo)
          )
     , _poolsSS
       :: Map.Map (KeyHash hashAlgo dsignAlgo) (PoolParams hashAlgo dsignAlgo)