{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
module Test.Ouroboros.Network.Testing.Utils where
import Codec.CBOR.FlatTerm qualified as CBOR
import Codec.CBOR.Read qualified as CBOR
import Codec.CBOR.Term qualified as CBOR
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as LBS
import Network.TypedProtocol.Codec
import Network.TypedProtocol.Stateful.Codec qualified as Stateful
import Test.QuickCheck
splits2 :: LBS.ByteString -> [[LBS.ByteString]]
splits2 :: ByteString -> [[ByteString]]
splits2 ByteString
bs = (ByteString -> ByteString -> [ByteString])
-> [ByteString] -> [ByteString] -> [[ByteString]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ByteString
a ByteString
b -> [ByteString
a,ByteString
b]) (ByteString -> [ByteString]
LBS.inits ByteString
bs) (ByteString -> [ByteString]
LBS.tails ByteString
bs)
splits3 :: LBS.ByteString -> [[LBS.ByteString]]
splits3 :: ByteString -> [[ByteString]]
splits3 ByteString
bs =
[ [ByteString
a,ByteString
b,ByteString
c]
| (ByteString
a,ByteString
bs') <- [ByteString] -> [ByteString] -> [(ByteString, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip (ByteString -> [ByteString]
LBS.inits ByteString
bs) (ByteString -> [ByteString]
LBS.tails ByteString
bs)
, (ByteString
b,ByteString
c) <- [ByteString] -> [ByteString] -> [(ByteString, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip (ByteString -> [ByteString]
LBS.inits ByteString
bs') (ByteString -> [ByteString]
LBS.tails ByteString
bs') ]
prop_codec_cborM
:: forall ps m. Monad m
=> Codec ps CBOR.DeserialiseFailure m LBS.ByteString
-> AnyMessage ps
-> m Bool
prop_codec_cborM :: forall ps (m :: * -> *).
Monad m =>
Codec ps DeserialiseFailure m ByteString -> AnyMessage ps -> m Bool
prop_codec_cborM Codec ps DeserialiseFailure m ByteString
codec (AnyMessage Message ps st st'
msg)
= case (forall s. Decoder s Term)
-> ByteString -> Either DeserialiseFailure (ByteString, Term)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes Decoder s Term
forall s. Decoder s Term
CBOR.decodeTerm (ByteString -> Either DeserialiseFailure (ByteString, Term))
-> ByteString -> Either DeserialiseFailure (ByteString, Term)
forall a b. (a -> b) -> a -> b
$ Codec ps DeserialiseFailure m ByteString
-> forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> ByteString
forall ps failure (m :: * -> *) bytes.
Codec ps failure m bytes
-> forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> bytes
encode Codec ps DeserialiseFailure m ByteString
codec Message ps st st'
msg of
Left DeserialiseFailure
_err -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Right (ByteString
leftover, Term
_term) -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
LBS.null ByteString
leftover
prop_codec_valid_cbor_encoding
:: forall ps.
Codec ps CBOR.DeserialiseFailure IO ByteString
-> AnyMessage ps
-> Property
prop_codec_valid_cbor_encoding :: forall ps.
Codec ps DeserialiseFailure IO ByteString
-> AnyMessage ps -> Property
prop_codec_valid_cbor_encoding Codec {forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> ByteString
encode :: forall ps failure (m :: * -> *) bytes.
Codec ps failure m bytes
-> forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> bytes
encode :: forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> ByteString
encode} (AnyMessage Message ps st st'
msg) =
case [TermToken] -> ByteString -> Either DeserialiseFailure [TermToken]
deserialise [] (Message ps st st' -> ByteString
forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> ByteString
encode Message ps st st'
msg) of
Left DeserialiseFailure
e -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (DeserialiseFailure -> String
forall a. Show a => a -> String
show DeserialiseFailure
e) Bool
False
Right [TermToken]
terms -> Bool -> Property
forall prop. Testable prop => prop -> Property
property ([TermToken] -> Bool
CBOR.validFlatTerm [TermToken]
terms)
where
deserialise :: [CBOR.TermToken]
-> ByteString
-> Either CBOR.DeserialiseFailure [CBOR.TermToken]
deserialise :: [TermToken] -> ByteString -> Either DeserialiseFailure [TermToken]
deserialise ![TermToken]
as ByteString
bs =
case (forall s. Decoder s TermToken)
-> ByteString -> Either DeserialiseFailure (ByteString, TermToken)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes Decoder s TermToken
forall s. Decoder s TermToken
CBOR.decodeTermToken ByteString
bs of
Left DeserialiseFailure
e -> DeserialiseFailure -> Either DeserialiseFailure [TermToken]
forall a b. a -> Either a b
Left DeserialiseFailure
e
Right (ByteString
bs', TermToken
a) | ByteString -> Bool
LBS.null ByteString
bs'
-> [TermToken] -> Either DeserialiseFailure [TermToken]
forall a b. b -> Either a b
Right ([TermToken] -> [TermToken]
forall a. [a] -> [a]
reverse (TermToken
a TermToken -> [TermToken] -> [TermToken]
forall a. a -> [a] -> [a]
: [TermToken]
as))
| Bool
otherwise
-> [TermToken] -> ByteString -> Either DeserialiseFailure [TermToken]
deserialise (TermToken
a TermToken -> [TermToken] -> [TermToken]
forall a. a -> [a] -> [a]
: [TermToken]
as) ByteString
bs'
prop_codec_st_cborM
:: forall ps f m. Monad m
=> Stateful.Codec ps CBOR.DeserialiseFailure f m LBS.ByteString
-> Stateful.AnyMessage ps f
-> m Bool
prop_codec_st_cborM :: forall ps (f :: ps -> *) (m :: * -> *).
Monad m =>
Codec ps DeserialiseFailure f m ByteString
-> AnyMessage ps f -> m Bool
prop_codec_st_cborM Codec ps DeserialiseFailure f m ByteString
codec (Stateful.AnyMessage f st
f Message ps st st'
msg)
= case (forall s. Decoder s Term)
-> ByteString -> Either DeserialiseFailure (ByteString, Term)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes Decoder s Term
forall s. Decoder s Term
CBOR.decodeTerm (ByteString -> Either DeserialiseFailure (ByteString, Term))
-> ByteString -> Either DeserialiseFailure (ByteString, Term)
forall a b. (a -> b) -> a -> b
$ Codec ps DeserialiseFailure f m ByteString
-> forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
f st -> Message ps st st' -> ByteString
forall ps failure (f :: ps -> *) (m :: * -> *) bytes.
Codec ps failure f m bytes
-> forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
f st -> Message ps st st' -> bytes
Stateful.encode Codec ps DeserialiseFailure f m ByteString
codec f st
f Message ps st st'
msg of
Left DeserialiseFailure
_err -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Right (ByteString
leftover, Term
_term) -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
LBS.null ByteString
leftover
prop_codec_st_valid_cbor_encoding
:: forall ps f.
Stateful.Codec ps CBOR.DeserialiseFailure f IO ByteString
-> Stateful.AnyMessage ps f
-> Property
prop_codec_st_valid_cbor_encoding :: forall ps (f :: ps -> *).
Codec ps DeserialiseFailure f IO ByteString
-> AnyMessage ps f -> Property
prop_codec_st_valid_cbor_encoding Stateful.Codec {forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
f st -> Message ps st st' -> ByteString
encode :: forall ps failure (f :: ps -> *) (m :: * -> *) bytes.
Codec ps failure f m bytes
-> forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
f st -> Message ps st st' -> bytes
encode :: forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
f st -> Message ps st st' -> ByteString
Stateful.encode} (Stateful.AnyMessage f st
f Message ps st st'
msg) =
case [TermToken] -> ByteString -> Either DeserialiseFailure [TermToken]
deserialise [] (f st -> Message ps st st' -> ByteString
forall (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
f st -> Message ps st st' -> ByteString
encode f st
f Message ps st st'
msg) of
Left DeserialiseFailure
e -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (DeserialiseFailure -> String
forall a. Show a => a -> String
show DeserialiseFailure
e) Bool
False
Right [TermToken]
terms -> Bool -> Property
forall prop. Testable prop => prop -> Property
property ([TermToken] -> Bool
CBOR.validFlatTerm [TermToken]
terms)
where
deserialise :: [CBOR.TermToken]
-> ByteString
-> Either CBOR.DeserialiseFailure [CBOR.TermToken]
deserialise :: [TermToken] -> ByteString -> Either DeserialiseFailure [TermToken]
deserialise ![TermToken]
as ByteString
bs =
case (forall s. Decoder s TermToken)
-> ByteString -> Either DeserialiseFailure (ByteString, TermToken)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes Decoder s TermToken
forall s. Decoder s TermToken
CBOR.decodeTermToken ByteString
bs of
Left DeserialiseFailure
e -> DeserialiseFailure -> Either DeserialiseFailure [TermToken]
forall a b. a -> Either a b
Left DeserialiseFailure
e
Right (ByteString
bs', TermToken
a) | ByteString -> Bool
LBS.null ByteString
bs'
-> [TermToken] -> Either DeserialiseFailure [TermToken]
forall a b. b -> Either a b
Right ([TermToken] -> [TermToken]
forall a. [a] -> [a]
reverse (TermToken
a TermToken -> [TermToken] -> [TermToken]
forall a. a -> [a] -> [a]
: [TermToken]
as))
| Bool
otherwise
-> [TermToken] -> ByteString -> Either DeserialiseFailure [TermToken]
deserialise (TermToken
a TermToken -> [TermToken] -> [TermToken]
forall a. a -> [a] -> [a]
: [TermToken]
as) ByteString
bs'