{-# LANGUAGE TypeApplications #-}

-- | A header's claim that its body carries a Leios certificate is the one
-- Leios claim checkable from the block alone.
module Test.Consensus.Shelley.Integrity (tests) where

import Cardano.Ledger.Dijkstra (DijkstraEra)
import Cardano.Ledger.MemoBytes (getMemoRawType)
import qualified Cardano.Protocol.Leios.BlockHeader as Leios
import Data.Proxy (Proxy (Proxy))
import Ouroboros.Consensus.Block (blockMatchesHeader, getHeader)
import Ouroboros.Consensus.Shelley.HFEras (StandardDijkstraBlock)
import Ouroboros.Consensus.Shelley.Ledger
  ( Header
  , mkShelleyHeader
  , shelleyHeaderRaw
  )
import Ouroboros.Consensus.Shelley.Protocol.Abstract (pHeaderBodyHash)
import Test.Consensus.Shelley.Examples (examplesDijkstra)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertBool, assertEqual, testCase)
import Test.Util.Serialisation.Examples (exampleBlock)

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"Integrity"
    [ TestName -> Assertion -> TestTree
testCase TestName
"an example Dijkstra block matches its header" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        (StandardDijkstraBlock -> Assertion)
-> [StandardDijkstraBlock] -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
          (\StandardDijkstraBlock
blk -> HasCallStack => TestName -> Bool -> Assertion
TestName -> Bool -> Assertion
assertBool TestName
"does not match" (Header StandardDijkstraBlock -> StandardDijkstraBlock -> Bool
forall blk. GetHeader blk => Header blk -> blk -> Bool
blockMatchesHeader (StandardDijkstraBlock -> Header StandardDijkstraBlock
forall blk. GetHeader blk => blk -> Header blk
getHeader StandardDijkstraBlock
blk) StandardDijkstraBlock
blk))
          [StandardDijkstraBlock]
exampleDijkstraBlocks
    , TestName -> Assertion -> TestTree
testCase TestName
"a Dijkstra header claiming a Leios certificate its body lacks does not match" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        (StandardDijkstraBlock -> Assertion)
-> [StandardDijkstraBlock] -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
          ( \StandardDijkstraBlock
blk -> do
              let lying :: Header StandardDijkstraBlock
lying = Header StandardDijkstraBlock -> Header StandardDijkstraBlock
claimLeiosCert (StandardDijkstraBlock -> Header StandardDijkstraBlock
forall blk. GetHeader blk => blk -> Header blk
getHeader StandardDijkstraBlock
blk)
              -- Without this, the mismatch could be the body hash's doing.
              TestName
-> Hash HASH EraIndependentBlockBody
-> Hash HASH EraIndependentBlockBody
-> Assertion
forall a.
(Eq a, Show a, HasCallStack) =>
TestName -> a -> a -> Assertion
assertEqual
                TestName
"the body hash moved too"
                (ShelleyProtocolHeader (Praos2 StandardCrypto)
-> Hash HASH EraIndependentBlockBody
forall proto.
ProtocolHeaderSupportsEnvelope proto =>
ShelleyProtocolHeader proto -> Hash HASH EraIndependentBlockBody
pHeaderBodyHash (Header StandardDijkstraBlock
-> ShelleyProtocolHeader (Praos2 StandardCrypto)
forall proto era.
Header (ShelleyBlock proto era) -> ShelleyProtocolHeader proto
shelleyHeaderRaw (StandardDijkstraBlock -> Header StandardDijkstraBlock
forall blk. GetHeader blk => blk -> Header blk
getHeader StandardDijkstraBlock
blk)))
                (ShelleyProtocolHeader (Praos2 StandardCrypto)
-> Hash HASH EraIndependentBlockBody
forall proto.
ProtocolHeaderSupportsEnvelope proto =>
ShelleyProtocolHeader proto -> Hash HASH EraIndependentBlockBody
pHeaderBodyHash (Header StandardDijkstraBlock
-> ShelleyProtocolHeader (Praos2 StandardCrypto)
forall proto era.
Header (ShelleyBlock proto era) -> ShelleyProtocolHeader proto
shelleyHeaderRaw Header StandardDijkstraBlock
lying))
              HasCallStack => TestName -> Bool -> Assertion
TestName -> Bool -> Assertion
assertBool TestName
"matches despite the false claim" (Bool -> Assertion) -> Bool -> Assertion
forall a b. (a -> b) -> a -> b
$
                Bool -> Bool
not (Header StandardDijkstraBlock -> StandardDijkstraBlock -> Bool
forall blk. GetHeader blk => Header blk -> blk -> Bool
blockMatchesHeader Header StandardDijkstraBlock
lying StandardDijkstraBlock
blk)
          )
          [StandardDijkstraBlock]
exampleDijkstraBlocks
    ]

