{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}

-- | Tests of LeiosNotify's codec: the bounds and CBOR encodings it accepts.
module Test.Consensus.Leios.LeiosNotify.Codec
  ( signedVote
  , tests
  ) where

import Cardano.Binary.FixedSizeCodec (encodeFixedSized)
import Cardano.Crypto.DSIGN.Class (genKeyDSIGN, signDSIGN)
import Cardano.Crypto.Leios (LeiosSeatId (..), leiosSignContext)
import Cardano.Crypto.Seed (mkSeedFromBytes)
import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Encoding as CBOR
import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Write as CBOR
import Control.Monad.IOSim (IOSim, runSimOrThrow)
import qualified Data.ByteString as BS
import Data.Either (isLeft)
import qualified Data.List.NonEmpty as NE
import Data.Word (Word16)
import Network.TypedProtocol.Codec
  ( CodecF (..)
  , SomeMessage (..)
  , runDecoder
  )
import Ouroboros.Consensus.Block (SlotNo (..))
import Ouroboros.Consensus.Leios.Types
  ( EbHash (..)
  , LeiosPoint (..)
  , LeiosVote (..)
  , RbHash (..)
  , decodeLeiosPoint
  , decodeLeiosVote
  , encodeEbHash
  , encodeRbHash
  )
import Ouroboros.Consensus.MiniProtocol.LeiosNotify.Type
import Test.Consensus.Leios.LeiosNotify.Protocol (P, codec)
import Test.Tasty
import Test.Tasty.HUnit

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup TestName
"codec" ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$
    [ TestName -> Assertion -> TestTree
testCase TestName
"the codec rejects an empty MsgLeiosVotes" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        HasCallStack => TestName -> Bool -> Assertion
TestName -> Bool -> Assertion
assertBool TestName
"decoded" (Bool -> Assertion) -> Bool -> Assertion
forall a b. (a -> b) -> a -> b
$
          Either DeserialiseFailure (SomeMessage 'StBusy) -> Bool
forall a b. Either a b -> Bool
isLeft (Either DeserialiseFailure (SomeMessage 'StBusy) -> Bool)
-> Either DeserialiseFailure (SomeMessage 'StBusy) -> Bool
forall a b. (a -> b) -> a -> b
$
            (forall s.
 IOSim s (Either DeserialiseFailure (SomeMessage 'StBusy)))
-> Either DeserialiseFailure (SomeMessage 'StBusy)
forall a. (forall s. IOSim s a) -> a
runSimOrThrow IOSim s (Either DeserialiseFailure (SomeMessage 'StBusy))
forall s. IOSim s (Either DeserialiseFailure (SomeMessage 'StBusy))
decodeEmptyVotes
    ]
      [TestTree] -> [TestTree] -> [TestTree]
forall a. Semigroup a => a -> a -> a
<> [ TestName -> [TestTree] -> TestTree
testGroup
             TestName
"the codec accepts either CBOR list encoding"
             [ TestName -> Assertion -> TestTree
testCase TestName
"definite message, indefinite votes" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
                 (forall s. IOSim s (Maybe [Int])) -> Maybe [Int]
forall a. (forall s. IOSim s a) -> a
runSimOrThrow (Encoding -> IOSim s (Maybe [Int])
forall s. Encoding -> IOSim s (Maybe [Int])
decodeVotes ([Encoding] -> Encoding
definite [Encoding
votesKey, [Encoding] -> Encoding
indefinite [Encoding]
twoVotes])) Maybe [Int] -> Maybe [Int] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int
1, Int
2]
             , TestName -> Assertion -> TestTree
testCase TestName
"indefinite message, definite votes" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
                 (forall s. IOSim s (Maybe [Int])) -> Maybe [Int]
forall a. (forall s. IOSim s a) -> a
runSimOrThrow (Encoding -> IOSim s (Maybe [Int])
forall s. Encoding -> IOSim s (Maybe [Int])
decodeVotes ([Encoding] -> Encoding
indefinite [Encoding
votesKey, [Encoding] -> Encoding
definite [Encoding]
twoVotes])) Maybe [Int] -> Maybe [Int] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int
1, Int
2]
             , TestName -> Assertion -> TestTree
testCase TestName
"indefinite message, indefinite votes" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
                 (forall s. IOSim s (Maybe [Int])) -> Maybe [Int]
forall a. (forall s. IOSim s a) -> a
runSimOrThrow (Encoding -> IOSim s (Maybe [Int])
forall s. Encoding -> IOSim s (Maybe [Int])
decodeVotes ([Encoding] -> Encoding
indefinite [Encoding
votesKey, [Encoding] -> Encoding
indefinite [Encoding]
twoVotes])) Maybe [Int] -> Maybe [Int] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int
1, Int
2]
             , TestName -> Assertion -> TestTree
testCase TestName
"rejects indefinite votes past the bound" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
                 (forall s. IOSim s (Maybe [Int])) -> Maybe [Int]
forall a. (forall s. IOSim s a) -> a
runSimOrThrow
                   (Encoding -> IOSim s (Maybe [Int])
forall s. Encoding -> IOSim s (Maybe [Int])
decodeVotes ([Encoding] -> Encoding
definite [Encoding
votesKey, [Encoding] -> Encoding
indefinite ((Int -> Encoding) -> [Int] -> [Encoding]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Encoding
CBOR.encodeInt [Int
1 .. Int
17])]))
                   Maybe [Int] -> Maybe [Int] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Maybe [Int]
forall a. Maybe a
Nothing
             , TestName -> Assertion -> TestTree
testCase TestName
"rejects an indefinite message with an extra field" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
                 (forall s. IOSim s (Maybe [Int])) -> Maybe [Int]
forall a. (forall s. IOSim s a) -> a
runSimOrThrow (Encoding -> IOSim s (Maybe [Int])
forall s. Encoding -> IOSim s (Maybe [Int])
decodeVotes ([Encoding] -> Encoding
indefinite [Encoding
votesKey, [Encoding] -> Encoding
definite [Encoding]
twoVotes, Int -> Encoding
CBOR.encodeInt Int
0]))
                   Maybe [Int] -> Maybe [Int] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Maybe [Int]
forall a. Maybe a
Nothing
             , TestName -> Assertion -> TestTree
testCase TestName
"rejects empty indefinite votes" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
                 (forall s. IOSim s (Maybe [Int])) -> Maybe [Int]
forall a. (forall s. IOSim s a) -> a
runSimOrThrow (Encoding -> IOSim s (Maybe [Int])
forall s. Encoding -> IOSim s (Maybe [Int])
decodeVotes ([Encoding] -> Encoding
definite [Encoding
votesKey, [Encoding] -> Encoding
indefinite []])) Maybe [Int] -> Maybe [Int] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Maybe [Int]
forall a. Maybe a
Nothing
             , TestName -> Assertion -> TestTree
testCase TestName
"an indefinite point" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
                 let p :: LeiosPoint
p = SlotNo -> EbHash -> LeiosPoint
MkLeiosPoint (Word64 -> SlotNo
SlotNo Word64
3) (ByteString -> EbHash
MkEbHash (Int -> Word8 -> ByteString
BS.replicate Int
32 Word8
7))
                  in (forall s. Decoder s LeiosPoint) -> Encoding -> Maybe LeiosPoint
forall a. (forall s. Decoder s a) -> Encoding -> Maybe a
decodeWith
                       Decoder s LeiosPoint
forall s. Decoder s LeiosPoint
decodeLeiosPoint
                       ([Encoding] -> Encoding
indefinite [Word64 -> Encoding
CBOR.encodeWord64 Word64
3, EbHash -> Encoding
encodeEbHash (ByteString -> EbHash
MkEbHash (Int -> Word8 -> ByteString
BS.replicate Int
32 Word8
7))])
                       Maybe LeiosPoint -> Maybe LeiosPoint -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosPoint -> Maybe LeiosPoint
forall a. a -> Maybe a
Just LeiosPoint
p
             , TestName -> Assertion -> TestTree
testCase TestName
"an indefinite vote" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
                 let v :: LeiosVote
v = RbHash -> Word16 -> LeiosVote
signedVote (ByteString -> RbHash
MkRbHash (Int -> Word8 -> ByteString
BS.replicate Int
32 Word8
1)) Word16
0
                  in (forall s. Decoder s LeiosVote) -> Encoding -> Maybe LeiosVote
forall a. (forall s. Decoder s a) -> Encoding -> Maybe a
decodeWith Decoder s LeiosVote
forall s. Decoder s LeiosVote
decodeLeiosVote (LeiosVote -> Encoding
indefiniteVote LeiosVote
v) Maybe LeiosVote -> Maybe LeiosVote -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosVote -> Maybe LeiosVote
forall a. a -> Maybe a
Just LeiosVote
v
             ]
         ]

-- | Decode a 'MsgLeiosVotes' that holds no votes.
decodeEmptyVotes :: IOSim s (Either CBOR.DeserialiseFailure (SomeMessage (StBusy :: P)))
decodeEmptyVotes :: forall s. IOSim s (Either DeserialiseFailure (SomeMessage 'StBusy))
decodeEmptyVotes = do
  step <- CodecF P DeserialiseFailure (IOSim s) SomeMessage ByteString
-> forall (st :: P).
   ActiveState st =>
   StateToken st
   -> IOSim
        s
        (DecodeStep
           ByteString DeserialiseFailure (IOSim s) (SomeMessage st))
forall ps failure (m :: * -> *) (f :: ps -> *) bytes.
CodecF ps failure m f bytes
-> forall (st :: ps).
   ActiveState st =>
   StateToken st -> m (DecodeStep bytes failure m (f st))
decode CodecF P DeserialiseFailure (IOSim s) SomeMessage ByteString
forall s. Codec P DeserialiseFailure (IOSim s) ByteString
codec SingLeiosNotify 'StBusy
StateToken 'StBusy
forall {point} {announcement} {vote}. SingLeiosNotify 'StBusy
SingBusy
  runDecoder
    [CBOR.toLazyByteString (CBOR.encodeListLen 2 <> CBOR.encodeWord 7 <> CBOR.encodeListLen 0)]
    step

-- | Decode a 'MsgLeiosVotes'.
decodeVotes :: CBOR.Encoding -> IOSim s (Maybe [Int])
decodeVotes :: forall s. Encoding -> IOSim s (Maybe [Int])
decodeVotes Encoding
enc = do
  step <- CodecF P DeserialiseFailure (IOSim s) SomeMessage ByteString
-> forall (st :: P).
   ActiveState st =>
   StateToken st
   -> IOSim
        s
        (DecodeStep
           ByteString DeserialiseFailure (IOSim s) (SomeMessage st))
forall ps failure (m :: * -> *) (f :: ps -> *) bytes.
CodecF ps failure m f bytes
-> forall (st :: ps).
   ActiveState st =>
   StateToken st -> m (DecodeStep bytes failure m (f st))
decode CodecF P DeserialiseFailure (IOSim s) SomeMessage ByteString
forall s. Codec P DeserialiseFailure (IOSim s) ByteString
codec SingLeiosNotify 'StBusy
StateToken 'StBusy
forall {point} {announcement} {vote}. SingLeiosNotify 'StBusy
SingBusy
  runDecoder [CBOR.toLazyByteString enc] step >>= \case
    Right (SomeMessage (MsgLeiosVotes NonEmpty Int
vs)) -> Maybe [Int] -> IOSim s (Maybe [Int])
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int] -> Maybe [Int]
forall a. a -> Maybe a
Just (NonEmpty Int -> [Int]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Int
vs))
    Either DeserialiseFailure (SomeMessage 'StBusy)
_ -> Maybe [Int] -> IOSim s (Maybe [Int])
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Int]
forall a. Maybe a
Nothing

decodeWith :: (forall s. CBOR.Decoder s a) -> CBOR.Encoding -> Maybe a
decodeWith :: forall a. (forall s. Decoder s a) -> Encoding -> Maybe a
decodeWith forall s. Decoder s a
dec Encoding
enc =
  (DeserialiseFailure -> Maybe a)
-> ((ByteString, a) -> Maybe a)
-> Either DeserialiseFailure (ByteString, a)
-> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> DeserialiseFailure -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a)
-> ((ByteString, a) -> a) -> (ByteString, a) -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, a) -> a
forall a b. (a, b) -> b
snd) (Either DeserialiseFailure (ByteString, a) -> Maybe a)
-> Either DeserialiseFailure (ByteString, a) -> Maybe a
forall a b. (a -> b) -> a -> b
$
    (forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes Decoder s a
forall s. Decoder s a
dec (Encoding -> ByteString
CBOR.toLazyByteString Encoding
enc)

indefiniteVote :: LeiosVote -> CBOR.Encoding
indefiniteVote :: LeiosVote -> Encoding
indefiniteVote (MkLeiosVote RbHash
rbHash LeiosSeatId
seat SigDSIGN LeiosDSIGN
signature) =
  [Encoding] -> Encoding
indefinite
    [RbHash -> Encoding
encodeRbHash RbHash
rbHash, Word16 -> Encoding
CBOR.encodeWord16 (LeiosSeatId -> Word16
leiosSeatIndex LeiosSeatId
seat), SigDSIGN LeiosDSIGN -> Encoding
forall a. FixedSizeCodec a => a -> Encoding
encodeFixedSized SigDSIGN LeiosDSIGN
signature]

definite :: [CBOR.Encoding] -> CBOR.Encoding
definite :: [Encoding] -> Encoding
definite [Encoding]
xs = Word -> Encoding
CBOR.encodeListLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ [Encoding] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Encoding]
xs) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [Encoding]
xs

indefinite :: [CBOR.Encoding] -> CBOR.Encoding
indefinite :: [Encoding] -> Encoding
indefinite [Encoding]
xs = Encoding
CBOR.encodeListLenIndef Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [Encoding]
xs Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
CBOR.encodeBreak

votesKey :: CBOR.Encoding
votesKey :: Encoding
votesKey = Word -> Encoding
CBOR.encodeWord Word
7

twoVotes :: [CBOR.Encoding]
twoVotes :: [Encoding]
twoVotes = (Int -> Encoding) -> [Int] -> [Encoding]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Encoding
CBOR.encodeInt [Int
1, Int
2]

-- | A vote from this seat for this announcing block. The node's LeiosNotify
-- client does not check a vote's signature, so any key will do.
signedVote :: RbHash -> Word16 -> LeiosVote
signedVote :: RbHash -> Word16 -> LeiosVote
signedVote RbHash
rbHash Word16
seat =
  RbHash -> LeiosSeatId -> SigDSIGN LeiosDSIGN -> LeiosVote
MkLeiosVote RbHash
rbHash (Word16 -> LeiosSeatId
LeiosSeatId Word16
seat) (SigDSIGN LeiosDSIGN -> LeiosVote)
-> SigDSIGN LeiosDSIGN -> LeiosVote
forall a b. (a -> b) -> a -> b
$
    ContextDSIGN LeiosDSIGN
-> RbHash -> SignKeyDSIGN LeiosDSIGN -> SigDSIGN LeiosDSIGN
forall v a.
(DSIGNAlgorithm v, Signable v a, HasCallStack) =>
ContextDSIGN v -> a -> SignKeyDSIGN v -> SigDSIGN v
forall a.
(Signable LeiosDSIGN a, HasCallStack) =>
ContextDSIGN LeiosDSIGN
-> a -> SignKeyDSIGN LeiosDSIGN -> SigDSIGN LeiosDSIGN
signDSIGN ContextDSIGN LeiosDSIGN
BLS12381SignContext
leiosSignContext RbHash
rbHash (Seed -> SignKeyDSIGN LeiosDSIGN
forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
genKeyDSIGN (ByteString -> Seed
mkSeedFromBytes (Int -> Word8 -> ByteString
BS.replicate Int
32 Word8
0)))