Refactor MultiSig / Tx defs to Tx module

- move transaction definitions from `UTxO` to own module - add hashScript to `MultiSignatureScript` typeclass - define first tag for native multi-signature - move address defintions to `Address module`
IntersectMBO · Jul 15, 2019 · 0815395 · 0815395
1 parent 081529e
commit 0815395
Show file tree

Hide file tree

Showing 23 changed files with 415 additions and 339 deletions.
diff --git a/shelley/chain-and-ledger/executable-spec/delegation.cabal b/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
@@ -26,10 +27,10 @@ library
                      PParams
                      EpochBoundary
                      LedgerState
-                     MultiSig
                      Delegation.PoolParams
                      Delegation.Certificates
                      OCert
+                     Tx
                      Updates
                      STS.Avup
                      STS.Bbody

diff --git a/shelley/chain-and-ledger/executable-spec/src/Address.hs b/shelley/chain-and-ledger/executable-spec/src/Address.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Address
+  ( Addr(..)
+  , Ix
+  , Ptr(..)
+  , mkRwdAcnt
+  )
+where
+
+import           Data.Typeable           (Typeable)
+import           Data.Word               (Word8)
+import           Numeric.Natural         (Natural)
+
+import           Cardano.Binary          (ToCBOR(toCBOR), encodeListLen)
+import           Cardano.Crypto.Hash   (HashAlgorithm)
+
+import           Delegation.PoolParams (RewardAcnt(..))
+import           Keys
+import           Slot (Slot(..))
+
+-- |An address for UTxO.
+data Addr hashAlgo dsignAlgo
+  = AddrTxin
+      { _payHK :: KeyHash hashAlgo dsignAlgo
+      , _stakeHK :: KeyHash hashAlgo dsignAlgo
+      }
+  | AddrPtr
+      { _stakePtr :: Ptr
+      }
+  deriving (Show, Eq, Ord)
+
+instance
+  (Typeable dsignAlgo, HashAlgorithm hashAlgo)
+  => ToCBOR (Addr hashAlgo dsignAlgo)
+ where
+  toCBOR = \case
+    AddrTxin payHK stakeHK ->
+      encodeListLen 3
+        <> toCBOR (0 :: Word8)
+        <> toCBOR payHK
+        <> toCBOR stakeHK
+    AddrPtr stakePtr ->
+      encodeListLen 2
+        <> toCBOR (1 :: Word8)
+        <> toCBOR stakePtr
+
+type Ix  = Natural
+
+-- | Pointer to a slot, transaction index and index in certificate list.
+data Ptr
+  = Ptr Slot Ix Ix
+  deriving (Show, Eq, Ord)
+
+instance ToCBOR Ptr where
+  toCBOR (Ptr slot txIx certIx) =
+    encodeListLen 3
+      <> toCBOR slot
+      <> toCBOR txIx
+      <> toCBOR certIx
+
+mkRwdAcnt
+  :: ( HashAlgorithm hashAlgo
+     , DSIGNAlgorithm dsignAlgo
+     )
+  => KeyPair dsignAlgo
+  -> RewardAcnt hashAlgo dsignAlgo
+mkRwdAcnt keys = RewardAcnt $ hashKey $ vKey keys
diff --git a/shelley/chain-and-ledger/executable-spec/src/BlockChain.hs b/shelley/chain-and-ledger/executable-spec/src/BlockChain.hs
@@ -41,7 +41,7 @@ import           EpochBoundary
 import           Keys
 import           OCert
 import qualified Slot
-import qualified UTxO                          as U
+import           Tx
 
 import           NonIntegral                    ( (***) )
 
@@ -52,7 +52,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
@@ -65,7 +65,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
 
@@ -115,7 +115,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
@@ -128,24 +128,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
@@ -154,7 +154,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
@@ -163,7 +163,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

diff --git a/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs b/shelley/chain-and-ledger/executable-spec/src/EpochBoundary.hs
@@ -30,13 +30,15 @@ module EpochBoundary
   , groupByPool
   ) where
 
+import           Address
 import           Coin
 import           Delegation.Certificates (StakeKeys (..), StakePools (..),
                                           decayKey, decayPool, refund)
 import           Delegation.PoolParams   (RewardAcnt (..), PoolParams(..))
 import           Keys
 import           PParams hiding (a0, nOpt)
 import           Slot
