Merge pull request #99 from input-output-hk/lars/praos

Continuation of #87

ouroboros-network.cabal

@@ -49,9 +49,11 @@ library
                        Ouroboros.Consensus.Node
                        Ouroboros.Consensus.Protocol.Abstract
                        Ouroboros.Consensus.Protocol.BFT
+                       Ouroboros.Consensus.Protocol.Genesis
                        Ouroboros.Consensus.Protocol.Praos
                        Ouroboros.Consensus.Protocol.Test
                        Ouroboros.Consensus.Protocol.ExtNodeConfig
+                       Ouroboros.Consensus.Protocol.ModChainSel
                        Ouroboros.Consensus.Util
                        Ouroboros.Consensus.Util.Chain
                        Ouroboros.Consensus.Util.DepFn
@@ -263,13 +265,15 @@ test-suite test-consensus
                     Test.Crypto.Hash
                     Test.Crypto.KES
                     Test.Crypto.VRF
-                    Test.DynamicBFT
-                    Test.DynamicPraos
+                    Test.Dynamic.BFT
+                    Test.Dynamic.General
+                    Test.Dynamic.Praos
                     Test.Ouroboros
   build-depends:    base,
                     ouroboros-network,
 
                     QuickCheck,
+                    bytestring,
                     containers,
                     cryptonite,
                     mtl,

shell.nix.lars

@@ -0,0 +1,9 @@
+{nixpkgs ? import <nixpkgs> { }, ghc ? nixpkgs.ghc}:
+
+with nixpkgs;
+
+haskell.lib.buildStackProject {
+  name = "datastructures";
+  buildInputs = [pkgconfig zlib ncurses gitMinimal];
+  inherit ghc;
+}

src/Ouroboros/Consensus/Crypto/DSIGN/Class.hs

@@ -10,17 +10,12 @@ module Ouroboros.Consensus.Crypto.DSIGN.Class
     , SignedDSIGN
     , signedDSIGN
     , verifySignedDSIGN
-    , prop_dsign_verify_pos
-    , prop_dsign_verify_neg_key
-    , prop_dsign_verify_neg_msg
     ) where
 
 import           Crypto.Random (MonadRandom)
 import           GHC.Generics (Generic)
 import           Ouroboros.Consensus.Util
-import           Test.QuickCheck (Arbitrary (..), Gen, Property, (==>))
 
-import           Ouroboros.Consensus.Util.Random
 import           Ouroboros.Network.Serialise
 
 class ( Show (VerKeyDSIGN v)
@@ -65,57 +60,3 @@ signedDSIGN a key = SignedDSIGN <$> signDSIGN a key
 verifySignedDSIGN :: (DSIGNAlgorithm v, Serialise a)
                   => VerKeyDSIGN v -> a -> SignedDSIGN v a -> Bool
 verifySignedDSIGN key a (SignedDSIGN s) = verifyDSIGN key a s
-
-instance DSIGNAlgorithm v => Arbitrary (SignKeyDSIGN v) where
-
-    arbitrary = do
-        seed <- arbitrary
-        return $ withSeed seed genKeyDSIGN
-
-    shrink = const []
-
-instance DSIGNAlgorithm v => Arbitrary (VerKeyDSIGN v) where
-    arbitrary = deriveVerKeyDSIGN <$> arbitrary
-    shrink = const []
-
-instance DSIGNAlgorithm v => Arbitrary (SigDSIGN v) where
-
-    arbitrary = do
-        a    <- arbitrary :: Gen Int
-        sk   <- arbitrary
-        seed <- arbitrary
-        return $ withSeed seed $ signDSIGN a sk
-
-    shrink = const []
-
-prop_dsign_verify_pos :: forall a v. (Serialise a, DSIGNAlgorithm v)
-                      => Seed
-                      -> a
-                      -> SignKeyDSIGN v
-                      -> Bool
-prop_dsign_verify_pos seed a sk =
-    let sig = withSeed seed $ signDSIGN a sk
-        vk  = deriveVerKeyDSIGN sk
-    in  verifyDSIGN vk a sig
-
-prop_dsign_verify_neg_key :: forall a v. (Serialise a, DSIGNAlgorithm v)
-                          => Seed
-                          -> a
-                          -> SignKeyDSIGN v
-                          -> SignKeyDSIGN v
-                          -> Property
-prop_dsign_verify_neg_key seed a sk sk' = sk /= sk' ==>
-    let sig = withSeed seed $ signDSIGN a sk'
-        vk  = deriveVerKeyDSIGN sk
-    in  not $ verifyDSIGN vk a sig
-
-prop_dsign_verify_neg_msg :: forall a v. (Serialise a, Eq a, DSIGNAlgorithm v)
-                          => Seed
-                          -> a
-                          -> a
-                          -> SignKeyDSIGN v
-                          -> Property
-prop_dsign_verify_neg_msg seed a a' sk = a /= a' ==>
-    let sig = withSeed seed $ signDSIGN a sk
-        vk  = deriveVerKeyDSIGN sk
-    in  not $ verifyDSIGN vk a' sig

src/Ouroboros/Consensus/Crypto/Hash/Class.hs

@@ -11,8 +11,6 @@ module Ouroboros.Consensus.Crypto.Hash.Class
     , getHash
     , hash
     , fromHash
-    , prop_hash_correct_byteCount
-    , prop_hash_show_fromString
     ) where
 
 import           Data.ByteString (ByteString)
