324: Slotting property tests

cardano-chain.cabal

@@ -182,6 +182,7 @@ test-suite cardano-chain-test
 
                        Test.Cardano.Chain.Slotting.Example
                        Test.Cardano.Chain.Slotting.Gen
+                       Test.Cardano.Chain.Slotting.Slotting
 
                        Test.Cardano.Chain.Txp.Bi
                        Test.Cardano.Chain.Txp.Example

src/Cardano/Chain/Slotting/Data.hs

@@ -23,6 +23,7 @@ module Cardano.Chain.Slotting.Data
   , addEpochSlottingData
   , lookupEpochSlottingData
   , computeSlotStart
+  , unsafeSlottingData
   )
 where
 
@@ -31,7 +32,7 @@ import Cardano.Prelude
 import Data.Map.Strict as M
 import Data.Semigroup (Semigroup)
 import Data.Time (NominalDiffTime, UTCTime, addUTCTime)
-import Formatting (bprint, build, int, sformat)
+import Formatting (bprint, build, int, sformat, string)
 import qualified Formatting.Buildable as B
 
 import Cardano.Binary.Class
@@ -77,6 +78,11 @@ newtype SlottingData = SlottingData
   deriving newtype (Semigroup, Monoid)
   deriving anyclass NFData
 
+instance B.Buildable SlottingData where
+  build (SlottingData sMap) = bprint
+    ("SlottingData: " . string)
+    (show sMap)
+
 instance Bi SlottingData where
   encode slottingData = encode $ getSlottingDataMap slottingData
   decode = checkIfSlottindDataValid decode
@@ -127,6 +133,9 @@ mkSlottingData epochSlottingDataMap = do
   validateSlottingDataMap epochSlottingDataMap
   pure $ SlottingData epochSlottingDataMap
 
+unsafeSlottingData :: Map EpochIndex EpochSlottingData -> SlottingData
+unsafeSlottingData = SlottingData
+
 -- | The validation for the @SlottingData@. It's visible since it's needed
 --   externally.
 validateSlottingDataMap

stack.yaml

@@ -6,7 +6,7 @@ packages:
 
 extra-deps:
   - git: https://github.com/input-output-hk/cardano-prelude
-    commit: 7161436bd31195b2ddfa7d359cd99f0fe53c881c
+    commit: e1fb84b1a955b6e3e3e53d9022e8bc0f927417a2
     subdirs:
       - .
       - test

test/Test/Cardano/Chain/Slotting/Gen.hs

@@ -4,6 +4,9 @@
 module Test.Cardano.Chain.Slotting.Gen
   ( genEpochIndex
   , genEpochSlottingData
+  , genSlottingDataCustom
+  , genSlottingDataTooFewIndicies
+  , genSlottingDataInvalidIndicies
   , genFlatSlotId
   , genLocalSlotIndex
   , genSlotCount
@@ -36,6 +39,7 @@ import Cardano.Chain.Slotting
   , localSlotIndexMinBound
   , mkLocalSlotIndex
   , mkSlottingData
+  , unsafeSlottingData
   )
 import Cardano.Crypto (ProtocolMagicId)
 
@@ -88,6 +92,49 @@ genSlottingData = mkSlottingData <$> genSlottingDataMap >>= \case
       [0 .. fromIntegral mapSize - 1]
       epochSlottingDatas
 