+import           Tx
 import           UTxO hiding (dom)
 
 import qualified Data.Map.Strict         as Map

diff --git a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs
@@ -120,12 +120,14 @@ import           Numeric.Natural (Natural)
 import           Lens.Micro ((%~), (&), (.~), (^.))
 import           Lens.Micro.TH (makeLenses)
 
+import           Address
 import           Coin (Coin (..))
 import           EpochBoundary
 import           Keys
 import           PParams (PParams (..), emptyPParams, keyDecayRate, keyDeposit, keyMinRefund,
                      minfeeA, minfeeB)
 import           Slot (Epoch (..), Slot (..), epochFromSlot, firstSlot, slotsPerEpoch, (-*))
+import           Tx
 import qualified Updates
 import           UTxO
 
@@ -553,7 +555,7 @@ witsNeeded
   -> Tx hashAlgo dsignAlgo
   -> Dms dsignAlgo
   -> Set (KeyHash hashAlgo dsignAlgo)
-witsNeeded utxo' tx@(Tx txbody _) _dms =
+witsNeeded utxo' tx@(Tx txbody _ _) _dms =
     inputAuthors `Set.union`
     wdrlAuthors  `Set.union`
     certAuthors  `Set.union`
@@ -582,7 +584,7 @@ verifiedWits
      )
   => Tx hashAlgo dsignAlgo
   -> Validity
-verifiedWits (Tx tx wits) =
+verifiedWits (Tx tx wits _) =
   if all (verifyWitVKey tx) wits
     then Valid
     else Invalid [InvalidWitness]
@@ -598,7 +600,7 @@ enoughWits
   -> Dms dsignAlgo
   -> UTxOState hashAlgo dsignAlgo
   -> Validity
-enoughWits tx@(Tx _ wits) d u =
+enoughWits tx@(Tx _ wits _) d u =
   if witsNeeded (u ^. utxo) tx d `Set.isSubsetOf` signers
     then Valid
     else Invalid [MissingWitnesses]

diff --git a/shelley/chain-and-ledger/executable-spec/src/MultiSig.hs b/shelley/chain-and-ledger/executable-spec/src/MultiSig.hs
diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Bbody.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Bbody.hs
@@ -19,7 +19,7 @@ import           Keys
 import           LedgerState
 import           PParams
 import           Slot
-import           UTxO
+import           Tx
 
 import           Control.State.Transition
 

diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Chain.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Chain.hs
@@ -19,7 +19,7 @@ import           Keys
 import           LedgerState
 import           OCert
 import           Slot
-import           UTxO
+import           Tx
 
 import           Control.State.Transition
 

diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Deleg.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Deleg.hs
@@ -8,12 +8,12 @@ where
 
 import qualified Data.Map.Strict as Map
 
+import           Address
 import           BlockChain (slotsPrior)
 import           Delegation.Certificates
 import           Keys
 import           LedgerState
 import           Slot
-import           UTxO
 
 import           Control.State.Transition
 

diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs
@@ -11,13 +11,14 @@ where
 
 import qualified Data.Map.Strict as Map
 
+import           Address
 import           Delegation.Certificates
 import           Delegation.PoolParams
 import           Keys
 import           LedgerState
 import           PParams hiding (d)
 import           Slot
-import           UTxO
+import           Tx
 
 import           Control.State.Transition
 
@@ -49,7 +50,7 @@ delegsTransition
    . (HashAlgorithm hashAlgo, DSIGNAlgorithm dsignAlgo)
   => TransitionRule (DELEGS hashAlgo dsignAlgo)
 delegsTransition = do
-  TRC (env@(_slot, txIx, pp, Tx txbody _), dpstate, certificates) <- judgmentContext
+  TRC (env@(_slot, txIx, pp, Tx txbody _ _), dpstate, certificates) <- judgmentContext
   case certificates of
     [] -> do
       let wdrls' = _wdrls txbody

diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs
@@ -9,10 +9,10 @@ module STS.Delpl
   )
 where
 
+import           Address
 import           Keys
 import           LedgerState
 import           Delegation.Certificates
-import           UTxO
 import           PParams hiding (d)
 import           Slot
 

diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Ledger.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Ledger.hs
@@ -16,7 +16,7 @@ import           Keys
 import           LedgerState
 import           PParams hiding (d)
 import           Slot
-import           UTxO
+import           Tx
 
 import           Control.State.Transition