@@ -25,7 +23,6 @@ import           Data.Proxy (Proxy (..))
 import           Data.String (IsString (..))
 import           GHC.Generics (Generic)
 import           Numeric.Natural
-import           Test.QuickCheck (Arbitrary (..), Property, (===))
 
 import           Ouroboros.Consensus.Util
 import           Ouroboros.Network.Serialise
@@ -61,21 +58,7 @@ instance HashAlgorithm h => Serialise (Hash h a) where
 hash :: forall h a. (HashAlgorithm h, Serialise a) => a -> Hash h a
 hash = Hash . digest (Proxy :: Proxy h)  . LB.toStrict . toLazyByteString . encode
 
-instance (Serialise a, Arbitrary a, HashAlgorithm h) => Arbitrary (Hash h a) where
-
-    arbitrary = hash <$> arbitrary
-    shrink = const []
-
 fromHash :: Hash h a -> Natural
 fromHash = foldl' f 0 . SB.unpack . getHash
   where
     f n b = n * 256 + fromIntegral b
-
-prop_hash_correct_byteCount :: forall h a. HashAlgorithm h
-                            => Hash h a
-                            -> Property
-prop_hash_correct_byteCount h =
-    (SB.length $ getHash h) === (fromIntegral $ byteCount (Proxy :: Proxy h))
-
-prop_hash_show_fromString :: Hash h a -> Property
-prop_hash_show_fromString h = h === fromString (show h)

src/Ouroboros/Consensus/Crypto/KES/Class.hs

@@ -8,15 +8,13 @@
 -- | Abstract key evolving signatures.
 module Ouroboros.Consensus.Crypto.KES.Class
     ( KESAlgorithm (..)
-    , SignedKES
+    , SignedKES (..)
     , signedKES
-    , Duration_Seed_SK (..)
-    , Duration_Seed_SK_Times (..)
+    , verifySignedKES
     ) where
 
 import           GHC.Generics (Generic)
 import           Numeric.Natural (Natural)
-import           Test.QuickCheck (Arbitrary (..), Gen)
 
 import           Ouroboros.Consensus.Util (Condense (..))
 import           Ouroboros.Consensus.Util.Random
