{-# 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

-- | Generate all 2-splits of a string.
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)

-- | Generate all 3-splits of a string.
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') ]

-- | Check that the codec produces a valid CBOR term
-- that is decodeable by CBOR.decodeTerm.
--
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


-- | This property checks that the encoder is producing a valid CBOR.  It
-- encodes to 'ByteString' using 'encode' and decodes a 'FlatTerm' from the
-- bytestring which is the fed into 'CBOR.validFlatTerm'.
--
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'

-- | Check that the codec produces a valid CBOR term
-- that is decodeable by CBOR.decodeTerm.
--
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

-- | This property checks that the encoder is producing a valid CBOR.  It
-- encodes to 'ByteString' using 'encode' and decodes a 'FlatTerm' from the
-- bytestring which is the fed into 'CBOR.validFlatTerm'.
--
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'