Merge pull request #638 from input-output-hk/shelley/exec_spec/multi-…

…signature

Simple Multi-signature scheme

shelley/chain-and-ledger/executable-spec/delegation.cabal

@@ -17,7 +17,8 @@ flag development
     manual: True
 
 library
-  exposed-modules:   BaseTypes
+  exposed-modules:   Address
+                     BaseTypes
                      BlockChain
                      Coin
                      Keys
@@ -29,6 +30,8 @@ library
                      Delegation.PoolParams
                      Delegation.Certificates
                      OCert
+                     Tx
+                     TxData
                      Updates
                      STS.Avup
                      STS.Bbody

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

@@ -0,0 +1,19 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Address
+  ( mkRwdAcnt
+  )
+where
+
+import           Cardano.Crypto.Hash   (HashAlgorithm)
+
+import           Keys
+import           TxData
+
+mkRwdAcnt
+  :: ( HashAlgorithm hashAlgo
+     , DSIGNAlgorithm dsignAlgo
+     )
+  => KeyPair dsignAlgo
+  -> RewardAcnt hashAlgo dsignAlgo
+mkRwdAcnt keys = RewardAcnt $ KeyHashStake (hashKey $ vKey keys)

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

@@ -42,7 +42,7 @@ import           EpochBoundary
 import           Keys
 import           OCert
 import qualified Slot
-import qualified UTxO                          as U
+import           Tx
 
 import           NonIntegral                    ( (***) )
 
@@ -53,7 +53,7 @@ newtype HashHeader hashAlgo dsignAlgo kesAlgo =
 
 -- | Hash of block body
 newtype HashBBody hashAlgo dsignAlgo kesAlgo =
-  HashBBody (Hash hashAlgo [U.Tx hashAlgo dsignAlgo])
+  HashBBody (Hash hashAlgo [Tx hashAlgo dsignAlgo])
   deriving (Show, Eq, Ord, ToCBOR)
 
 -- |Hash a given block header
@@ -66,7 +66,7 @@ bhHash = HashHeader . hash
 -- |Hash a given block body
 bhbHash
   :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
-  => [U.Tx hashAlgo dsignAlgo]
+  => [Tx hashAlgo dsignAlgo]
   -> HashBBody hashAlgo dsignAlgo kesAlgo
 bhbHash = HashBBody . hash
 
@@ -120,7 +120,7 @@ data BHBody hashAlgo dsignAlgo kesAlgo = BHBody
     -- | proof of leader election
   , bheaderPrfL           :: Proof dsignAlgo UnitInterval
     -- | signature of block body
-  , bheaderBlockSignature :: Sig dsignAlgo [U.Tx hashAlgo dsignAlgo]
+  , bheaderBlockSignature :: Sig dsignAlgo [Tx hashAlgo dsignAlgo]
     -- | Size of the block body
   , bsize                 :: Natural
     -- | Hash of block body
@@ -133,24 +133,24 @@ instance
   (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo, KESAlgorithm kesAlgo)
   => ToCBOR (BHBody hashAlgo dsignAlgo kesAlgo)
  where
-  toCBOR body =
+  toCBOR bhBody =
     encodeListLen 11
-      <> toCBOR (bheaderPrev body)
-      <> toCBOR (bheaderVk body)
-      <> toCBOR (bheaderSlot body)
-      <> toCBOR (bheaderEta body)
-      <> toCBOR (bheaderPrfEta body)
-      <> toCBOR (bheaderL body)
-      <> toCBOR (bheaderPrfL body)
-      <> toCBOR (bheaderBlockSignature body)
-      <> toCBOR (bsize body)
-      <> toCBOR (bhash body)
-      <> toCBOR (bheaderOCert body)
+      <> toCBOR (bheaderPrev bhBody)
+      <> toCBOR (bheaderVk bhBody)
+      <> toCBOR (bheaderSlot bhBody)
+      <> toCBOR (bheaderEta bhBody)
+      <> toCBOR (bheaderPrfEta bhBody)
+      <> toCBOR (bheaderL bhBody)
+      <> toCBOR (bheaderPrfL bhBody)
+      <> toCBOR (bheaderBlockSignature bhBody)
+      <> toCBOR (bsize bhBody)
+      <> toCBOR (bhash bhBody)
+      <> toCBOR (bheaderOCert bhBody)
 
 data Block hashAlgo dsignAlgo kesAlgo
   = Block
     (BHeader hashAlgo dsignAlgo kesAlgo)
-    [U.Tx hashAlgo dsignAlgo]
+    [Tx hashAlgo dsignAlgo]
   deriving (Show, Eq)
 
 bHeaderSize
@@ -159,7 +159,7 @@ bHeaderSize
   -> Int
 bHeaderSize = BS.length . BS.pack . show
 
