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) ]; }; }; 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..688b52d38c5 --- /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 (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 + ] diff --git a/shelley/chain-and-ledger/executable-spec/test/Tests.hs b/shelley/chain-and-ledger/executable-spec/test/Tests.hs index 80248f8040e..2daa938dbdb 100644 --- a/shelley/chain-and-ledger/executable-spec/test/Tests.hs +++ b/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 ()