From b9903ee5494045c949f1a63d0f88af32826c9045 Mon Sep 17 00:00:00 2001 From: Jared Corduan Date: Fri, 12 Jul 2019 11:35:25 -0400 Subject: [PATCH 1/3] Issue #637: simple Shelley CHAIN STS test --- .../executable-spec/delegation.cabal | 5 +- .../executable-spec/src/BlockChain.hs | 7 +- .../executable-spec/src/Keys.hs | 4 +- .../executable-spec/src/STS/Chain.hs | 2 +- .../executable-spec/src/STS/Prtcl.hs | 4 +- .../executable-spec/src/Slot.hs | 2 +- .../executable-spec/test/MockTypes.hs | 28 +++++ .../executable-spec/test/STSTests.hs | 107 ++++++++++++++++++ .../executable-spec/test/Tests.hs | 3 +- 9 files changed, 153 insertions(+), 9 deletions(-) create mode 100644 shelley/chain-and-ledger/executable-spec/test/STSTests.hs diff --git a/shelley/chain-and-ledger/executable-spec/delegation.cabal b/shelley/chain-and-ledger/executable-spec/delegation.cabal index 11ad52dc629..09d2b2ed34b 100644 --- a/shelley/chain-and-ledger/executable-spec/delegation.cabal +++ b/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 diff --git a/shelley/chain-and-ledger/executable-spec/src/BlockChain.hs b/shelley/chain-and-ledger/executable-spec/src/BlockChain.hs index 2c75c15fbcb..33808543f05 100644 --- a/shelley/chain-and-ledger/executable-spec/src/BlockChain.hs +++ b/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 diff --git a/shelley/chain-and-ledger/executable-spec/src/Keys.hs b/shelley/chain-and-ledger/executable-spec/src/Keys.hs index 06155de4cd1..3270eb2f29c 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Keys.hs +++ b/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 diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Chain.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Chain.hs index 6cf6ece8676..eb91ca6a284 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Chain.hs +++ b/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 ) diff --git a/shelley/chain-and-ledger/executable-spec/src/STS/Prtcl.hs b/shelley/chain-and-ledger/executable-spec/src/STS/Prtcl.hs index da5ce672762..2196b647f0c 100644 --- a/shelley/chain-and-ledger/executable-spec/src/STS/Prtcl.hs +++ b/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 diff --git a/shelley/chain-and-ledger/executable-spec/src/Slot.hs b/shelley/chain-and-ledger/executable-spec/src/Slot.hs index 7c2f05a633f..c9d8129b571 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Slot.hs +++ b/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 diff --git a/shelley/chain-and-ledger/executable-spec/test/MockTypes.hs b/shelley/chain-and-ledger/executable-spec/test/MockTypes.hs index d380bd7db4e..af75d8b2742 100644 --- a/shelley/chain-and-ledger/executable-spec/test/MockTypes.hs +++ b/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 diff --git a/shelley/chain-and-ledger/executable-spec/test/STSTests.hs b/shelley/chain-and-ledger/executable-spec/test/STSTests.hs new file mode 100644 index 00000000000..5f3de4a3296 --- /dev/null +++ b/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 +import Data.Maybe (fromMaybe) +import Data.Word (Word64) +import Test.Tasty +import Test.Tasty.HUnit + +import Cardano.Crypto.KES (deriveVerKeyKES, genKeyKES) +import Crypto.Random (drgNewTest, withDRG) +import MockTypes + +import BaseTypes (Seed (..), mkUnitInterval) +import BlockChain (pattern BHBody, pattern BHeader, pattern Block, pattern Proof, bhbHash) +import Control.State.Transition +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 + + +-- | 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 + ] diff --git a/shelley/chain-and-ledger/executable-spec/test/Tests.hs b/shelley/chain-and-ledger/executable-spec/test/Tests.hs index 80248f8040e..680883822f0 100644 --- a/shelley/chain-and-ledger/executable-spec/test/Tests.hs +++ b/shelley/chain-and-ledger/executable-spec/test/Tests.hs @@ -2,9 +2,10 @@ import Test.Tasty import UnitTests (unitTests) import PropertyTests (propertyTests) +import STSTests (stsTests) tests :: TestTree -tests = testGroup "Ledger with Delegation" [unitTests, propertyTests] +tests = testGroup "Ledger with Delegation" [unitTests, propertyTests, stsTests] -- main entry point main :: IO () From 52555450c40ac7081acd4a3dbde0089b4513972f Mon Sep 17 00:00:00 2001 From: Jared Corduan Date: Fri, 12 Jul 2019 13:07:44 -0400 Subject: [PATCH 2/3] stack2nix --- nix/.stack.nix/delegation.nix | 2 ++ 1 file changed, 2 insertions(+) diff --git a/nix/.stack.nix/delegation.nix b/nix/.stack.nix/delegation.nix index 71670a07334..3f1f6119253 100644 --- a/nix/.stack.nix/delegation.nix +++ b/nix/.stack.nix/delegation.nix @@ -34,6 +34,7 @@ "delegation-test" = { depends = (pkgs.lib).optionals (!flags.development) [ (hsPkgs.base) + (hsPkgs.cryptonite) (hsPkgs.tasty) (hsPkgs.tasty-hunit) (hsPkgs.tasty-hedgehog) @@ -45,6 +46,7 @@ (hsPkgs.microlens) (hsPkgs.cs-ledger) (hsPkgs.cardano-crypto-class) + (hsPkgs.small-steps) ]; }; }; From 1ca5597ca91197b523ace9600ddf6d5b42c50608 Mon Sep 17 00:00:00 2001 From: Jared Corduan Date: Mon, 15 Jul 2019 14:11:12 -0400 Subject: [PATCH 3/3] explicit imports --- .../executable-spec/test/STSTests.hs | 12 ++++++------ .../chain-and-ledger/executable-spec/test/Tests.hs | 8 ++++---- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/test/STSTests.hs b/shelley/chain-and-ledger/executable-spec/test/STSTests.hs index 5f3de4a3296..688b52d38c5 100644 --- a/shelley/chain-and-ledger/executable-spec/test/STSTests.hs +++ b/shelley/chain-and-ledger/executable-spec/test/STSTests.hs @@ -4,26 +4,26 @@ module STSTests (stsTests) where import Data.Either (isLeft) -import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Map (empty) import Data.Maybe (fromMaybe) import Data.Word (Word64) -import Test.Tasty -import Test.Tasty.HUnit +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, testCase, (@?=)) import Cardano.Crypto.KES (deriveVerKeyKES, genKeyKES) import Crypto.Random (drgNewTest, withDRG) -import MockTypes +import MockTypes (CHAIN, SKeyES, VKeyES) import BaseTypes (Seed (..), mkUnitInterval) import BlockChain (pattern BHBody, pattern BHeader, pattern Block, pattern Proof, bhbHash) -import Control.State.Transition +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 +import STS.Updn (UPDN) -- | The UPDN transition should update both the evolving nonce and diff --git a/shelley/chain-and-ledger/executable-spec/test/Tests.hs b/shelley/chain-and-ledger/executable-spec/test/Tests.hs index 680883822f0..2daa938dbdb 100644 --- a/shelley/chain-and-ledger/executable-spec/test/Tests.hs +++ b/shelley/chain-and-ledger/executable-spec/test/Tests.hs @@ -1,8 +1,8 @@ -import Test.Tasty +import Test.Tasty -import UnitTests (unitTests) -import PropertyTests (propertyTests) -import STSTests (stsTests) +import PropertyTests (propertyTests) +import STSTests (stsTests) +import UnitTests (unitTests) tests :: TestTree tests = testGroup "Ledger with Delegation" [unitTests, propertyTests, stsTests]