-bBodySize :: DSIGNAlgorithm dsignAlgo => [U.Tx hashAlgo dsignAlgo] -> Int
+bBodySize :: DSIGNAlgorithm dsignAlgo => [Tx hashAlgo dsignAlgo] -> Int
 bBodySize txs = foldl (+) 0 (map (BS.length . BS.pack . show) txs)
 
 slotToSeed :: Slot.Slot -> Seed
@@ -168,7 +168,7 @@ slotToSeed (Slot.Slot s) = mkNonce (fromIntegral s)
 bheader :: Block hashAlgo dsignAlgo kesAlgo -> BHeader hashAlgo dsignAlgo kesAlgo
 bheader (Block bh _) = bh
 
-bbody :: Block hashAlgo dsignAlgo kesAlgo -> [U.Tx hashAlgo dsignAlgo]
+bbody :: Block hashAlgo dsignAlgo kesAlgo -> [Tx hashAlgo dsignAlgo]
 bbody (Block _ txs) = txs
 
 bhbody :: BHeader hashAlgo dsignAlgo kesAlgo -> BHBody hashAlgo dsignAlgo kesAlgo

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

@@ -17,96 +17,32 @@ module Delegation.Certificates
   , decayPool
   ) where
 
-import           Cardano.Binary (ToCBOR(toCBOR), encodeListLen)
-
 import           Coin (Coin (..))
 import           Keys
 import           PParams (PParams (..), keyDecayRate, keyDeposit, keyMinRefund, poolDecayRate,
                      poolDeposit, poolMinRefund)
-import           Slot (Duration (..), Epoch (..), Slot (..))
-
-import           Delegation.PoolParams
+import           Slot (Duration (..))
+import           TxData
 
 import           BaseTypes
 import           NonIntegral (exp')
 
 import qualified Data.Map.Strict as Map
 import           Data.Ratio (approxRational)
-import           Data.Word (Word8)
 
 import           Lens.Micro ((^.))
 
-newtype StakeKeys hashAlgo dsignAlgo =
-  StakeKeys (Map.Map (KeyHash hashAlgo dsignAlgo) Slot)
-  deriving (Show, Eq)
-
-newtype StakePools hashAlgo dsignAlgo =
-  StakePools (Map.Map (KeyHash hashAlgo dsignAlgo) Slot)
-  deriving (Show, Eq)
-
--- | A heavyweight certificate.
-data DCert hashAlgo dsignAlgo
-    -- | A stake key registration certificate.
-  = RegKey (VKey dsignAlgo)
-    -- | A stake key deregistration certificate.
-  | DeRegKey (VKey dsignAlgo) --TODO this is actually KeyHash on page 13, is that what we want?
-    -- | A stake pool registration certificate.
-  | RegPool (PoolParams hashAlgo dsignAlgo)
-    -- | A stake pool retirement certificate.
-  | RetirePool (VKey dsignAlgo) Epoch
-    -- | A stake delegation certificate.
-  | Delegate (Delegation dsignAlgo)
-    -- | Genesis key delegation certificate
-  | GenesisDelegate (VKeyGenesis dsignAlgo, VKey dsignAlgo)
-  deriving (Show, Eq, Ord)
-
-instance
-  (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
-  => ToCBOR (DCert hashAlgo dsignAlgo)
- where
-  toCBOR = \case
-    RegKey vk ->
-      encodeListLen 2
-        <> toCBOR (0 :: Word8)
-        <> toCBOR vk
-
-    DeRegKey vk ->
-      encodeListLen 2
-        <> toCBOR (1 :: Word8)
-        <> toCBOR vk
-
-    RegPool poolParams ->
-      encodeListLen 2
-        <> toCBOR (2 :: Word8)
-        <> toCBOR poolParams
-
-    RetirePool vk epoch ->
-      encodeListLen 3
-        <> toCBOR (3 :: Word8)
-        <> toCBOR vk
-        <> toCBOR epoch
-
-    Delegate delegation ->
-      encodeListLen 2
-        <> toCBOR (4 :: Word8)
-        <> toCBOR delegation
-
-    GenesisDelegate keys ->
-      encodeListLen 2
-        <> toCBOR (5 :: Word8)
-        <> toCBOR keys
-
 -- |Determine the certificate author
 cwitness
   :: (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
   => DCert hashAlgo dsignAlgo
-  -> KeyHash hashAlgo dsignAlgo
-cwitness (RegKey k)            = hashKey k
-cwitness (DeRegKey k)          = hashKey k
-cwitness (RegPool pool)        = hashKey $ pool ^. poolPubKey
-cwitness (RetirePool k _)      = hashKey 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

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