exampleDijkstraBlocks :: [StandardDijkstraBlock]
exampleDijkstraBlocks :: [StandardDijkstraBlock]
exampleDijkstraBlocks = (Maybe TestName, StandardDijkstraBlock) -> StandardDijkstraBlock
forall a b. (a, b) -> b
snd ((Maybe TestName, StandardDijkstraBlock) -> StandardDijkstraBlock)
-> [(Maybe TestName, StandardDijkstraBlock)]
-> [StandardDijkstraBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Examples StandardDijkstraBlock
-> [(Maybe TestName, StandardDijkstraBlock)]
forall blk. Examples blk -> Labelled blk
exampleBlock Examples StandardDijkstraBlock
examplesDijkstra

-- | The same header, claiming its body carries a Leios certificate.
--
-- The body hash is left alone, so only the claim disagrees.
claimLeiosCert :: Header StandardDijkstraBlock -> Header StandardDijkstraBlock
claimLeiosCert :: Header StandardDijkstraBlock -> Header StandardDijkstraBlock
claimLeiosCert Header StandardDijkstraBlock
hdr =
  ShelleyProtocolHeader (Praos2 StandardCrypto)
-> Header StandardDijkstraBlock
forall proto era.
ShelleyCompatible proto era =>
ShelleyProtocolHeader proto -> Header (ShelleyBlock proto era)
mkShelleyHeader (ShelleyProtocolHeader (Praos2 StandardCrypto)
 -> Header StandardDijkstraBlock)
-> ShelleyProtocolHeader (Praos2 StandardCrypto)
-> Header StandardDijkstraBlock
forall a b. (a -> b) -> a -> b
$
    -- TODO: should be able to use lenses, but blockBodyContainsLeiosCert has none yet in ledger
    Proxy DijkstraEra
-> HeaderBody StandardCrypto
-> SignedKES (KES StandardCrypto) (HeaderBody StandardCrypto)
-> Header StandardCrypto
forall era crypto (proxy :: * -> *).
(Era era, Crypto crypto) =>
proxy era
-> HeaderBody crypto
-> SignedKES (KES crypto) (HeaderBody crypto)
-> Header crypto
Leios.mkHeader
      Proxy DijkstraEra
era
      (Proxy DijkstraEra
-> HeaderBodyRaw StandardCrypto -> HeaderBody StandardCrypto
forall era crypto (proxy :: * -> *).
(Era era, Crypto crypto) =>
proxy era -> HeaderBodyRaw crypto -> HeaderBody crypto
Leios.mkHeaderBody Proxy DijkstraEra
era HeaderBodyRaw StandardCrypto
rawBody{Leios.hbrBlockBodyContainsLeiosCert = True})
      (Header StandardCrypto
-> SignedKES (KES StandardCrypto) (HeaderBody StandardCrypto)
forall crypto.
Header crypto -> SignedKES (KES crypto) (HeaderBody crypto)
Leios.headerSig Header StandardCrypto
raw)
 where
  era :: Proxy DijkstraEra
era = forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @DijkstraEra
  raw :: ShelleyProtocolHeader (Praos2 StandardCrypto)
raw = Header StandardDijkstraBlock
-> ShelleyProtocolHeader (Praos2 StandardCrypto)
forall proto era.
Header (ShelleyBlock proto era) -> ShelleyProtocolHeader proto
shelleyHeaderRaw Header StandardDijkstraBlock
hdr
  rawBody :: RawType (HeaderBody StandardCrypto)
rawBody = HeaderBody StandardCrypto -> RawType (HeaderBody StandardCrypto)
forall t. Memoized t => t -> RawType t
getMemoRawType (Header StandardCrypto -> HeaderBody StandardCrypto
forall crypto. Header crypto -> HeaderBody crypto
Leios.headerBody Header StandardCrypto
raw)