+genSlottingDataCustom :: Int -> Int -> Gen SlottingData
+genSlottingDataCustom lowerMb upperMb = mkSlottingData <$> genSlottingDataMap >>= \case
+  Left err ->
+    panic $ sformat ("The impossible happened in genSlottingData: " . build) err
+  Right slottingData -> pure slottingData
+ where
+  genSlottingDataMap :: Gen (Map EpochIndex EpochSlottingData)
+  genSlottingDataMap = do
+    mapSize <- Gen.int $ Range.linear lowerMb upperMb
+    epochSlottingDatas <- Gen.list
+      (Range.singleton mapSize)
+      genEpochSlottingData
+    pure $ Map.fromList $ zip
+      [0 .. fromIntegral mapSize - 1]
+      epochSlottingDatas
+
+genSlottingDataTooFewIndicies :: Gen SlottingData
+genSlottingDataTooFewIndicies = unsafeSlottingData <$> genSlottingDataMap
+ where
+  genSlottingDataMap :: Gen (Map EpochIndex EpochSlottingData)
+  genSlottingDataMap = do
+    mapSize <- Gen.int $ Range.linear 0 1
+    epochSlottingDatas <- Gen.list
+      (Range.singleton mapSize)
+      genEpochSlottingData
+    pure $ Map.fromList $ zip
+      [0 .. fromIntegral mapSize - 1]
+      epochSlottingDatas
+
+genSlottingDataInvalidIndicies :: Gen SlottingData
+genSlottingDataInvalidIndicies = unsafeSlottingData <$> genSlottingDataMap
+ where
+  genSlottingDataMap :: Gen (Map EpochIndex EpochSlottingData)
+  genSlottingDataMap = do
+    mapSize <- Gen.int $ Range.singleton 10
+    rList <- Gen.filter (\x -> x /= sort x) $ Gen.list (Range.singleton mapSize) (Gen.word64 (Range.linear 0 (fromIntegral mapSize - 1)))
+    epochSlottingDatas <- Gen.list
+      (Range.singleton mapSize)
+      genEpochSlottingData
+    pure $ Map.fromAscList $ zip
+      (map EpochIndex rList)
+      epochSlottingDatas
+
 feedPMEpochSlots :: (ProtocolMagicId -> SlotCount -> Gen a) -> Gen a
 feedPMEpochSlots genA = do
   pm         <- genProtocolMagicId

test/Test/Cardano/Chain/Slotting/Slotting.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Test.Cardano.Chain.Slotting.Slotting
+  ( prop_mkSlottingData
+  , prop_mkSlottingDataInvalidIndices
+  , prop_mkSlottingDataTooFewIndices
+  , prop_localSlotIndexToEnumOverflow
+  , prop_localSlotIndexToEnumUnderflow
+  )
+where
+
+import Cardano.Prelude
+import Test.Cardano.Prelude
+
+import Hedgehog (Property,withTests,property, forAll)
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+
+import Cardano.Chain.Slotting (SlottingData, SlotCount (..), mkSlottingData, getSlottingDataMap, localSlotIndexToEnum, validateSlottingDataMap)
+
+import Test.Cardano.Chain.Slotting.Gen (genSlotCount, genSlottingData, genSlottingDataCustom, genSlottingDataInvalidIndicies,genSlottingDataTooFewIndicies)
+
+prop_mkSlottingData :: Property
+prop_mkSlottingData = eachOf 1000 (getSlottingDataMap <$> genSlottingData) (assertEitherIsRight mkSlottingData)
+
+prop_mkSlottingDataTooFewIndices :: Property
+prop_mkSlottingDataTooFewIndices = eachOf 10 (getSlottingDataMap <$> genSlottingDataTooFewIndicies) (assertEitherIsLeft validateSlottingDataMap)
+
+prop_mkSlottingDataInvalidIndices :: Property
+prop_mkSlottingDataInvalidIndices = eachOf 1000 (getSlottingDataMap <$> genSlottingDataInvalidIndicies) (assertEitherIsLeft validateSlottingDataMap)
+
+--------------------------------------------------------------------------------
+-- LocalSlotIndex
+--------------------------------------------------------------------------------
+
+prop_localSlotIndexToEnumOverflow :: Property
+prop_localSlotIndexToEnumOverflow = withTests 1000 . property $ do
+  sc <- forAll genSlotCount
+  let newSc = 1 + getSlotCount sc
+  assertEitherIsLeft (localSlotIndexToEnum sc) (fromIntegral newSc)
+
+prop_localSlotIndexToEnumUnderflow :: Property
+prop_localSlotIndexToEnumUnderflow = withTests 1000 . property $ do
+  tVal <- forAll (Gen.int (Range.constant (negate 1) minBound))
+  sc <- forAll genSlotCount
+  assertEitherIsLeft (localSlotIndexToEnum sc) tVal

test/cardano-chain-test.cabal

@@ -29,6 +29,7 @@ library
                        Test.Cardano.Chain.Genesis.Json
                        Test.Cardano.Chain.Slotting.Example
                        Test.Cardano.Chain.Slotting.Gen
+                       Test.Cardano.Chain.Slotting.Slotting
                        Test.Cardano.Chain.Txp.Bi
                        Test.Cardano.Chain.Txp.Example
                        Test.Cardano.Chain.Txp.Gen