{-# 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 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
     , Eq (AnyMessage ps)
     )
  => Codec ps CBOR.DeserialiseFailure m LBS.ByteString
  -> AnyMessageAndAgency ps
  -> m Bool
prop_codec_cborM :: forall ps (m :: * -> *).
(Monad m, Eq (AnyMessage ps)) =>
Codec ps DeserialiseFailure m ByteString
-> AnyMessageAndAgency ps -> m Bool
prop_codec_cborM Codec ps DeserialiseFailure m ByteString
codec (AnyMessageAndAgency PeerHasAgency pr st
stok 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 (pr :: PeerRole) (st :: ps) (st' :: ps).
   PeerHasAgency pr st -> Message ps st st' -> ByteString
forall ps failure (m :: * -> *) bytes.
Codec ps failure m bytes
-> forall (pr :: PeerRole) (st :: ps) (st' :: ps).
   PeerHasAgency pr st -> Message ps st st' -> bytes
encode Codec ps DeserialiseFailure m ByteString
codec PeerHasAgency pr st
stok 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
  -> AnyMessageAndAgency ps
  -> Property
prop_codec_valid_cbor_encoding :: forall ps.
Codec ps DeserialiseFailure IO ByteString
-> AnyMessageAndAgency ps -> Property
prop_codec_valid_cbor_encoding Codec {forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> ByteString
encode :: forall ps failure (m :: * -> *) bytes.
Codec ps failure m bytes
-> forall (pr :: PeerRole) (st :: ps) (st' :: ps).
   PeerHasAgency pr st -> Message ps st st' -> bytes
encode :: forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> ByteString
encode} (AnyMessageAndAgency PeerHasAgency pr st
stok Message ps st st'
msg) =
    case [TermToken] -> ByteString -> Either DeserialiseFailure [TermToken]
deserialise [] (PeerHasAgency pr st -> Message ps st st' -> ByteString
forall (pr :: PeerRole) (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> ByteString
encode PeerHasAgency pr st
stok 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'