Merge pull request #639 from input-output-hk/exec_spec/shelley/small-…

…chain-sts-test

simple Shelley CHAIN STS test

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

@@ -85,6 +85,7 @@ test-suite delegation-test
                          Mutator
                          Generator
                          PropertyTests
+                         STSTests
     hs-source-dirs:      test
     ghc-options:
       -threaded
@@ -100,6 +101,7 @@ test-suite delegation-test
       -Werror
     build-depends:
       base,
+      cryptonite,
       tasty,
       tasty-hunit,
       tasty-hedgehog,
@@ -110,4 +112,5 @@ test-suite delegation-test
       text,
       microlens,
       cs-ledger,
-      cardano-crypto-class
+      cardano-crypto-class,
+      small-steps

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

@@ -5,6 +5,7 @@ module BlockChain
   , BHBody(..)
   , BHeader(..)
   , Block(..)
+  , Proof(..)
   , bhHash
   , bhbHash
   , bHeaderSize
@@ -101,7 +102,11 @@ instance
 
 data BHBody hashAlgo dsignAlgo kesAlgo = BHBody
   { -- | Hash of the previous block header
-    bheaderPrev           :: HashHeader hashAlgo dsignAlgo kesAlgo
+    -- The first block in a chain will set this field to Nothing.
+    -- TODO Since the Shelley chain will begins with blocks from
+    -- the Byron era, we should probably use a sum type here,
+    -- so that the first shelley block can point to the last Byron block.
+    bheaderPrev           :: Maybe (HashHeader hashAlgo dsignAlgo kesAlgo)
     -- | verification key of block issuer
   , bheaderVk             :: VKey dsignAlgo
     -- | block slot

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

@@ -202,11 +202,11 @@ hashKeyES (VKeyES vKeyES) =
 -- |Produce a key evolving signature
 signKES
   :: (KESAlgorithm kesAlgo, KES.Signable kesAlgo a, ToCBOR a)
-  => SignKeyKES kesAlgo
+  => SKeyES kesAlgo
   -> a
   -> Natural
   -> KESig kesAlgo a
-signKES k d n =
+signKES (SKeyES k) d n =
   KESig
     . fst
     . fromJust

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

@@ -43,7 +43,7 @@ instance
     = ( NewEpochState hashAlgo dsignAlgo
       , Seed
       , Seed
-      , HashHeader hashAlgo dsignAlgo kesAlgo
+      , Maybe (HashHeader hashAlgo dsignAlgo kesAlgo)
       , Slot
       )
 

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

@@ -39,7 +39,7 @@ instance
  where
   type State (PRTCL hashAlgo dsignAlgo kesAlgo)
     = ( Map.Map (KeyHash hashAlgo dsignAlgo) Natural
-      , HashHeader hashAlgo dsignAlgo kesAlgo
+      , Maybe (HashHeader hashAlgo dsignAlgo kesAlgo)
       , Slot
       , Seed
       , Seed
@@ -89,7 +89,7 @@ prtclTransition = do
   cs'            <- trans @(OVERLAY hashAlgo dsignAlgo kesAlgo) $ TRC (oe, cs, bh)
   (etaV', etaC') <- trans @UPDN $ TRC (eta, (etaV, etaC), slot)
 
-  pure (cs', bhHash bh, slot, etaV', etaC')
+  pure (cs', Just $ bhHash bh, slot, etaV', etaC')
 
 instance
   ( HashAlgorithm hashAlgo

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

@@ -51,7 +51,7 @@ slotFromEpoch :: Epoch -> Slot
 slotFromEpoch (Epoch n) = Slot $ slotsPerEpoch * n
 
 epochFromSlot :: Slot -> Epoch
-epochFromSlot (Slot n) = Epoch $ n `rem` slotsPerEpoch
+epochFromSlot (Slot n) = Epoch $ n `div` slotsPerEpoch
 
 firstSlot :: Epoch -> Slot
 firstSlot = slotFromEpoch

shelley/chain-and-ledger/executable-spec/test/MockTypes.hs

@@ -2,11 +2,15 @@ module MockTypes where
 
 import           Cardano.Crypto.DSIGN (MockDSIGN)
 import           Cardano.Crypto.Hash (ShortHash)
+import           Cardano.Crypto.KES (MockKES)
 
+import qualified BlockChain
 import qualified Delegation.Certificates
 import qualified Delegation.PoolParams
 import qualified Keys
 import qualified LedgerState
+import qualified OCert
+import qualified STS.Chain
 import qualified UTxO
 
 type DCert = Delegation.Certificates.DCert ShortHash MockDSIGN
@@ -44,3 +48,27 @@ type TxIn = UTxO.TxIn ShortHash MockDSIGN
 type TxOut = UTxO.TxOut ShortHash MockDSIGN
 
 type UTxO = UTxO.UTxO ShortHash MockDSIGN
+
+type Block = BlockChain.Block ShortHash MockDSIGN MockKES
+
+type BHBody = BlockChain.BHBody ShortHash MockDSIGN MockKES
+
+type SKeyES = Keys.SKeyES MockKES
+
+type VKeyES = Keys.VKeyES MockKES
+
+type KESig = Keys.KESig MockKES BHBody
+
+type Sig a = Keys.Sig MockDSIGN a
+
+type Proof a = BlockChain.Proof MockDSIGN
+
+type BHeader = BlockChain.BHeader ShortHash MockDSIGN MockKES
+
+type OCert = OCert.OCert MockDSIGN MockKES
+
+type HashHeader = BlockChain.HashHeader ShortHash MockDSIGN MockKES
+
+type NewEpochState = LedgerState.NewEpochState ShortHash MockDSIGN
+
+type CHAIN = STS.Chain.CHAIN ShortHash MockDSIGN MockKES

shelley/chain-and-ledger/executable-spec/test/STSTests.hs

@@ -0,0 +1,107 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeApplications #-}
+
+module STSTests (stsTests) where
+
+import           Data.Either (isLeft)
+import qualified Data.Map.Strict as Map (empty)
+import           Data.Maybe (fromMaybe)
+import           Data.Word (Word64)
+import           Test.Tasty (TestTree, testGroup)
+import           Test.Tasty.HUnit (Assertion, testCase, (@?=))
+
+import           Cardano.Crypto.KES (deriveVerKeyKES, genKeyKES)
+import           Crypto.Random (drgNewTest, withDRG)
+import           MockTypes (CHAIN, SKeyES, VKeyES)
+
+import           BaseTypes (Seed (..), mkUnitInterval)
+import           BlockChain (pattern BHBody, pattern BHeader, pattern Block, pattern Proof, bhbHash)
+import           Control.State.Transition (TRC (..), applySTS)
+import           Delegation.Certificates (PoolDistr (..))
+import           EpochBoundary (BlocksMade (..))
+import           Keys (pattern KeyPair, pattern SKeyES, pattern VKeyES, sKey, sign, signKES, vKey)
+import           LedgerState (pattern NewEpochState, emptyEpochState)
+import           OCert (KESPeriod (..), pattern OCert)
+import           Slot (Epoch (..), Slot (..))
+import           STS.Updn (UPDN)
+
+
+-- | The UPDN transition should update both the evolving nonce and
+-- the candidate nonce during the first two-thirds of the epoch.
+-- Note that the number of slots per epoch is hard-coded in the Slot module.
+testUPNEarly :: Assertion
+testUPNEarly =
+  let
+    st = applySTS @UPDN (TRC (Nonce 1, (Nonce 2, Nonce 3), Slot.Slot 5))
+  in
+    st @?= Right (SeedOp (Nonce 2) (Nonce 1), SeedOp (Nonce 3) (Nonce 1))
+
+-- | The UPDN transition should update only the evolving nonce
+-- in the last thirds of the epoch.
+-- Note that the number of slots per epoch is hard-coded in the Slot module.
+testUPNLate :: Assertion
+testUPNLate =
+  let
+    st = applySTS @UPDN (TRC (Nonce 1, (Nonce 2, Nonce 3), Slot.Slot 85))
+  in
+    st @?= Right (SeedOp (Nonce 2) (Nonce 1), Nonce 3)
+
+-- | For testing purposes, generate a deterministic KES key pair given a seed.
+mkKESKeyPair :: (Word64, Word64, Word64, Word64, Word64) -> (SKeyES, VKeyES)
+mkKESKeyPair seed = fst . withDRG (drgNewTest seed) $ do
+  sk <- genKeyKES 90
+  return (SKeyES sk, VKeyES $ deriveVerKeyKES sk)
+
+-- | This is a very simple test demonstrating that we have everything in place
+-- in order to run the CHAIN STS transition.
+-- TODO replace this test with one that does more than just apply the rule.
+testApplyChain :: Assertion
+testApplyChain =
+  let
+    initChainSt =
+      ( NewEpochState
+          (Epoch 0)
+          (Nonce 0)
+          (BlocksMade Map.empty)
+          (BlocksMade Map.empty)
+          emptyEpochState
+          Nothing
+          (PoolDistr Map.empty)
+          Map.empty
+      , Nonce 0
+      , Nonce 0
+      , Nothing
+      , Slot 0
+      )
+    kp = KeyPair 1 1
+    half = fromMaybe (error "could not construct unit interval") $ mkUnitInterval 0.5
+    (sKeyES, vKeyES) = mkKESKeyPair (0, 0, 0, 0, 0)
+    bhb = BHBody
+            Nothing
+            (vKey kp)
+            (Slot 0)
+            (Nonce 0)
+            (Proof (vKey kp) (Nonce 0))
+            half
+            (Proof (vKey kp) half)
+            (sign (sKey kp) [])
+            100
+            (bhbHash [])
+            (OCert
+              vKeyES
+              (vKey kp)
+              0
+              (KESPeriod 0)
+              (sign (sKey kp) (vKeyES, 0, KESPeriod 0))
+            )
+    block = Block (BHeader bhb (Keys.signKES sKeyES bhb 0)) []
+    newSt = applySTS @CHAIN (TRC (Slot 0, initChainSt, block))
+  in
+    isLeft newSt @?= True
+
+stsTests :: TestTree
+stsTests = testGroup "STS Tests"
+  [ testCase "update nonce early in the epoch" testUPNEarly
+  , testCase "update nonce late in the epoch" testUPNLate
+  , testCase "apply CHAIN transition" testApplyChain
+  ]

shelley/chain-and-ledger/executable-spec/test/Tests.hs

@@ -1,10 +1,11 @@
-import Test.Tasty
+import           Test.Tasty
 
-import UnitTests     (unitTests)
-import PropertyTests (propertyTests)
+import           PropertyTests (propertyTests)
+import           STSTests (stsTests)
+import           UnitTests (unitTests)
 
 tests :: TestTree
-tests = testGroup "Ledger with Delegation" [unitTests, propertyTests]
+tests = testGroup "Ledger with Delegation" [unitTests, propertyTests, stsTests]
 
 -- main entry point
 main :: IO ()