@@ -48,7 +46,7 @@ class ( Show (VerKeyKES v)
             -> m (Maybe (SigKES v, SignKeyKES v))
     verifyKES :: Serialise a => VerKeyKES v -> Natural -> a -> SigKES v -> Bool
 
-newtype SignedKES v a = SignedKES (SigKES v)
+newtype SignedKES v a = SignedKES {getSig :: SigKES v}
   deriving (Generic)
 
 deriving instance KESAlgorithm v => Show (SignedKES v a)
@@ -69,69 +67,6 @@ signedKES time a key = do
         Nothing          -> Nothing
         Just (sig, key') -> Just (SignedKES sig, key')
 
---
--- Testing
---
-
-data Duration_Seed_SK v = Duration_Seed_SK Natural Seed (SignKeyKES v)
-    deriving Generic
-
-deriving instance KESAlgorithm v => Show (Duration_Seed_SK v)
-deriving instance KESAlgorithm v => Eq (Duration_Seed_SK v)
-deriving instance KESAlgorithm v => Serialise (Duration_Seed_SK v)
-
-instance KESAlgorithm v => Arbitrary (Duration_Seed_SK v) where
-
-    arbitrary = do
-        duration <- genNat
-        seed <- arbitrary
-        return $ duration_Seed_SK duration seed
-
-    shrink (Duration_Seed_SK duration seed _) =
-        [duration_Seed_SK d seed | d <- shrinkNat duration]
-
-instance KESAlgorithm v => Arbitrary (VerKeyKES v) where
-
-    arbitrary = do
-        Duration_Seed_SK _ _ sk <- arbitrary
-        return $ deriveVerKeyKES sk
-
-    shrink = const []
-
-data Duration_Seed_SK_Times v a =
-    Duration_Seed_SK_Times Natural Seed (SignKeyKES v) [(Natural, a)]
-    deriving Generic
-
-instance (KESAlgorithm v, Arbitrary a) => Arbitrary (Duration_Seed_SK_Times v a) where
-
-    arbitrary = arbitrary >>= gen_Duration_Seed_SK_Times
-
-    shrink (Duration_Seed_SK_Times d s sk ts) = do
-        Duration_Seed_SK d' s' sk' <- shrink $ Duration_Seed_SK d s sk
-        let ts' = filter ((< d') . fst) ts
-        return $ Duration_Seed_SK_Times d' s' sk' ts'
-
-deriving instance (KESAlgorithm v, Show a) => Show (Duration_Seed_SK_Times v a)
-deriving instance (KESAlgorithm v, Eq a) => Eq (Duration_Seed_SK_Times v a)
-deriving instance (KESAlgorithm v, Serialise a) => Serialise (Duration_Seed_SK_Times v a)
-
-duration_Seed_SK :: KESAlgorithm v => Natural -> Seed -> Duration_Seed_SK v
-duration_Seed_SK duration seed =
-    let sk = withSeed seed $ genKeyKES duration
-    in  Duration_Seed_SK duration seed sk
-
-gen_Duration_Seed_SK_Times :: Arbitrary a
-                           => Duration_Seed_SK v
-                           -> Gen (Duration_Seed_SK_Times v a)
-gen_Duration_Seed_SK_Times (Duration_Seed_SK duration seed sk) = do
-    ts <- genTimes 0
-    return $ Duration_Seed_SK_Times duration seed sk ts
-  where
-    genTimes :: Arbitrary a => Natural -> Gen [(Natural, a)]
-    genTimes j
-        | j >= duration = return []
-        | otherwise = do
-            k  <- genNatBetween j (duration - 1)
-            a  <- arbitrary
-            ns <- genTimes $ k + 1
-            return ((k, a) : ns)
+verifySignedKES :: (KESAlgorithm v, Serialise a)
+                => VerKeyKES v -> Natural -> a -> SignedKES v a -> Bool
+verifySignedKES vk j a (SignedKES sig) = verifyKES vk j a sig

src/Ouroboros/Consensus/Crypto/VRF/Class.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -10,19 +11,13 @@ module Ouroboros.Consensus.Crypto.VRF.Class
     -- TODO: Added to Lars' stuff, might need to modify
   , CertifiedVRF(..)
   , evalCertified
-  , prop_vrf_max
-  , prop_vrf_verify_pos
-  , prop_vrf_verify_neg
+  , verifyCertified
   ) where
 
 import           Crypto.Random (MonadRandom)
-import           Data.Proxy (Proxy (..))
 import           GHC.Generics (Generic)
 import           Numeric.Natural
-import           Test.QuickCheck (Arbitrary (..), Gen, Property, counterexample,
-                                  (==>))
 
-import           Ouroboros.Consensus.Util.Random (Seed, withSeed)
 import           Ouroboros.Network.Serialise
 
 class ( Show (VerKeyVRF v)
@@ -54,8 +49,8 @@ data CertifiedVRF v a = CertifiedVRF {
   deriving Generic
 
 deriving instance VRFAlgorithm v => Show (CertifiedVRF v a)
-deriving instance VRFAlgorithm v => Eq (CertifiedVRF v a)
-deriving instance VRFAlgorithm v => Ord (CertifiedVRF v a)
+deriving instance VRFAlgorithm v => Eq   (CertifiedVRF v a)
+deriving instance VRFAlgorithm v => Ord  (CertifiedVRF v a)
 
 instance VRFAlgorithm v => Serialise (CertifiedVRF v a) where
   -- use generic instance for now
@@ -64,55 +59,6 @@ evalCertified :: (VRFAlgorithm v, MonadRandom m, Serialise a)
               => a -> SignKeyVRF v -> m (CertifiedVRF v a)
 evalCertified a key = uncurry CertifiedVRF <$> evalVRF a key
 
-instance VRFAlgorithm v => Arbitrary (SignKeyVRF v) where
-
-    arbitrary = do
-        seed <- arbitrary
-        return $ withSeed seed genKeyVRF
-
-    shrink = const []
-
-instance VRFAlgorithm v => Arbitrary (VerKeyVRF v) where
-    arbitrary = deriveVerKeyVRF <$> arbitrary
-    shrink = const []
-
-instance VRFAlgorithm v => Arbitrary (CertVRF v) where
-
-    arbitrary = do
-        a    <- arbitrary :: Gen Int
-        sk   <- arbitrary
-        seed <- arbitrary
-        return $ withSeed seed $ fmap snd $ evalVRF a sk
-
-    shrink = const []
-
-prop_vrf_max :: forall a v. (Serialise a, VRFAlgorithm v)
-             => Seed
-             -> a
-             -> SignKeyVRF v
-             -> Property
-prop_vrf_max seed a sk =
-    let (y, _) = withSeed seed $ evalVRF a sk
-        m      = maxVRF (Proxy :: Proxy v)
-    in  counterexample ("expected " ++ show y ++ " <= " ++ show m) $ y <= m
-
-prop_vrf_verify_pos :: forall a v. (Serialise a, VRFAlgorithm v)
-                    => Seed
-                    -> a
-                    -> SignKeyVRF v
-                    -> Bool
-prop_vrf_verify_pos seed a sk =
-    let (y, c) = withSeed seed $ evalVRF a sk
-        vk     = deriveVerKeyVRF sk
-    in  verifyVRF vk a (y, c)
-
-prop_vrf_verify_neg :: forall a v. (Serialise a, VRFAlgorithm v)
-                    => Seed
-                    -> a
-                    -> SignKeyVRF v
-                    -> SignKeyVRF v
-                    -> Property
-prop_vrf_verify_neg seed a sk sk' = sk /= sk' ==>
-    let (y, c) = withSeed seed $ evalVRF a sk'
-        vk     = deriveVerKeyVRF sk
-    in  not $ verifyVRF vk a (y, c)
+verifyCertified :: (VRFAlgorithm v, Serialise a)
+                => VerKeyVRF v -> a -> CertifiedVRF v a -> Bool
+verifyCertified vk a CertifiedVRF{..} = verifyVRF vk a (certifiedNatural, certifiedProof)

src/Ouroboros/Consensus/Crypto/VRF/Mock.hs

@@ -6,7 +6,8 @@
 -- | Mock implementations of verifiable random functions.
 module Ouroboros.Consensus.Crypto.VRF.Mock
   ( MockVRF
-  , SignKeyVRF(..)
+  , VerKeyVRF (..)
+  , SignKeyVRF (..)
   ) where
 
 import           Data.Proxy (Proxy (..))