{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE DerivingVia         #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- TODO: Needed for PeerSharing arbitrary instance see
-- todo there.
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Network.Protocol.Handshake.Test where

import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as BL
import Data.List (nub)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics

import Codec.CBOR.Read qualified as CBOR
import Codec.CBOR.Term qualified as CBOR

import Control.Applicative (Alternative)
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadST (MonadST)
import Control.Monad.Class.MonadThrow (MonadCatch, MonadMask, MonadThrow,
           bracket)
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Control.Monad.IOSim (runSimOrThrow)
import Control.Tracer (nullTracer)

import Network.Mux.Bearer qualified as Mx
import Network.Mux.Types (MiniProtocolDir (..), MiniProtocolNum (..),
           bearerAsChannel)
import Network.TypedProtocol.Codec
import Network.TypedProtocol.Codec.Properties
import Network.TypedProtocol.Proofs

import Test.Ouroboros.Network.Protocol.Utils (prop_codec_cborM,
           prop_codec_valid_cbor_encoding, splits2, splits3)

import Ouroboros.Network.Channel
import Ouroboros.Network.CodecCBORTerm
import Ouroboros.Network.Driver.Simple (runConnectedPeers,
           runConnectedPeersAsymmetric, runPeer)
import Ouroboros.Network.Snocket (TestAddress (..))
import Ouroboros.Network.Snocket qualified as Snocket
import Simulation.Network.Snocket

import Ouroboros.Network.Protocol.Handshake.Client
import Ouroboros.Network.Protocol.Handshake.Codec
import Ouroboros.Network.Protocol.Handshake.Direct
import Ouroboros.Network.Protocol.Handshake.Server
import Ouroboros.Network.Protocol.Handshake.Type
import Ouroboros.Network.Protocol.Handshake.Version

import Codec.CBOR.Write qualified as CBOR

import Test.QuickCheck
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)

tests :: TestTree
tests :: TestTree
tests =
  String -> [TestTree] -> TestTree
testGroup String
"Ouroboros.Network.Protocol"
    [ String -> [TestTree] -> TestTree
testGroup String
"Handshake"
        [ String -> (ArbitraryVersions -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"connect"               ArbitraryVersions -> Property
prop_connect
        , String -> (ArbitraryVersions -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"channel ST"            ArbitraryVersions -> Property
prop_channel_ST
        , String -> (ArbitraryVersions -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"channel IO"            ArbitraryVersions -> Property
prop_channel_IO
        , String -> (ArbitraryVersions -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"pipe IO"               ArbitraryVersions -> Property
prop_pipe_IO
        , String -> (ArbitraryVersions -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"channel asymmetric ST" ArbitraryVersions -> Property
prop_channel_asymmetric_ST
        , String -> (ArbitraryVersions -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"channel asymmetric IO" ArbitraryVersions -> Property
prop_channel_asymmetric_IO
        , String -> (ArbitraryVersions -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"pipe asymmetric IO"    ArbitraryVersions -> Property
prop_pipe_asymmetric_IO

        , String -> [TestTree] -> TestTree
testGroup String
"VersionData"
          [ String -> (VersionData -> VersionData -> Bool) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"acceptable_symmetric"
              VersionData -> VersionData -> Bool
prop_acceptable_symmetric_VersionData
          , String -> (ArbitraryVersions -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"acceptOrRefuse"
              ArbitraryVersions -> Property
prop_acceptOrRefuse_symmetric_VersionData
          , String -> (ArbitraryVersions -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"simultaneous open ST"
              ArbitraryVersions -> Property
prop_channel_simultaneous_open_ST
          , String -> (ArbitraryVersions -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"simultaneous open IO"
              ArbitraryVersions -> Property
prop_channel_simultaneous_open_IO
          , String -> (ArbitraryVersions -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"simultaneous open SimNet"
              ArbitraryVersions -> Property
prop_channel_simultaneous_open_SimNet
          ]

        , String -> (ArbitraryRefuseReason -> Bool) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"codec RefuseReason"    ArbitraryRefuseReason -> Bool
prop_codec_RefuseReason
        , String
-> (AnyMessage (Handshake VersionNumber Term) -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"codec"                 AnyMessage (Handshake VersionNumber Term) -> Property
prop_codec_Handshake
        , String
-> (AnyMessage (Handshake VersionNumber Term) -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"codec 2-splits"        AnyMessage (Handshake VersionNumber Term) -> Property
prop_codec_splits2_Handshake
        , String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"codec 3-splits"      (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ Int
-> (AnyMessage (Handshake VersionNumber Term) -> Property)
-> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
30
                                               AnyMessage (Handshake VersionNumber Term) -> Property
prop_codec_splits3_Handshake
        , String
-> (AnyMessage (Handshake VersionNumber Term) -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"codec cbor"            AnyMessage (Handshake VersionNumber Term) -> Property
prop_codec_cbor
        , String
-> (AnyMessage (Handshake VersionNumber Term) -> Property)
-> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"codec valid cbor"      AnyMessage (Handshake VersionNumber Term) -> Property
prop_codec_valid_cbor
        , String -> [TestTree] -> TestTree
testGroup String
"Generators"
          [ String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"ArbitraryVersions" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
              (ArbitraryVersions -> Property) -> Property
forall prop. Testable prop => prop -> Property
checkCoverage ArbitraryVersions -> Property
prop_arbitrary_ArbitraryVersions
          , String -> (ArbitraryValidVersions -> Bool) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"arbitrary ArbitraryValidVersions"
              ArbitraryValidVersions -> Bool
prop_arbitrary_ArbitraryValidVersions
          , String -> (ArbitraryValidVersions -> Bool) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"shrink ArbitraryValidVersions"
              ArbitraryValidVersions -> Bool
prop_shrink_ArbitraryValidVersions
          ]
        ]
    ]

--
-- Test Versions
--
-- Notes: Associated data are chosen in such a way that a decoder will fail
-- interpreting one of them as the other.  This is done on purpose for testing
-- wrongly encoded data (protocol version & associated version data mismatch)
--

-- | Testing version number
--
data VersionNumber
  = Version_0
  | Version_1
  | Version_2
  deriving (VersionNumber -> VersionNumber -> Bool
(VersionNumber -> VersionNumber -> Bool)
-> (VersionNumber -> VersionNumber -> Bool) -> Eq VersionNumber
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VersionNumber -> VersionNumber -> Bool
== :: VersionNumber -> VersionNumber -> Bool
$c/= :: VersionNumber -> VersionNumber -> Bool
/= :: VersionNumber -> VersionNumber -> Bool
Eq, Eq VersionNumber
Eq VersionNumber =>
(VersionNumber -> VersionNumber -> Ordering)
-> (VersionNumber -> VersionNumber -> Bool)
-> (VersionNumber -> VersionNumber -> Bool)
-> (VersionNumber -> VersionNumber -> Bool)
-> (VersionNumber -> VersionNumber -> Bool)
-> (VersionNumber -> VersionNumber -> VersionNumber)
-> (VersionNumber -> VersionNumber -> VersionNumber)
-> Ord VersionNumber
VersionNumber -> VersionNumber -> Bool
VersionNumber -> VersionNumber -> Ordering
VersionNumber -> VersionNumber -> VersionNumber
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: VersionNumber -> VersionNumber -> Ordering
compare :: VersionNumber -> VersionNumber -> Ordering
$c< :: VersionNumber -> VersionNumber -> Bool
< :: VersionNumber -> VersionNumber -> Bool
$c<= :: VersionNumber -> VersionNumber -> Bool
<= :: VersionNumber -> VersionNumber -> Bool
$c> :: VersionNumber -> VersionNumber -> Bool
> :: VersionNumber -> VersionNumber -> Bool
$c>= :: VersionNumber -> VersionNumber -> Bool
>= :: VersionNumber -> VersionNumber -> Bool
$cmax :: VersionNumber -> VersionNumber -> VersionNumber
max :: VersionNumber -> VersionNumber -> VersionNumber
$cmin :: VersionNumber -> VersionNumber -> VersionNumber
min :: VersionNumber -> VersionNumber -> VersionNumber
Ord, Int -> VersionNumber
VersionNumber -> Int
VersionNumber -> [VersionNumber]
VersionNumber -> VersionNumber
VersionNumber -> VersionNumber -> [VersionNumber]
VersionNumber -> VersionNumber -> VersionNumber -> [VersionNumber]
(VersionNumber -> VersionNumber)
-> (VersionNumber -> VersionNumber)
-> (Int -> VersionNumber)
-> (VersionNumber -> Int)
-> (VersionNumber -> [VersionNumber])
-> (VersionNumber -> VersionNumber -> [VersionNumber])
-> (VersionNumber -> VersionNumber -> [VersionNumber])
-> (VersionNumber
    -> VersionNumber -> VersionNumber -> [VersionNumber])
-> Enum VersionNumber
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: VersionNumber -> VersionNumber
succ :: VersionNumber -> VersionNumber
$cpred :: VersionNumber -> VersionNumber
pred :: VersionNumber -> VersionNumber
$ctoEnum :: Int -> VersionNumber
toEnum :: Int -> VersionNumber
$cfromEnum :: VersionNumber -> Int
fromEnum :: VersionNumber -> Int
$cenumFrom :: VersionNumber -> [VersionNumber]
enumFrom :: VersionNumber -> [VersionNumber]
$cenumFromThen :: VersionNumber -> VersionNumber -> [VersionNumber]
enumFromThen :: VersionNumber -> VersionNumber -> [VersionNumber]
$cenumFromTo :: VersionNumber -> VersionNumber -> [VersionNumber]
enumFromTo :: VersionNumber -> VersionNumber -> [VersionNumber]
$cenumFromThenTo :: VersionNumber -> VersionNumber -> VersionNumber -> [VersionNumber]
enumFromThenTo :: VersionNumber -> VersionNumber -> VersionNumber -> [VersionNumber]
Enum, VersionNumber
VersionNumber -> VersionNumber -> Bounded VersionNumber
forall a. a -> a -> Bounded a
$cminBound :: VersionNumber
minBound :: VersionNumber
$cmaxBound :: VersionNumber
maxBound :: VersionNumber
Bounded, Int -> VersionNumber -> ShowS
[VersionNumber] -> ShowS
VersionNumber -> String
(Int -> VersionNumber -> ShowS)
-> (VersionNumber -> String)
-> ([VersionNumber] -> ShowS)
-> Show VersionNumber
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VersionNumber -> ShowS
showsPrec :: Int -> VersionNumber -> ShowS
$cshow :: VersionNumber -> String
show :: VersionNumber -> String
$cshowList :: [VersionNumber] -> ShowS
showList :: [VersionNumber] -> ShowS
Show)

instance Arbitrary VersionNumber where
  arbitrary :: Gen VersionNumber
arbitrary = [VersionNumber] -> Gen VersionNumber
forall a. HasCallStack => [a] -> Gen a
elements [VersionNumber
forall a. Bounded a => a
minBound .. VersionNumber
forall a. Bounded a => a
maxBound]

versionNumberCodec :: CodecCBORTerm (String, Maybe Int) VersionNumber
versionNumberCodec :: CodecCBORTerm (String, Maybe Int) VersionNumber
versionNumberCodec = CodecCBORTerm { VersionNumber -> Term
encodeTerm :: VersionNumber -> Term
encodeTerm :: VersionNumber -> Term
encodeTerm, Term -> Either (String, Maybe Int) VersionNumber
decodeTerm :: Term -> Either (String, Maybe Int) VersionNumber
decodeTerm :: Term -> Either (String, Maybe Int) VersionNumber
decodeTerm }
  where
    encodeTerm :: VersionNumber -> Term
encodeTerm VersionNumber
Version_0 = Int -> Term
CBOR.TInt Int
0
    encodeTerm VersionNumber
Version_1 = Int -> Term
CBOR.TInt Int
1
    encodeTerm VersionNumber
Version_2 = Int -> Term
CBOR.TInt Int
2

    decodeTerm :: Term -> Either (String, Maybe Int) VersionNumber
decodeTerm (CBOR.TInt Int
0) = VersionNumber -> Either (String, Maybe Int) VersionNumber
forall a b. b -> Either a b
Right VersionNumber
Version_0
    decodeTerm (CBOR.TInt Int
1) = VersionNumber -> Either (String, Maybe Int) VersionNumber
forall a b. b -> Either a b
Right VersionNumber
Version_1
    decodeTerm (CBOR.TInt Int
2) = VersionNumber -> Either (String, Maybe Int) VersionNumber
forall a b. b -> Either a b
Right VersionNumber
Version_2
    decodeTerm (CBOR.TInt Int
n) = (String, Maybe Int) -> Either (String, Maybe Int) VersionNumber
forall a b. a -> Either a b
Left (String
"unknown version", Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n)
    decodeTerm Term
_             = (String, Maybe Int) -> Either (String, Maybe Int) VersionNumber
forall a b. a -> Either a b
Left (String
"unknown tag", Maybe Int
forall a. Maybe a
Nothing)


versionNumberHandshakeCodec :: MonadST m
                            => Codec (Handshake VersionNumber CBOR.Term)
                                      CBOR.DeserialiseFailure m ByteString
versionNumberHandshakeCodec :: forall (m :: * -> *).
MonadST m =>
Codec
  (Handshake VersionNumber Term) DeserialiseFailure m ByteString
versionNumberHandshakeCodec = CodecCBORTerm (String, Maybe Int) VersionNumber
-> Codec
     (Handshake VersionNumber Term) DeserialiseFailure m ByteString
forall vNumber (m :: * -> *) failure.
(MonadST m, Ord vNumber, Show failure) =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
codecHandshake CodecCBORTerm (String, Maybe Int) VersionNumber
versionNumberCodec

data VersionData = VersionData {
    VersionData -> Int
dataVersion0 :: Int,
    VersionData -> Bool
dataVersion1 :: Bool,
    VersionData -> Bool
dataVersion2 :: Bool
  }
  deriving (VersionData -> VersionData -> Bool
(VersionData -> VersionData -> Bool)
-> (VersionData -> VersionData -> Bool) -> Eq VersionData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VersionData -> VersionData -> Bool
== :: VersionData -> VersionData -> Bool
$c/= :: VersionData -> VersionData -> Bool
/= :: VersionData -> VersionData -> Bool
Eq, Int -> VersionData -> ShowS
[VersionData] -> ShowS
VersionData -> String
(Int -> VersionData -> ShowS)
-> (VersionData -> String)
-> ([VersionData] -> ShowS)
-> Show VersionData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VersionData -> ShowS
showsPrec :: Int -> VersionData -> ShowS
$cshow :: VersionData -> String
show :: VersionData -> String
$cshowList :: [VersionData] -> ShowS
showList :: [VersionData] -> ShowS
Show, (forall x. VersionData -> Rep VersionData x)
-> (forall x. Rep VersionData x -> VersionData)
-> Generic VersionData
forall x. Rep VersionData x -> VersionData
forall x. VersionData -> Rep VersionData x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. VersionData -> Rep VersionData x
from :: forall x. VersionData -> Rep VersionData x
$cto :: forall x. Rep VersionData x -> VersionData
to :: forall x. Rep VersionData x -> VersionData
Generic)

instance Acceptable VersionData where
    acceptableVersion :: VersionData -> VersionData -> Accept VersionData
acceptableVersion VersionData
d VersionData
d' =
      if VersionData -> Int
dataVersion0 VersionData
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= VersionData -> Int
dataVersion0 VersionData
d'
        then Text -> Accept VersionData
forall vData. Text -> Accept vData
Refuse (String -> Text
T.pack String
"incompatible")
        else VersionData -> Accept VersionData
forall vData. vData -> Accept vData
Accept (VersionData -> Accept VersionData)
-> VersionData -> Accept VersionData
forall a b. (a -> b) -> a -> b
$ VersionData { dataVersion0 :: Int
dataVersion0 = VersionData -> Int
dataVersion0 VersionData
d,
                                    dataVersion1 :: Bool
dataVersion1 = VersionData -> Bool
dataVersion1 VersionData
d
                                                Bool -> Bool -> Bool
&& VersionData -> Bool
dataVersion1 VersionData
d',
                                    dataVersion2 :: Bool
dataVersion2 = VersionData -> Bool
dataVersion2 VersionData
d
                                                Bool -> Bool -> Bool
|| VersionData -> Bool
dataVersion2 VersionData
d' }

instance Queryable VersionData where
    queryVersion :: VersionData -> Bool
queryVersion VersionData
_d = Bool
False

dataCodecCBORTerm :: VersionNumber -> CodecCBORTerm Text VersionData
dataCodecCBORTerm :: VersionNumber -> CodecCBORTerm Text VersionData
dataCodecCBORTerm VersionNumber
Version_0 = CodecCBORTerm {VersionData -> Term
encodeTerm :: VersionData -> Term
encodeTerm :: VersionData -> Term
encodeTerm, Term -> Either Text VersionData
decodeTerm :: Term -> Either Text VersionData
decodeTerm :: Term -> Either Text VersionData
decodeTerm}
    where
      -- We are using @CBOR.TInt@ instead of @CBOR.TInteger@, since for small
      -- integers generated by QuickCheck they will be encoded as @TkInt@ and then
      -- are decoded back to @CBOR.TInt@ rather than @COBR.TInteger@.  The same for
      -- other @CodecCBORTerm@ records.
      encodeTerm :: VersionData -> Term
encodeTerm VersionData { Int
dataVersion0 :: VersionData -> Int
dataVersion0 :: Int
dataVersion0 } =
        Int -> Term
CBOR.TInt Int
dataVersion0

      decodeTerm :: Term -> Either Text VersionData
decodeTerm (CBOR.TInt Int
dataVersion0) =
        VersionData -> Either Text VersionData
forall a b. b -> Either a b
Right VersionData { Int
dataVersion0 :: Int
dataVersion0 :: Int
dataVersion0,
                            dataVersion1 :: Bool
dataVersion1 = Bool
False,
                            dataVersion2 :: Bool
dataVersion2 = Bool
False }
      decodeTerm Term
n =
        Text -> Either Text VersionData
forall a b. a -> Either a b
Left (Text -> Either Text VersionData)
-> Text -> Either Text VersionData
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"decodeTerm VersionData: unrecognised tag: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Term -> String
forall a. Show a => a -> String
show Term
n

dataCodecCBORTerm VersionNumber
Version_1 = CodecCBORTerm {VersionData -> Term
encodeTerm :: VersionData -> Term
encodeTerm :: VersionData -> Term
encodeTerm, Term -> Either Text VersionData
decodeTerm :: Term -> Either Text VersionData
decodeTerm :: Term -> Either Text VersionData
decodeTerm}
    where
      encodeTerm :: VersionData -> Term
encodeTerm VersionData { Int
dataVersion0 :: VersionData -> Int
dataVersion0 :: Int
dataVersion0,
                               Bool
dataVersion1 :: VersionData -> Bool
dataVersion1 :: Bool
dataVersion1 } =
        [Term] -> Term
CBOR.TList [ Int -> Term
CBOR.TInt Int
dataVersion0,
                     Bool -> Term
CBOR.TBool Bool
dataVersion1 ]

      decodeTerm :: Term -> Either Text VersionData
decodeTerm (CBOR.TList [ CBOR.TInt Int
dataVersion0,
                               CBOR.TBool Bool
dataVersion1 ])
        = VersionData -> Either Text VersionData
forall a b. b -> Either a b
Right VersionData { Int
dataVersion0 :: Int
dataVersion0 :: Int
dataVersion0,
                              Bool
dataVersion1 :: Bool
dataVersion1 :: Bool
dataVersion1,
                              dataVersion2 :: Bool
dataVersion2 = Bool
False }
      decodeTerm Term
n
        = Text -> Either Text VersionData
forall a b. a -> Either a b
Left (Text -> Either Text VersionData)
-> Text -> Either Text VersionData
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"decodeTerm VersionData: unrecognised tag: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Term -> String
forall a. Show a => a -> String
show Term
n

dataCodecCBORTerm VersionNumber
Version_2 = CodecCBORTerm {VersionData -> Term
encodeTerm :: VersionData -> Term
encodeTerm :: VersionData -> Term
encodeTerm, Term -> Either Text VersionData
decodeTerm :: Term -> Either Text VersionData
decodeTerm :: Term -> Either Text VersionData
decodeTerm}
    where
      encodeTerm :: VersionData -> Term
encodeTerm VersionData { Int
dataVersion0 :: VersionData -> Int
dataVersion0 :: Int
dataVersion0,
                               Bool
dataVersion1 :: VersionData -> Bool
dataVersion1 :: Bool
dataVersion1,
                               Bool
dataVersion2 :: VersionData -> Bool
dataVersion2 :: Bool
dataVersion2 } =
        [Term] -> Term
CBOR.TList [ Int -> Term
CBOR.TInt Int
dataVersion0,
                     Bool -> Term
CBOR.TBool Bool
dataVersion1,
                     Bool -> Term
CBOR.TBool Bool
dataVersion2 ]

      decodeTerm :: Term -> Either Text VersionData
decodeTerm (CBOR.TList [ CBOR.TInt  Int
dataVersion0,
                               CBOR.TBool Bool
dataVersion1,
                               CBOR.TBool Bool
dataVersion2 ])
        = VersionData -> Either Text VersionData
forall a b. b -> Either a b
Right VersionData { Int
dataVersion0 :: Int
dataVersion0 :: Int
dataVersion0,
                              Bool
dataVersion1 :: Bool
dataVersion1 :: Bool
dataVersion1,
                              Bool
dataVersion2 :: Bool
dataVersion2 :: Bool
dataVersion2 }
      decodeTerm Term
n
        = Text -> Either Text VersionData
forall a b. a -> Either a b
Left (Text -> Either Text VersionData)
-> Text -> Either Text VersionData
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"decodeTerm Data: unrecognised tag: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Term -> String
forall a. Show a => a -> String
show Term
n

arbitraryVersionData :: VersionNumber -> Gen VersionData
arbitraryVersionData :: VersionNumber -> Gen VersionData
arbitraryVersionData VersionNumber
Version_0 = (\Int
a -> Int -> Bool -> Bool -> VersionData
VersionData Int
a Bool
False Bool
False)
                              (Int -> VersionData) -> Gen Int -> Gen VersionData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
arbitrary
arbitraryVersionData VersionNumber
Version_1 = (\Int
a Bool
b -> Int -> Bool -> Bool -> VersionData
VersionData Int
a Bool
b Bool
False)
                              (Int -> Bool -> VersionData)
-> Gen Int -> Gen (Bool -> VersionData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
arbitrary
                              Gen (Bool -> VersionData) -> Gen Bool -> Gen VersionData
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
arbitraryVersionData VersionNumber
Version_2 = Int -> Bool -> Bool -> VersionData
VersionData
                              (Int -> Bool -> Bool -> VersionData)
-> Gen Int -> Gen (Bool -> Bool -> VersionData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
arbitrary
                              Gen (Bool -> Bool -> VersionData)
-> Gen Bool -> Gen (Bool -> VersionData)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
                              Gen (Bool -> VersionData) -> Gen Bool -> Gen VersionData
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary

instance Arbitrary VersionData where
  arbitrary :: Gen VersionData
arbitrary = Gen VersionNumber
forall a. Arbitrary a => Gen a
arbitrary Gen VersionNumber
-> (VersionNumber -> Gen VersionData) -> Gen VersionData
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= VersionNumber -> Gen VersionData
arbitraryVersionData

instance CoArbitrary VersionData where

--
-- ProtocolVersion generators
--

application :: VersionData -> VersionData -> Bool
application :: VersionData -> VersionData -> Bool
application VersionData
d = \VersionData
d' ->
     (VersionData -> Int
dataVersion0 VersionData
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== VersionData -> Int
dataVersion0 VersionData
d')
     -- we take `&&` (see `acceptableVersions`
     -- below), which is like `*` in Z₂
  Bool -> Bool -> Bool
&& (VersionData -> Bool
dataVersion1 VersionData
d Bool -> Bool -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionData -> Bool
dataVersion1 VersionData
d')
     -- we take `||` (see `acceptableVersions`
     -- below), which is like `+` in Z₂
  Bool -> Bool -> Bool
&& (VersionData -> Bool
dataVersion2 VersionData
d Bool -> Bool -> Bool
forall a. Ord a => a -> a -> Bool
<= VersionData -> Bool
dataVersion2 VersionData
d')

-- |
-- Generate a valid @'ProtocolVersion' 'VersionNumber' r@
--
genValidVersion
  :: VersionNumber
  -> Gen (Version VersionData Bool)
genValidVersion :: VersionNumber -> Gen (Version VersionData Bool)
genValidVersion VersionNumber
version = do
  d <- VersionNumber -> Gen VersionData
arbitraryVersionData VersionNumber
version
  return $ Version (application d) d


-- |
-- Generate an invalid @'ProtocolVersion' 'VersionNumber' r@.
--
genInvalidVersion
  :: VersionNumber
  -> Gen (Version VersionData Bool)
genInvalidVersion :: VersionNumber -> Gen (Version VersionData Bool)
genInvalidVersion VersionNumber
Version_0 =
    [Gen (Version VersionData Bool)] -> Gen (Version VersionData Bool)
forall a. HasCallStack => [Gen a] -> Gen a
oneof [ VersionNumber -> Gen (Version VersionData Bool)
genValidVersion VersionNumber
Version_1
          , VersionNumber -> Gen (Version VersionData Bool)
genValidVersion VersionNumber
Version_2 ]
genInvalidVersion VersionNumber
Version_1 =
    [Gen (Version VersionData Bool)] -> Gen (Version VersionData Bool)
forall a. HasCallStack => [Gen a] -> Gen a
oneof [ VersionNumber -> Gen (Version VersionData Bool)
genValidVersion VersionNumber
Version_0
          , VersionNumber -> Gen (Version VersionData Bool)
genValidVersion VersionNumber
Version_2 ]
genInvalidVersion VersionNumber
Version_2 =
    [Gen (Version VersionData Bool)] -> Gen (Version VersionData Bool)
forall a. HasCallStack => [Gen a] -> Gen a
oneof [ VersionNumber -> Gen (Version VersionData Bool)
genValidVersion VersionNumber
Version_0
          , VersionNumber -> Gen (Version VersionData Bool)
genValidVersion VersionNumber
Version_1 ]

-- |
-- Generate valid @Versions@.
--
genValidVersions :: Gen (Versions VersionNumber VersionData Bool)
genValidVersions :: Gen (Versions VersionNumber VersionData Bool)
genValidVersions = do
  vns <- [VersionNumber] -> [VersionNumber]
forall a. Eq a => [a] -> [a]
nub ([VersionNumber] -> [VersionNumber])
-> Gen [VersionNumber] -> Gen [VersionNumber]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen [VersionNumber] -> Gen [VersionNumber]
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
3 (Gen VersionNumber -> Gen [VersionNumber]
forall a. Gen a -> Gen [a]
listOf1 (Gen VersionNumber
forall a. Arbitrary a => Gen a
arbitrary :: Gen VersionNumber))
  vs <- traverse genValidVersion vns
  return $ Versions $ Map.fromList $ zip vns vs

-- |
-- Generate possibly invalid @Versions@.
--
genVersions :: Gen (Versions VersionNumber VersionData Bool)
genVersions :: Gen (Versions VersionNumber VersionData Bool)
genVersions = do
  vns <- [VersionNumber] -> [VersionNumber]
forall a. Eq a => [a] -> [a]
nub ([VersionNumber] -> [VersionNumber])
-> Gen [VersionNumber] -> Gen [VersionNumber]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen [VersionNumber] -> Gen [VersionNumber]
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
3 (Gen VersionNumber -> Gen [VersionNumber]
forall a. Gen a -> Gen [a]
listOf1 (Gen VersionNumber
forall a. Arbitrary a => Gen a
arbitrary :: Gen VersionNumber))
  vs <- traverse (\VersionNumber
v -> [Gen (Version VersionData Bool)] -> Gen (Version VersionData Bool)
forall a. HasCallStack => [Gen a] -> Gen a
oneof [VersionNumber -> Gen (Version VersionData Bool)
genValidVersion VersionNumber
v, VersionNumber -> Gen (Version VersionData Bool)
genInvalidVersion VersionNumber
v]) vns
  return $ Versions $ Map.fromList $ zip vns vs

newtype ArbitraryValidVersions = ArbitraryValidVersions {
      ArbitraryValidVersions -> Versions VersionNumber VersionData Bool
runArbitraryValidVersions :: Versions VersionNumber VersionData Bool
    }

instance Show ArbitraryValidVersions where
    show :: ArbitraryValidVersions -> String
show (ArbitraryValidVersions (Versions Map VersionNumber (Version VersionData Bool)
vs)) = Map VersionNumber VersionData -> String
forall a. Show a => a -> String
show ((Version VersionData Bool -> VersionData)
-> Map VersionNumber (Version VersionData Bool)
-> Map VersionNumber VersionData
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Version VersionData Bool -> VersionData
forall vData r. Version vData r -> vData
versionData Map VersionNumber (Version VersionData Bool)
vs)

instance Arbitrary ArbitraryValidVersions where
    arbitrary :: Gen ArbitraryValidVersions
arbitrary = Versions VersionNumber VersionData Bool -> ArbitraryValidVersions
ArbitraryValidVersions (Versions VersionNumber VersionData Bool -> ArbitraryValidVersions)
-> Gen (Versions VersionNumber VersionData Bool)
-> Gen ArbitraryValidVersions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Versions VersionNumber VersionData Bool)
genValidVersions
    -- TODO: shrink (issue #3407)

prop_arbitrary_ArbitraryValidVersions
  :: ArbitraryValidVersions
  -> Bool
prop_arbitrary_ArbitraryValidVersions :: ArbitraryValidVersions -> Bool
prop_arbitrary_ArbitraryValidVersions (ArbitraryValidVersions Versions VersionNumber VersionData Bool
vs) =
    (Bool -> VersionNumber -> Version VersionData Bool -> Bool)
-> Bool -> Map VersionNumber (Version VersionData Bool) -> Bool
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (\Bool
r VersionNumber
vn Version VersionData Bool
s -> Bool
r Bool -> Bool -> Bool
&& VersionNumber -> Version VersionData Bool -> Bool
validVersion VersionNumber
vn Version VersionData Bool
s) Bool
True (Versions VersionNumber VersionData Bool
-> Map VersionNumber (Version VersionData Bool)
forall vNum vData r.
Versions vNum vData r -> Map vNum (Version vData r)
getVersions Versions VersionNumber VersionData Bool
vs)

prop_shrink_ArbitraryValidVersions
  :: ArbitraryValidVersions
  -> Bool
prop_shrink_ArbitraryValidVersions :: ArbitraryValidVersions -> Bool
prop_shrink_ArbitraryValidVersions ArbitraryValidVersions
a = (Bool -> Bool) -> [Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Bool -> Bool
forall a. a -> a
id
  [ (Bool -> VersionNumber -> Version VersionData Bool -> Bool)
-> Bool -> Map VersionNumber (Version VersionData Bool) -> Bool
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (\Bool
r VersionNumber
vn Version VersionData Bool
s -> Bool
r Bool -> Bool -> Bool
&& VersionNumber -> Version VersionData Bool -> Bool
validVersion VersionNumber
vn Version VersionData Bool
s) Bool
True (Versions VersionNumber VersionData Bool
-> Map VersionNumber (Version VersionData Bool)
forall vNum vData r.
Versions vNum vData r -> Map vNum (Version vData r)
getVersions Versions VersionNumber VersionData Bool
vs')
  | ArbitraryValidVersions Versions VersionNumber VersionData Bool
vs' <- ArbitraryValidVersions -> [ArbitraryValidVersions]
forall a. Arbitrary a => a -> [a]
shrink ArbitraryValidVersions
a
  ]

-- |
-- Generators for pairs of arbitrary list of versions.
--
data ArbitraryVersions =
  ArbitraryVersions
    (Versions VersionNumber VersionData Bool)
    (Versions VersionNumber VersionData Bool)

instance Show ArbitraryVersions where
    show :: ArbitraryVersions -> String
show (ArbitraryVersions (Versions Map VersionNumber (Version VersionData Bool)
vs) (Versions Map VersionNumber (Version VersionData Bool)
vs'))
      = String
"ArbitraryVersions " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Map VersionNumber VersionData -> String
forall a. Show a => a -> String
show ((Version VersionData Bool -> VersionData)
-> Map VersionNumber (Version VersionData Bool)
-> Map VersionNumber VersionData
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Version VersionData Bool -> VersionData
forall vData r. Version vData r -> vData
versionData Map VersionNumber (Version VersionData Bool)
vs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Map VersionNumber VersionData -> String
forall a. Show a => a -> String
show ((Version VersionData Bool -> VersionData)
-> Map VersionNumber (Version VersionData Bool)
-> Map VersionNumber VersionData
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Version VersionData Bool -> VersionData
forall vData r. Version vData r -> vData
versionData Map VersionNumber (Version VersionData Bool)
vs')

instance Arbitrary ArbitraryVersions where
    arbitrary :: Gen ArbitraryVersions
arbitrary = [(Int, Gen ArbitraryVersions)] -> Gen ArbitraryVersions
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
1, (\Versions VersionNumber VersionData Bool
v -> Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool -> ArbitraryVersions
ArbitraryVersions Versions VersionNumber VersionData Bool
v Versions VersionNumber VersionData Bool
v) (Versions VersionNumber VersionData Bool -> ArbitraryVersions)
-> Gen (Versions VersionNumber VersionData Bool)
-> Gen ArbitraryVersions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Versions VersionNumber VersionData Bool)
genVersions)
      , (Int
2, Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool -> ArbitraryVersions
ArbitraryVersions (Versions VersionNumber VersionData Bool
 -> Versions VersionNumber VersionData Bool -> ArbitraryVersions)
-> Gen (Versions VersionNumber VersionData Bool)
-> Gen
     (Versions VersionNumber VersionData Bool -> ArbitraryVersions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Versions VersionNumber VersionData Bool)
genVersions Gen (Versions VersionNumber VersionData Bool -> ArbitraryVersions)
-> Gen (Versions VersionNumber VersionData Bool)
-> Gen ArbitraryVersions
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Versions VersionNumber VersionData Bool)
genVersions)
      ]
    shrink :: ArbitraryVersions -> [ArbitraryVersions]
shrink (ArbitraryVersions (Versions Map VersionNumber (Version VersionData Bool)
vs) (Versions Map VersionNumber (Version VersionData Bool)
vs')) =
      [ Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool -> ArbitraryVersions
ArbitraryVersions (Map VersionNumber (Version VersionData Bool)
-> Versions VersionNumber VersionData Bool
forall vNum vData r.
Map vNum (Version vData r) -> Versions vNum vData r
Versions (Map VersionNumber (Version VersionData Bool)
 -> Versions VersionNumber VersionData Bool)
-> Map VersionNumber (Version VersionData Bool)
-> Versions VersionNumber VersionData Bool
forall a b. (a -> b) -> a -> b
$ [(VersionNumber, Version VersionData Bool)]
-> Map VersionNumber (Version VersionData Bool)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(VersionNumber, Version VersionData Bool)]
vs'') (Map VersionNumber (Version VersionData Bool)
-> Versions VersionNumber VersionData Bool
forall vNum vData r.
Map vNum (Version vData r) -> Versions vNum vData r
Versions Map VersionNumber (Version VersionData Bool)
vs')
      | [(VersionNumber, Version VersionData Bool)]
vs'' <- ((VersionNumber, Version VersionData Bool)
 -> [(VersionNumber, Version VersionData Bool)])
-> [(VersionNumber, Version VersionData Bool)]
-> [[(VersionNumber, Version VersionData Bool)]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([(VersionNumber, Version VersionData Bool)]
-> (VersionNumber, Version VersionData Bool)
-> [(VersionNumber, Version VersionData Bool)]
forall a b. a -> b -> a
const []) (Map VersionNumber (Version VersionData Bool)
-> [(VersionNumber, Version VersionData Bool)]
forall k a. Map k a -> [(k, a)]
Map.toList Map VersionNumber (Version VersionData Bool)
vs)
      ] [ArbitraryVersions] -> [ArbitraryVersions] -> [ArbitraryVersions]
forall a. [a] -> [a] -> [a]
++
      [ Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool -> ArbitraryVersions
ArbitraryVersions (Map VersionNumber (Version VersionData Bool)
-> Versions VersionNumber VersionData Bool
forall vNum vData r.
Map vNum (Version vData r) -> Versions vNum vData r
Versions Map VersionNumber (Version VersionData Bool)
vs) (Map VersionNumber (Version VersionData Bool)
-> Versions VersionNumber VersionData Bool
forall vNum vData r.
Map vNum (Version vData r) -> Versions vNum vData r
Versions (Map VersionNumber (Version VersionData Bool)
 -> Versions VersionNumber VersionData Bool)
-> Map VersionNumber (Version VersionData Bool)
-> Versions VersionNumber VersionData Bool
forall a b. (a -> b) -> a -> b
$ [(VersionNumber, Version VersionData Bool)]
-> Map VersionNumber (Version VersionData Bool)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(VersionNumber, Version VersionData Bool)]
vs'')
      | [(VersionNumber, Version VersionData Bool)]
vs'' <- ((VersionNumber, Version VersionData Bool)
 -> [(VersionNumber, Version VersionData Bool)])
-> [(VersionNumber, Version VersionData Bool)]
-> [[(VersionNumber, Version VersionData Bool)]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([(VersionNumber, Version VersionData Bool)]
-> (VersionNumber, Version VersionData Bool)
-> [(VersionNumber, Version VersionData Bool)]
forall a b. a -> b -> a
const []) (Map VersionNumber (Version VersionData Bool)
-> [(VersionNumber, Version VersionData Bool)]
forall k a. Map k a -> [(k, a)]
Map.toList Map VersionNumber (Version VersionData Bool)
vs')
      ]


-- |
-- Check if a @'ProtocolVersion' 'VersionNumber' r@ is valid.
--
validVersion :: VersionNumber -> Version VersionData Bool -> Bool
validVersion :: VersionNumber -> Version VersionData Bool -> Bool
validVersion VersionNumber
Version_0 ((Version VersionData -> Bool
_ VersionData
d)) = VersionData -> Bool
dataVersion1 VersionData
d Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False
                                      Bool -> Bool -> Bool
&& VersionData -> Bool
dataVersion2 VersionData
d Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False
validVersion VersionNumber
Version_1 ((Version VersionData -> Bool
_ VersionData
d)) = VersionData -> Bool
dataVersion2 VersionData
d Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False
validVersion VersionNumber
Version_2 ((Version VersionData -> Bool
_ VersionData
_)) = Bool
True


prop_arbitrary_ArbitraryVersions :: ArbitraryVersions -> Property
prop_arbitrary_ArbitraryVersions :: ArbitraryVersions -> Property
prop_arbitrary_ArbitraryVersions (ArbitraryVersions (Versions Map VersionNumber (Version VersionData Bool)
vs) (Versions Map VersionNumber (Version VersionData Bool)
vs')) =
    -- in 75% of cases the intersection is non-empty
    Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
75 Bool
intersect String
"non-empty intersection" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$

    -- in 10% of cases the intersection is empty
    Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
10 (Bool -> Bool
not Bool
intersect) String
"empty intersection" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$

    -- in 25% of cases the common max version is valid
    Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
25 (case Map VersionNumber (Version VersionData Bool)
-> Maybe (VersionNumber, Version VersionData Bool)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax Map VersionNumber (Version VersionData Bool)
intersection of
               Maybe (VersionNumber, Version VersionData Bool)
Nothing      -> Bool
False
               Just (VersionNumber
vn, Version VersionData Bool
s) -> VersionNumber -> Version VersionData Bool -> Bool
validVersion VersionNumber
vn Version VersionData Bool
s)
               String
"valid common max version" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$

    -- in 25% of cases all the versions in @vs'@ are either not in @vs@ or are
    -- not valid
    Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
25
      ((Bool -> VersionNumber -> Version VersionData Bool -> Bool)
-> Bool -> Map VersionNumber (Version VersionData Bool) -> Bool
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (\Bool
r VersionNumber
vn Version VersionData Bool
s -> Bool
r Bool -> Bool -> Bool
&& (Bool -> Bool
not (VersionNumber
vn VersionNumber -> [VersionNumber] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [VersionNumber]
knownVersionNumbers) Bool -> Bool -> Bool
|| Bool -> Bool
not (VersionNumber -> Version VersionData Bool -> Bool
validVersion VersionNumber
vn Version VersionData Bool
s))) Bool
True Map VersionNumber (Version VersionData Bool)
vs)
      String
"all versions are either unknown or not valid" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$

    Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
  where
    intersection :: Map VersionNumber (Version VersionData Bool)
intersection = Map VersionNumber (Version VersionData Bool)
vs Map VersionNumber (Version VersionData Bool)
-> Map VersionNumber (Version VersionData Bool)
-> Map VersionNumber (Version VersionData Bool)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.intersection` Map VersionNumber (Version VersionData Bool)
vs'
    intersect :: Bool
intersect    = Bool -> Bool
not (Map VersionNumber (Version VersionData Bool) -> Bool
forall k a. Map k a -> Bool
Map.null Map VersionNumber (Version VersionData Bool)
intersection)

    knownVersionNumbers :: [VersionNumber]
knownVersionNumbers = Map VersionNumber (Version VersionData Bool) -> [VersionNumber]
forall k a. Map k a -> [k]
Map.keys Map VersionNumber (Version VersionData Bool)
vs'

maybeAccept :: Accept a -> Maybe a
maybeAccept :: forall a. Accept a -> Maybe a
maybeAccept (Accept a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
maybeAccept (Refuse Text
_) = Maybe a
forall a. Maybe a
Nothing

-- | Run a handshake protocol, without going via a channel.
--
prop_connect :: ArbitraryVersions -> Property
prop_connect :: ArbitraryVersions -> Property
prop_connect (ArbitraryVersions Versions VersionNumber VersionData Bool
clientVersions Versions VersionNumber VersionData Bool
serverVersions) =
  let (Maybe Bool
serverRes, Maybe Bool
clientRes) =
        (VersionData -> VersionData -> Maybe VersionData)
-> Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool
-> (Maybe Bool, Maybe Bool)
forall vNumber vData r.
Ord vNumber =>
(vData -> vData -> Maybe vData)
-> Versions vNumber vData r
-> Versions vNumber vData r
-> (Maybe r, Maybe r)
pureHandshake
          ((Accept VersionData -> Maybe VersionData
forall a. Accept a -> Maybe a
maybeAccept (Accept VersionData -> Maybe VersionData)
-> (VersionData -> Accept VersionData)
-> VersionData
-> Maybe VersionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((VersionData -> Accept VersionData)
 -> VersionData -> Maybe VersionData)
-> (VersionData -> VersionData -> Accept VersionData)
-> VersionData
-> VersionData
-> Maybe VersionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionData -> VersionData -> Accept VersionData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion)
          Versions VersionNumber VersionData Bool
serverVersions
          Versions VersionNumber VersionData Bool
clientVersions
  in case (forall s.
 IOSim
   s
   (Either
      (HandshakeProtocolError VersionNumber)
      (HandshakeResult Bool VersionNumber VersionData),
    Either
      (HandshakeProtocolError VersionNumber)
      (HandshakeResult Bool VersionNumber VersionData),
    TerminalStates (Handshake VersionNumber Term)))
-> (Either
      (HandshakeProtocolError VersionNumber)
      (HandshakeResult Bool VersionNumber VersionData),
    Either
      (HandshakeProtocolError VersionNumber)
      (HandshakeResult Bool VersionNumber VersionData),
    TerminalStates (Handshake VersionNumber Term))
forall a. (forall s. IOSim s a) -> a
runSimOrThrow
           (Peer
  (Handshake VersionNumber Term)
  'AsClient
  'NonPipelined
  'StPropose
  (IOSim s)
  (Either
     (HandshakeProtocolError VersionNumber)
     (HandshakeResult Bool VersionNumber VersionData))
-> Peer
     (Handshake VersionNumber Term)
     (FlipAgency 'AsClient)
     'NonPipelined
     'StPropose
     (IOSim s)
     (Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData))
-> IOSim
     s
     (Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData),
      Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData),
      TerminalStates (Handshake VersionNumber Term))
forall ps (pr :: PeerRole) (initSt :: ps) (m :: * -> *) a b.
(Monad m, SingI pr) =>
Peer ps pr 'NonPipelined initSt m a
-> Peer ps (FlipAgency pr) 'NonPipelined initSt m b
-> m (a, b, TerminalStates ps)
connect
              (VersionDataCodec Term VersionNumber VersionData
-> (VersionData -> VersionData -> Accept VersionData)
-> Versions VersionNumber VersionData Bool
-> Peer
     (Handshake VersionNumber Term)
     'AsClient
     'NonPipelined
     'StPropose
     (IOSim s)
     (Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData))
forall vNumber vData r (m :: * -> *).
Ord vNumber =>
VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
handshakeClientPeer
                ((VersionNumber -> CodecCBORTerm Text VersionData)
-> VersionDataCodec Term VersionNumber VersionData
forall vNumber vData.
(vNumber -> CodecCBORTerm Text vData)
-> VersionDataCodec Term vNumber vData
cborTermVersionDataCodec VersionNumber -> CodecCBORTerm Text VersionData
dataCodecCBORTerm)
                VersionData -> VersionData -> Accept VersionData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion
                Versions VersionNumber VersionData Bool
clientVersions)
              (VersionDataCodec Term VersionNumber VersionData
-> (VersionData -> VersionData -> Accept VersionData)
-> (VersionData -> Bool)
-> Versions VersionNumber VersionData Bool
-> Server
     (Handshake VersionNumber Term)
     'NonPipelined
     'StPropose
     (IOSim s)
     (Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData))
forall vNumber vData r (m :: * -> *).
Ord vNumber =>
VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> (vData -> Bool)
-> Versions vNumber vData r
-> Server
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
handshakeServerPeer
                ((VersionNumber -> CodecCBORTerm Text VersionData)
-> VersionDataCodec Term VersionNumber VersionData
forall vNumber vData.
(vNumber -> CodecCBORTerm Text vData)
-> VersionDataCodec Term vNumber vData
cborTermVersionDataCodec VersionNumber -> CodecCBORTerm Text VersionData
dataCodecCBORTerm)
                VersionData -> VersionData -> Accept VersionData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion
                VersionData -> Bool
forall v. Queryable v => v -> Bool
queryVersion
                Versions VersionNumber VersionData Bool
serverVersions)) of
      (Either
  (HandshakeProtocolError VersionNumber)
  (HandshakeResult Bool VersionNumber VersionData)
clientRes', Either
  (HandshakeProtocolError VersionNumber)
  (HandshakeResult Bool VersionNumber VersionData)
serverRes', TerminalStates StateToken st
SingHandshake st
SingDone StateToken st
SingHandshake 'StDone
SingDone) ->
           Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
clientRes Bool -> Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== (HandshakeProtocolError VersionNumber -> Bool)
-> (HandshakeResult Bool VersionNumber VersionData -> Bool)
-> Either
     (HandshakeProtocolError VersionNumber)
     (HandshakeResult Bool VersionNumber VersionData)
-> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> HandshakeProtocolError VersionNumber -> Bool
forall a b. a -> b -> a
const Bool
False) HandshakeResult Bool VersionNumber VersionData -> Bool
forall {vNumber} {vData}.
HandshakeResult Bool vNumber vData -> Bool
extractRes Either
  (HandshakeProtocolError VersionNumber)
  (HandshakeResult Bool VersionNumber VersionData)
clientRes'
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
           Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
serverRes Bool -> Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== (HandshakeProtocolError VersionNumber -> Bool)
-> (HandshakeResult Bool VersionNumber VersionData -> Bool)
-> Either
     (HandshakeProtocolError VersionNumber)
     (HandshakeResult Bool VersionNumber VersionData)
-> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> HandshakeProtocolError VersionNumber -> Bool
forall a b. a -> b -> a
const Bool
False) HandshakeResult Bool VersionNumber VersionData -> Bool
forall {vNumber} {vData}.
HandshakeResult Bool vNumber vData -> Bool
extractRes Either
  (HandshakeProtocolError VersionNumber)
  (HandshakeResult Bool VersionNumber VersionData)
serverRes'
  where
    extractRes :: HandshakeResult Bool vNumber vData -> Bool
extractRes (HandshakeNegotiationResult Bool
r vNumber
_ vData
_) = Bool
r
    extractRes (HandshakeQueryResult Map vNumber (Either Text vData)
_)           = Bool
False

--
-- Properties using a channel
--

-- | Run a simple block-fetch client and server using connected channels.
--
prop_channel :: ( MonadAsync m
                , MonadCatch m
                , MonadST m
                )
             => m (Channel m ByteString, Channel m ByteString)
             -> Versions VersionNumber VersionData Bool
             -> Versions VersionNumber VersionData Bool
             -> m Property
prop_channel :: forall (m :: * -> *).
(MonadAsync m, MonadCatch m, MonadST m) =>
m (Channel m ByteString, Channel m ByteString)
-> Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool
-> m Property
prop_channel m (Channel m ByteString, Channel m ByteString)
createChannels Versions VersionNumber VersionData Bool
clientVersions Versions VersionNumber VersionData Bool
serverVersions =
  let (!Maybe Bool
serverRes, !Maybe Bool
clientRes) =
        (VersionData -> VersionData -> Maybe VersionData)
-> Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool
-> (Maybe Bool, Maybe Bool)
forall vNumber vData r.
Ord vNumber =>
(vData -> vData -> Maybe vData)
-> Versions vNumber vData r
-> Versions vNumber vData r
-> (Maybe r, Maybe r)
pureHandshake
          ((Accept VersionData -> Maybe VersionData
forall a. Accept a -> Maybe a
maybeAccept (Accept VersionData -> Maybe VersionData)
-> (VersionData -> Accept VersionData)
-> VersionData
-> Maybe VersionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((VersionData -> Accept VersionData)
 -> VersionData -> Maybe VersionData)
-> (VersionData -> VersionData -> Accept VersionData)
-> VersionData
-> VersionData
-> Maybe VersionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionData -> VersionData -> Accept VersionData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion)
          Versions VersionNumber VersionData Bool
serverVersions
          Versions VersionNumber VersionData Bool
clientVersions
  in do
    (!clientRes', !serverRes') <-
      m (Channel m ByteString, Channel m ByteString)
-> Tracer m (Role, TraceSendRecv (Handshake VersionNumber Term))
-> Codec
     (Handshake VersionNumber Term) DeserialiseFailure m ByteString
-> Peer
     (Handshake VersionNumber Term)
     'AsClient
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData))
-> Peer
     (Handshake VersionNumber Term)
     (FlipAgency 'AsClient)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData))
-> m (Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData),
      Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData))
forall ps (pr :: PeerRole) (st :: ps) failure bytes (m :: * -> *) a
       b.
(MonadAsync m, MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
m (Channel m bytes, Channel m bytes)
-> Tracer m (Role, TraceSendRecv ps)
-> Codec ps failure m bytes
-> Peer ps pr 'NonPipelined st m a
-> Peer ps (FlipAgency pr) 'NonPipelined st m b
-> m (a, b)
runConnectedPeers
        m (Channel m ByteString, Channel m ByteString)
createChannels Tracer m (Role, TraceSendRecv (Handshake VersionNumber Term))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Codec
  (Handshake VersionNumber Term) DeserialiseFailure m ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (Handshake VersionNumber Term) DeserialiseFailure m ByteString
versionNumberHandshakeCodec
        (VersionDataCodec Term VersionNumber VersionData
-> (VersionData -> VersionData -> Accept VersionData)
-> Versions VersionNumber VersionData Bool
-> Peer
     (Handshake VersionNumber Term)
     'AsClient
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData))
forall vNumber vData r (m :: * -> *).
Ord vNumber =>
VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
handshakeClientPeer
          ((VersionNumber -> CodecCBORTerm Text VersionData)
-> VersionDataCodec Term VersionNumber VersionData
forall vNumber vData.
(vNumber -> CodecCBORTerm Text vData)
-> VersionDataCodec Term vNumber vData
cborTermVersionDataCodec VersionNumber -> CodecCBORTerm Text VersionData
dataCodecCBORTerm)
          VersionData -> VersionData -> Accept VersionData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion
          Versions VersionNumber VersionData Bool
clientVersions)
        (VersionDataCodec Term VersionNumber VersionData
-> (VersionData -> VersionData -> Accept VersionData)
-> (VersionData -> Bool)
-> Versions VersionNumber VersionData Bool
-> Server
     (Handshake VersionNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData))
forall vNumber vData r (m :: * -> *).
Ord vNumber =>
VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> (vData -> Bool)
-> Versions vNumber vData r
-> Server
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
handshakeServerPeer
          ((VersionNumber -> CodecCBORTerm Text VersionData)
-> VersionDataCodec Term VersionNumber VersionData
forall vNumber vData.
(vNumber -> CodecCBORTerm Text vData)
-> VersionDataCodec Term vNumber vData
cborTermVersionDataCodec VersionNumber -> CodecCBORTerm Text VersionData
dataCodecCBORTerm)
          VersionData -> VersionData -> Accept VersionData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion
          VersionData -> Bool
forall v. Queryable v => v -> Bool
queryVersion
          Versions VersionNumber VersionData Bool
serverVersions)
    pure $!
      case (clientRes', serverRes') of
        -- both succeeded, we just check that the application (which is
        -- a boolean value) is the one that was put inside 'Version'
        (Right (HandshakeNegotiationResult !Bool
c VersionNumber
_ VersionData
_), Right (HandshakeNegotiationResult !Bool
s VersionNumber
_ VersionData
_)) ->
               Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
c Maybe Bool -> Maybe Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe Bool
clientRes
          Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
s Maybe Bool -> Maybe Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe Bool
serverRes

        -- both queried versions
        (Right (HandshakeQueryResult Map VersionNumber (Either Text VersionData)
_), Right (HandshakeQueryResult Map VersionNumber (Either Text VersionData)
_)) ->
          Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True

        -- both failed
        (Left{}, Left{})   -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True

        -- it should not happen that one protocol succeeds and the other end
        -- fails
        (Either
   (HandshakeProtocolError VersionNumber)
   (HandshakeResult Bool VersionNumber VersionData),
 Either
   (HandshakeProtocolError VersionNumber)
   (HandshakeResult Bool VersionNumber VersionData))
_                  -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False


-- | Run 'prop_channel' in the simulation monad.
--
prop_channel_ST :: ArbitraryVersions -> Property
prop_channel_ST :: ArbitraryVersions -> Property
prop_channel_ST (ArbitraryVersions Versions VersionNumber VersionData Bool
clientVersions Versions VersionNumber VersionData Bool
serverVersions) =
    (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow (IOSim
  s (Channel (IOSim s) ByteString, Channel (IOSim s) ByteString)
-> Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool
-> IOSim s Property
forall (m :: * -> *).
(MonadAsync m, MonadCatch m, MonadST m) =>
m (Channel m ByteString, Channel m ByteString)
-> Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool
-> m Property
prop_channel IOSim
  s (Channel (IOSim s) ByteString, Channel (IOSim s) ByteString)
forall (m :: * -> *) a. MonadSTM m => m (Channel m a, Channel m a)
createConnectedChannels Versions VersionNumber VersionData Bool
clientVersions Versions VersionNumber VersionData Bool
serverVersions)


-- | Run 'prop_channel' in the IO monad.
--
prop_channel_IO :: ArbitraryVersions -> Property
prop_channel_IO :: ArbitraryVersions -> Property
prop_channel_IO (ArbitraryVersions Versions VersionNumber VersionData Bool
clientVersions Versions VersionNumber VersionData Bool
serverVersions) =
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO (Channel IO ByteString, Channel IO ByteString)
-> Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool
-> IO Property
forall (m :: * -> *).
(MonadAsync m, MonadCatch m, MonadST m) =>
m (Channel m ByteString, Channel m ByteString)
-> Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool
-> m Property
prop_channel IO (Channel IO ByteString, Channel IO ByteString)
forall (m :: * -> *) a. MonadSTM m => m (Channel m a, Channel m a)
createConnectedChannels Versions VersionNumber VersionData Bool
clientVersions Versions VersionNumber VersionData Bool
serverVersions)


-- | Run 'prop_channel' in the IO monad using local pipes.
--
prop_pipe_IO :: ArbitraryVersions -> Property
prop_pipe_IO :: ArbitraryVersions -> Property
prop_pipe_IO (ArbitraryVersions Versions VersionNumber VersionData Bool
clientVersions Versions VersionNumber VersionData Bool
serverVersions) =
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO (Channel IO ByteString, Channel IO ByteString)
-> Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool
-> IO Property
forall (m :: * -> *).
(MonadAsync m, MonadCatch m, MonadST m) =>
m (Channel m ByteString, Channel m ByteString)
-> Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool
-> m Property
prop_channel IO (Channel IO ByteString, Channel IO ByteString)
createPipeConnectedChannels Versions VersionNumber VersionData Bool
clientVersions Versions VersionNumber VersionData Bool
serverVersions)

--
-- Asymmetric tests
--


-- | Run a simple handshake client and server using connected channels.
-- The server can only decode a subset of versions send by client.
-- This test is using a fixed server 'Versions' which can only accept
-- a single version 'Version_1' (it cannot decode any other version).
--
prop_channel_asymmetric
    :: ( MonadAsync m
       , MonadMask  m
       , MonadST m
       )
    => m (Channel m ByteString, Channel m ByteString)
    -> Versions VersionNumber VersionData Bool
    -- ^ client versions
    -> m Property
prop_channel_asymmetric :: forall (m :: * -> *).
(MonadAsync m, MonadMask m, MonadST m) =>
m (Channel m ByteString, Channel m ByteString)
-> Versions VersionNumber VersionData Bool -> m Property
prop_channel_asymmetric m (Channel m ByteString, Channel m ByteString)
createChannels Versions VersionNumber VersionData Bool
clientVersions = do
    (clientRes', serverRes') <-
      m (Channel m ByteString, Channel m ByteString)
-> Tracer m (Role, TraceSendRecv (Handshake VersionNumber Term))
-> Codec
     (Handshake VersionNumber Term) DeserialiseFailure m ByteString
-> Codec
     (Handshake VersionNumber Term) DeserialiseFailure m ByteString
-> Peer
     (Handshake VersionNumber Term)
     'AsClient
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData))
-> Peer
     (Handshake VersionNumber Term)
     (FlipAgency 'AsClient)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData))
-> m (Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData),
      Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData))
forall (m :: * -> *) ps failure bytes (pr :: PeerRole) (st :: ps) a
       b.
(MonadAsync m, MonadMask m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
m (Channel m bytes, Channel m bytes)
-> Tracer m (Role, TraceSendRecv ps)
-> Codec ps failure m bytes
-> Codec ps failure m bytes
-> Peer ps pr 'NonPipelined st m a
-> Peer ps (FlipAgency pr) 'NonPipelined st m b
-> m (a, b)
runConnectedPeersAsymmetric
        m (Channel m ByteString, Channel m ByteString)
createChannels
        Tracer m (Role, TraceSendRecv (Handshake VersionNumber Term))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
        Codec
  (Handshake VersionNumber Term) DeserialiseFailure m ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (Handshake VersionNumber Term) DeserialiseFailure m ByteString
versionNumberHandshakeCodec
        (CodecCBORTerm (String, Maybe Int) VersionNumber
-> Codec
     (Handshake VersionNumber Term) DeserialiseFailure m ByteString
forall vNumber (m :: * -> *) failure.
(MonadST m, Ord vNumber, Show failure) =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
codecHandshake CodecCBORTerm (String, Maybe Int) VersionNumber
versionNumberCodec')
        (VersionDataCodec Term VersionNumber VersionData
-> (VersionData -> VersionData -> Accept VersionData)
-> Versions VersionNumber VersionData Bool
-> Peer
     (Handshake VersionNumber Term)
     'AsClient
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData))
forall vNumber vData r (m :: * -> *).
Ord vNumber =>
VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
handshakeClientPeer
          ((VersionNumber -> CodecCBORTerm Text VersionData)
-> VersionDataCodec Term VersionNumber VersionData
forall vNumber vData.
(vNumber -> CodecCBORTerm Text vData)
-> VersionDataCodec Term vNumber vData
cborTermVersionDataCodec VersionNumber -> CodecCBORTerm Text VersionData
dataCodecCBORTerm)
          VersionData -> VersionData -> Accept VersionData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion
          Versions VersionNumber VersionData Bool
clientVersions)
        (VersionDataCodec Term VersionNumber VersionData
-> (VersionData -> VersionData -> Accept VersionData)
-> (VersionData -> Bool)
-> Versions VersionNumber VersionData Bool
-> Server
     (Handshake VersionNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError VersionNumber)
        (HandshakeResult Bool VersionNumber VersionData))
forall vNumber vData r (m :: * -> *).
Ord vNumber =>
VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> (vData -> Bool)
-> Versions vNumber vData r
-> Server
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
handshakeServerPeer
          ((VersionNumber -> CodecCBORTerm Text VersionData)
-> VersionDataCodec Term VersionNumber VersionData
forall vNumber vData.
(vNumber -> CodecCBORTerm Text vData)
-> VersionDataCodec Term vNumber vData
cborTermVersionDataCodec VersionNumber -> CodecCBORTerm Text VersionData
dataCodecCBORTerm)
          VersionData -> VersionData -> Accept VersionData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion
          VersionData -> Bool
forall v. Queryable v => v -> Bool
queryVersion
          Versions VersionNumber VersionData Bool
serverVersions)
    pure $
      case (clientRes', serverRes') of
        (Right (HandshakeNegotiationResult Bool
c VersionNumber
_ VersionData
_), Right (HandshakeNegotiationResult Bool
s VersionNumber
_ VersionData
_))
                           -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
c Maybe Bool -> Maybe Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe Bool
clientRes
                         Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
s Maybe Bool -> Maybe Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe Bool
serverRes
        (Right (HandshakeQueryResult Map VersionNumber (Either Text VersionData)
_), Right (HandshakeQueryResult Map VersionNumber (Either Text VersionData)
_))
                           -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True

        (Left{}, Left{})   -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
        (Either
   (HandshakeProtocolError VersionNumber)
   (HandshakeResult Bool VersionNumber VersionData),
 Either
   (HandshakeProtocolError VersionNumber)
   (HandshakeResult Bool VersionNumber VersionData))
_                  -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False

  where
    -- server versions
    serverVersions :: Versions VersionNumber VersionData Bool
    serverVersions :: Versions VersionNumber VersionData Bool
serverVersions =
      let d :: VersionData
d = Int -> Bool -> Bool -> VersionData
VersionData Int
0 Bool
True Bool
True in
      Map VersionNumber (Version VersionData Bool)
-> Versions VersionNumber VersionData Bool
forall vNum vData r.
Map vNum (Version vData r) -> Versions vNum vData r
Versions
        (Map VersionNumber (Version VersionData Bool)
 -> Versions VersionNumber VersionData Bool)
-> Map VersionNumber (Version VersionData Bool)
-> Versions VersionNumber VersionData Bool
forall a b. (a -> b) -> a -> b
$ VersionNumber
-> Version VersionData Bool
-> Map VersionNumber (Version VersionData Bool)
forall k a. k -> a -> Map k a
Map.singleton
            VersionNumber
Version_1
            ((VersionData -> Bool) -> VersionData -> Version VersionData Bool
forall vData r. (vData -> r) -> vData -> Version vData r
Version (VersionData -> VersionData -> Bool
application VersionData
d) VersionData
d)


    -- This codec does not know how to decode 'Version_0' and 'Version_2'.
    versionNumberCodec' :: CodecCBORTerm (String, Maybe Int) VersionNumber
    versionNumberCodec' :: CodecCBORTerm (String, Maybe Int) VersionNumber
versionNumberCodec' = CodecCBORTerm { VersionNumber -> Term
encodeTerm :: VersionNumber -> Term
encodeTerm :: VersionNumber -> Term
encodeTerm, Term -> Either (String, Maybe Int) VersionNumber
decodeTerm :: Term -> Either (String, Maybe Int) VersionNumber
decodeTerm :: Term -> Either (String, Maybe Int) VersionNumber
decodeTerm }
      where
        encodeTerm :: VersionNumber -> Term
encodeTerm VersionNumber
Version_1 = Int -> Term
CBOR.TInt Int
1
        encodeTerm VersionNumber
_         = String -> Term
forall a. HasCallStack => String -> a
error String
"server encoder error"

        decodeTerm :: Term -> Either (String, Maybe Int) VersionNumber
decodeTerm (CBOR.TInt Int
1) = VersionNumber -> Either (String, Maybe Int) VersionNumber
forall a b. b -> Either a b
Right VersionNumber
Version_1
        decodeTerm (CBOR.TInt Int
n) = (String, Maybe Int) -> Either (String, Maybe Int) VersionNumber
forall a b. a -> Either a b
Left (String
"unknown version", Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n)
        decodeTerm Term
_             = (String, Maybe Int) -> Either (String, Maybe Int) VersionNumber
forall a b. a -> Either a b
Left (String
"unknown tag", Maybe Int
forall a. Maybe a
Nothing)

    (Maybe Bool
serverRes, Maybe Bool
clientRes) =
      (VersionData -> VersionData -> Maybe VersionData)
-> Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool
-> (Maybe Bool, Maybe Bool)
forall vNumber vData r.
Ord vNumber =>
(vData -> vData -> Maybe vData)
-> Versions vNumber vData r
-> Versions vNumber vData r
-> (Maybe r, Maybe r)
pureHandshake
        ((Accept VersionData -> Maybe VersionData
forall a. Accept a -> Maybe a
maybeAccept (Accept VersionData -> Maybe VersionData)
-> (VersionData -> Accept VersionData)
-> VersionData
-> Maybe VersionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((VersionData -> Accept VersionData)
 -> VersionData -> Maybe VersionData)
-> (VersionData -> VersionData -> Accept VersionData)
-> VersionData
-> VersionData
-> Maybe VersionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionData -> VersionData -> Accept VersionData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion)
        Versions VersionNumber VersionData Bool
serverVersions
        Versions VersionNumber VersionData Bool
clientVersions



-- | Run 'prop_channel' in the simulation monad.
--
prop_channel_asymmetric_ST :: ArbitraryVersions -> Property
prop_channel_asymmetric_ST :: ArbitraryVersions -> Property
prop_channel_asymmetric_ST (ArbitraryVersions Versions VersionNumber VersionData Bool
clientVersions Versions VersionNumber VersionData Bool
_serverVersions) =
    (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow (IOSim
  s (Channel (IOSim s) ByteString, Channel (IOSim s) ByteString)
-> Versions VersionNumber VersionData Bool -> IOSim s Property
forall (m :: * -> *).
(MonadAsync m, MonadMask m, MonadST m) =>
m (Channel m ByteString, Channel m ByteString)
-> Versions VersionNumber VersionData Bool -> m Property
prop_channel_asymmetric IOSim
  s (Channel (IOSim s) ByteString, Channel (IOSim s) ByteString)
forall (m :: * -> *) a. MonadSTM m => m (Channel m a, Channel m a)
createConnectedChannels Versions VersionNumber VersionData Bool
clientVersions)


-- | Run 'prop_channel' in the IO monad.
--
prop_channel_asymmetric_IO :: ArbitraryVersions -> Property
prop_channel_asymmetric_IO :: ArbitraryVersions -> Property
prop_channel_asymmetric_IO (ArbitraryVersions Versions VersionNumber VersionData Bool
clientVersions Versions VersionNumber VersionData Bool
_serverVersions) =
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO (Channel IO ByteString, Channel IO ByteString)
-> Versions VersionNumber VersionData Bool -> IO Property
forall (m :: * -> *).
(MonadAsync m, MonadMask m, MonadST m) =>
m (Channel m ByteString, Channel m ByteString)
-> Versions VersionNumber VersionData Bool -> m Property
prop_channel_asymmetric IO (Channel IO ByteString, Channel IO ByteString)
forall (m :: * -> *) a. MonadSTM m => m (Channel m a, Channel m a)
createConnectedChannels Versions VersionNumber VersionData Bool
clientVersions)


-- | Run 'prop_channel' in the IO monad using local pipes.
--
prop_pipe_asymmetric_IO :: ArbitraryVersions -> Property
prop_pipe_asymmetric_IO :: ArbitraryVersions -> Property
prop_pipe_asymmetric_IO (ArbitraryVersions Versions VersionNumber VersionData Bool
clientVersions Versions VersionNumber VersionData Bool
_serverVersions) =
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO (Channel IO ByteString, Channel IO ByteString)
-> Versions VersionNumber VersionData Bool -> IO Property
forall (m :: * -> *).
(MonadAsync m, MonadMask m, MonadST m) =>
m (Channel m ByteString, Channel m ByteString)
-> Versions VersionNumber VersionData Bool -> m Property
prop_channel_asymmetric IO (Channel IO ByteString, Channel IO ByteString)
createPipeConnectedChannels Versions VersionNumber VersionData Bool
clientVersions)



prop_acceptable_symmetric
  :: ( Acceptable vData
     , Eq vData
     )
  => vData
  -> vData
  -> Bool
prop_acceptable_symmetric :: forall vData.
(Acceptable vData, Eq vData) =>
vData -> vData -> Bool
prop_acceptable_symmetric vData
vData vData
vData' =
    case (vData -> vData -> Accept vData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion vData
vData vData
vData', vData -> vData -> Accept vData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion vData
vData' vData
vData) of
      (Accept vData
a, Accept vData
b) -> vData
a vData -> vData -> Bool
forall a. Eq a => a -> a -> Bool
== vData
b
      (Refuse Text
_, Refuse Text
_) -> Bool
True
      (Accept vData
_       , Accept vData
_       ) -> Bool
False

prop_acceptable_symmetric_VersionData
  :: VersionData
  -> VersionData
  -> Bool
prop_acceptable_symmetric_VersionData :: VersionData -> VersionData -> Bool
prop_acceptable_symmetric_VersionData VersionData
a VersionData
b =
    VersionData -> VersionData -> Bool
forall vData.
(Acceptable vData, Eq vData) =>
vData -> vData -> Bool
prop_acceptable_symmetric VersionData
a VersionData
b


-- | Run a query for the server's supported version.
--
prop_query_version :: ( MonadAsync m
                      , MonadCatch m
                      , Eq vData
                      , Acceptable vData
                      , Queryable vData
                      , Show vData
                      , Ord vNumber
                      , Show vNumber
                      )
                   => m (Channel m ByteString, Channel m ByteString)
                   -> Codec (Handshake vNumber CBOR.Term)
                             CBOR.DeserialiseFailure m ByteString
                   -> VersionDataCodec CBOR.Term vNumber vData
                   -> Versions vNumber vData Bool
                   -> Versions vNumber vData Bool
                   -> (vData -> vData)
                   -> m Property
prop_query_version :: forall (m :: * -> *) vData vNumber.
(MonadAsync m, MonadCatch m, Eq vData, Acceptable vData,
 Queryable vData, Show vData, Ord vNumber, Show vNumber) =>
m (Channel m ByteString, Channel m ByteString)
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
-> VersionDataCodec Term vNumber vData
-> Versions vNumber vData Bool
-> Versions vNumber vData Bool
-> (vData -> vData)
-> m Property
prop_query_version m (Channel m ByteString, Channel m ByteString)
createChannels Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
codec VersionDataCodec Term vNumber vData
versionDataCodec Versions vNumber vData Bool
clientVersions Versions vNumber vData Bool
serverVersions vData -> vData
setQuery = do
  (clientRes, _serverRes) <-
    m (Channel m ByteString, Channel m ByteString)
-> Tracer m (Role, TraceSendRecv (Handshake vNumber Term))
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber)
        (HandshakeResult Bool vNumber vData))
-> Peer
     (Handshake vNumber Term)
     (FlipAgency 'AsClient)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber)
        (HandshakeResult Bool vNumber vData))
-> m (Either
        (HandshakeProtocolError vNumber)
        (HandshakeResult Bool vNumber vData),
      Either
        (HandshakeProtocolError vNumber)
        (HandshakeResult Bool vNumber vData))
forall ps (pr :: PeerRole) (st :: ps) failure bytes (m :: * -> *) a
       b.
(MonadAsync m, MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
m (Channel m bytes, Channel m bytes)
-> Tracer m (Role, TraceSendRecv ps)
-> Codec ps failure m bytes
-> Peer ps pr 'NonPipelined st m a
-> Peer ps (FlipAgency pr) 'NonPipelined st m b
-> m (a, b)
runConnectedPeers
      m (Channel m ByteString, Channel m ByteString)
createChannels Tracer m (Role, TraceSendRecv (Handshake vNumber Term))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
codec
      (VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData Bool
-> Peer
     (Handshake vNumber Term)
     'AsClient
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber)
        (HandshakeResult Bool vNumber vData))
forall vNumber vData r (m :: * -> *).
Ord vNumber =>
VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
handshakeClientPeer
        VersionDataCodec Term vNumber vData
versionDataCodec
        vData -> vData -> Accept vData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion
        Versions vNumber vData Bool
clientVersions')
      (VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> (vData -> Bool)
-> Versions vNumber vData Bool
-> Server
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber)
        (HandshakeResult Bool vNumber vData))
forall vNumber vData r (m :: * -> *).
Ord vNumber =>
VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> (vData -> Bool)
-> Versions vNumber vData r
-> Server
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
handshakeServerPeer
        VersionDataCodec Term vNumber vData
versionDataCodec
        vData -> vData -> Accept vData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion
        vData -> Bool
forall v. Queryable v => v -> Bool
queryVersion
        Versions vNumber vData Bool
serverVersions)
  pure $ case clientRes of
    -- Ignore handshake errors.
    Left HandshakeProtocolError vNumber
_ ->
      Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    -- We should receive the queried versions.
    Right HandshakeNegotiationResult {} ->
      -- We will only receive a negotiated result if the negotiated version does not support queries.
      Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
    -- On successful handshakes, the received versions should match the server versions (ignoring `query`).
    Right (HandshakeQueryResult Map vNumber (Either Text vData)
serverVersions') ->
      Map vNumber (Either Text vData) -> Map vNumber (Either Text vData)
setQueryAll Map vNumber (Either Text vData)
serverVersions' Map vNumber (Either Text vData)
-> Map vNumber (Either Text vData) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Map vNumber (Either Text vData) -> Map vNumber (Either Text vData)
setQueryAll (vData -> Either Text vData
forall a b. b -> Either a b
Right (vData -> Either Text vData)
-> (Version vData Bool -> vData)
-> Version vData Bool
-> Either Text vData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version vData Bool -> vData
forall vData r. Version vData r -> vData
versionData (Version vData Bool -> Either Text vData)
-> Map vNumber (Version vData Bool)
-> Map vNumber (Either Text vData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Versions vNumber vData Bool -> Map vNumber (Version vData Bool)
forall vNum vData r.
Versions vNum vData r -> Map vNum (Version vData r)
getVersions Versions vNumber vData Bool
serverVersions)
  where
    setQueryAll :: Map vNumber (Either Text vData) -> Map vNumber (Either Text vData)
setQueryAll Map vNumber (Either Text vData)
vs = (vData -> vData
setQuery (vData -> vData) -> Either Text vData -> Either Text vData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Either Text vData -> Either Text vData)
-> Map vNumber (Either Text vData)
-> Map vNumber (Either Text vData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map vNumber (Either Text vData)
vs
    setQueryVersions :: Versions vNumber vData Bool -> Versions vNumber vData Bool
setQueryVersions (Versions Map vNumber (Version vData Bool)
vs) = Map vNumber (Version vData Bool) -> Versions vNumber vData Bool
forall vNum vData r.
Map vNum (Version vData r) -> Versions vNum vData r
Versions (Map vNumber (Version vData Bool) -> Versions vNumber vData Bool)
-> Map vNumber (Version vData Bool) -> Versions vNumber vData Bool
forall a b. (a -> b) -> a -> b
$ (\vNumber
_k Version vData Bool
v -> Version vData Bool
v { versionData = setQuery (versionData v) }) (vNumber -> Version vData Bool -> Version vData Bool)
-> Map vNumber (Version vData Bool)
-> Map vNumber (Version vData Bool)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
`Map.mapWithKey` Map vNumber (Version vData Bool)
vs
    clientVersions' :: Versions vNumber vData Bool
clientVersions' = Versions vNumber vData Bool -> Versions vNumber vData Bool
setQueryVersions Versions vNumber vData Bool
clientVersions


-- | Run 'prop_peerSharing_symmetric' with SimNet.
--
-- | 'acceptOrRefuse' is symmetric in the following sense:
--
-- Either both sides:
-- * accept the same version and version data; or
-- * refuse
--
-- The refuse reason might differ, although if one side refuses it with
-- `Refused` the other side must refuse the same version.
--
prop_acceptOrRefuse_symmetric
  :: forall vNumber vData r.
     ( Acceptable vData
     , Eq   vData
     , Show vData
     , Ord  vNumber
     , Show vNumber
     )
  => Versions vNumber vData r
  -> Versions vNumber vData r
  -> Property
prop_acceptOrRefuse_symmetric :: forall vNumber vData r.
(Acceptable vData, Eq vData, Show vData, Ord vNumber,
 Show vNumber) =>
Versions vNumber vData r -> Versions vNumber vData r -> Property
prop_acceptOrRefuse_symmetric Versions vNumber vData r
clientVersions Versions vNumber vData r
serverVersions =
    case ( VersionDataCodec vData vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Map vNumber vData
-> Either (RefuseReason vNumber) (r, vNumber, vData)
forall vParams vNumber vData r.
Ord vNumber =>
VersionDataCodec vParams vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Map vNumber vParams
-> Either (RefuseReason vNumber) (r, vNumber, vData)
acceptOrRefuse VersionDataCodec vData vNumber vData
codec vData -> vData -> Accept vData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion Versions vNumber vData r
clientVersions Map vNumber vData
serverMap
         , VersionDataCodec vData vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Map vNumber vData
-> Either (RefuseReason vNumber) (r, vNumber, vData)
forall vParams vNumber vData r.
Ord vNumber =>
VersionDataCodec vParams vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Map vNumber vParams
-> Either (RefuseReason vNumber) (r, vNumber, vData)
acceptOrRefuse VersionDataCodec vData vNumber vData
codec vData -> vData -> Accept vData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion Versions vNumber vData r
serverVersions Map vNumber vData
clientMap
         ) of
      (Right (r
_, vNumber
vNumber, vData
vData), Right (r
_, vNumber
vNumber', vData
vData')) ->
             vNumber
vNumber vNumber -> vNumber -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== vNumber
vNumber'
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. vData
vData   vData -> vData -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== vData
vData'
      (Left (VersionMismatch [vNumber]
vNumbers [Int]
_), Left (VersionMismatch [vNumber]
vNumbers' [Int]
_)) ->
             [vNumber]
vNumbers  [vNumber] -> [vNumber] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Map vNumber vData -> [vNumber]
forall k a. Map k a -> [k]
Map.keys Map vNumber vData
clientMap
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. [vNumber]
vNumbers' [vNumber] -> [vNumber] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Map vNumber vData -> [vNumber]
forall k a. Map k a -> [k]
Map.keys Map vNumber vData
serverMap
      (Left HandshakeDecodeError {}, Left RefuseReason vNumber
_) ->
        Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
      (Left RefuseReason vNumber
_, Left HandshakeDecodeError {}) ->
        Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
      (Left (Refused vNumber
vNumber Text
_), Left (Refused vNumber
vNumber' Text
_)) ->
        vNumber
vNumber vNumber -> vNumber -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== vNumber
vNumber'
      (Either (RefuseReason vNumber) (r, vNumber, vData)
_      , Either (RefuseReason vNumber) (r, vNumber, vData)
_      ) ->
        Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False

  where
    codec :: VersionDataCodec vData vNumber vData
    codec :: VersionDataCodec vData vNumber vData
codec = VersionDataCodec {
        encodeData :: vNumber -> vData -> vData
encodeData = \vNumber
_ vData
vData -> vData
vData,
        decodeData :: vNumber -> vData -> Either Text vData
decodeData = \vNumber
_ vData
vData -> vData -> Either Text vData
forall a b. b -> Either a b
Right vData
vData
      }

    toMap :: Versions vNumber vData r
          -> Map vNumber vData
    toMap :: Versions vNumber vData r -> Map vNumber vData
toMap (Versions Map vNumber (Version vData r)
m) = Version vData r -> vData
forall vData r. Version vData r -> vData
versionData (Version vData r -> vData)
-> Map vNumber (Version vData r) -> Map vNumber vData
forall a b k. (a -> b) -> Map k a -> Map k b
`Map.map` Map vNumber (Version vData r)
m

    clientMap :: Map vNumber vData
clientMap = Versions vNumber vData r -> Map vNumber vData
toMap Versions vNumber vData r
clientVersions
    serverMap :: Map vNumber vData
serverMap = Versions vNumber vData r -> Map vNumber vData
toMap Versions vNumber vData r
serverVersions


prop_acceptOrRefuse_symmetric_VersionData
  :: ArbitraryVersions
  -> Property
prop_acceptOrRefuse_symmetric_VersionData :: ArbitraryVersions -> Property
prop_acceptOrRefuse_symmetric_VersionData (ArbitraryVersions Versions VersionNumber VersionData Bool
a Versions VersionNumber VersionData Bool
b) =
    Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool -> Property
forall vNumber vData r.
(Acceptable vData, Eq vData, Show vData, Ord vNumber,
 Show vNumber) =>
Versions vNumber vData r -> Versions vNumber vData r -> Property
prop_acceptOrRefuse_symmetric Versions VersionNumber VersionData Bool
a Versions VersionNumber VersionData Bool
b


-- | Run two handshake clients against each other, which simulates a TCP
-- simultaneous open.
--
prop_channel_simultaneous_open
    :: ( MonadAsync m
       , MonadCatch m
       , Acceptable vData
       , Ord vNumber
       )
    => m (Channel m ByteString, Channel m ByteString)
    -> Codec (Handshake vNumber CBOR.Term)
              CBOR.DeserialiseFailure m ByteString
    -> VersionDataCodec CBOR.Term vNumber vData
    -> Versions vNumber vData Bool
    -> Versions vNumber vData Bool
    -> m Property
prop_channel_simultaneous_open :: forall (m :: * -> *) vData vNumber.
(MonadAsync m, MonadCatch m, Acceptable vData, Ord vNumber) =>
m (Channel m ByteString, Channel m ByteString)
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
-> VersionDataCodec Term vNumber vData
-> Versions vNumber vData Bool
-> Versions vNumber vData Bool
-> m Property
prop_channel_simultaneous_open m (Channel m ByteString, Channel m ByteString)
createChannels Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
codec VersionDataCodec Term vNumber vData
versionDataCodec Versions vNumber vData Bool
clientVersions Versions vNumber vData Bool
serverVersions =
  let (Maybe Bool
serverRes, Maybe Bool
clientRes) =
        (vData -> vData -> Maybe vData)
-> Versions vNumber vData Bool
-> Versions vNumber vData Bool
-> (Maybe Bool, Maybe Bool)
forall vNumber vData r.
Ord vNumber =>
(vData -> vData -> Maybe vData)
-> Versions vNumber vData r
-> Versions vNumber vData r
-> (Maybe r, Maybe r)
pureHandshake
          ((Accept vData -> Maybe vData
forall a. Accept a -> Maybe a
maybeAccept (Accept vData -> Maybe vData)
-> (vData -> Accept vData) -> vData -> Maybe vData
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((vData -> Accept vData) -> vData -> Maybe vData)
-> (vData -> vData -> Accept vData)
-> vData
-> vData
-> Maybe vData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. vData -> vData -> Accept vData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion)
          Versions vNumber vData Bool
serverVersions
          Versions vNumber vData Bool
clientVersions
  in do
    (clientChannel, serverChannel) <- m (Channel m ByteString, Channel m ByteString)
createChannels
    let client  = VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData Bool
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber)
        (HandshakeResult Bool vNumber vData))
forall vNumber vData r (m :: * -> *).
Ord vNumber =>
VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
handshakeClientPeer
                    VersionDataCodec Term vNumber vData
versionDataCodec
                    vData -> vData -> Accept vData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion
                    Versions vNumber vData Bool
clientVersions
        client' = VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData Bool
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber)
        (HandshakeResult Bool vNumber vData))
forall vNumber vData r (m :: * -> *).
Ord vNumber =>
VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions vNumber vData r
-> Client
     (Handshake vNumber Term)
     'NonPipelined
     'StPropose
     m
     (Either
        (HandshakeProtocolError vNumber) (HandshakeResult r vNumber vData))
handshakeClientPeer
                    VersionDataCodec Term vNumber vData
versionDataCodec
                    vData -> vData -> Accept vData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion
                    Versions vNumber vData Bool
serverVersions
    (clientRes', serverRes') <-
      (fst <$> runPeer nullTracer
                      -- (("client",) `contramap` Tracer Debug.traceShowM)
                       codec clientChannel client)
        `concurrently`
      (fst <$> runPeer nullTracer
                      -- (("server",) `contramap` Tracer Debug.traceShowM)
                       codec serverChannel client')
    pure $
      case (clientRes', serverRes') of
        -- both succeeded, we just check that the application (which is
        -- a boolean value) is the one that was put inside 'Version'
        (Right (HandshakeNegotiationResult Bool
c vNumber
_ vData
_), Right (HandshakeNegotiationResult Bool
s vNumber
_ vData
_)) ->
          String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
label String
"both-succeed" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
               Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
c Maybe Bool -> Maybe Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe Bool
clientRes
          Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
s Maybe Bool -> Maybe Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe Bool
serverRes

        -- both queried versions
        (Right (HandshakeQueryResult Map vNumber (Either Text vData)
_), Right (HandshakeQueryResult Map vNumber (Either Text vData)
_)) ->
          String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
label String
"both-query" Bool
True

        -- both failed
        (Left{}, Left{})   -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
label String
"both-failed" Bool
True

        -- it should not happen that one protocol succeeds and the other end
        -- fails
        (Either
   (HandshakeProtocolError vNumber)
   (HandshakeResult Bool vNumber vData),
 Either
   (HandshakeProtocolError vNumber)
   (HandshakeResult Bool vNumber vData))
_                  -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False

-- | Run 'prop_channel_simultaneous_open' in the simulation monad.
--
prop_channel_simultaneous_open_ST :: ArbitraryVersions -> Property
prop_channel_simultaneous_open_ST :: ArbitraryVersions -> Property
prop_channel_simultaneous_open_ST (ArbitraryVersions Versions VersionNumber VersionData Bool
clientVersions Versions VersionNumber VersionData Bool
serverVersions) =
  (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$ IOSim
  s (Channel (IOSim s) ByteString, Channel (IOSim s) ByteString)
-> Codec
     (Handshake VersionNumber Term)
     DeserialiseFailure
     (IOSim s)
     ByteString
-> VersionDataCodec Term VersionNumber VersionData
-> Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool
-> IOSim s Property
forall (m :: * -> *) vData vNumber.
(MonadAsync m, MonadCatch m, Acceptable vData, Ord vNumber) =>
m (Channel m ByteString, Channel m ByteString)
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
-> VersionDataCodec Term vNumber vData
-> Versions vNumber vData Bool
-> Versions vNumber vData Bool
-> m Property
prop_channel_simultaneous_open
                    IOSim
  s (Channel (IOSim s) ByteString, Channel (IOSim s) ByteString)
forall (m :: * -> *) a. MonadSTM m => m (Channel m a, Channel m a)
createConnectedChannels
                    Codec
  (Handshake VersionNumber Term)
  DeserialiseFailure
  (IOSim s)
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (Handshake VersionNumber Term) DeserialiseFailure m ByteString
versionNumberHandshakeCodec
                    ((VersionNumber -> CodecCBORTerm Text VersionData)
-> VersionDataCodec Term VersionNumber VersionData
forall vNumber vData.
(vNumber -> CodecCBORTerm Text vData)
-> VersionDataCodec Term vNumber vData
cborTermVersionDataCodec VersionNumber -> CodecCBORTerm Text VersionData
dataCodecCBORTerm)
                    Versions VersionNumber VersionData Bool
clientVersions
                    Versions VersionNumber VersionData Bool
serverVersions

-- | Run 'prop_channel_simultaneous_open' in the IO monad.
--
prop_channel_simultaneous_open_IO :: ArbitraryVersions -> Property
prop_channel_simultaneous_open_IO :: ArbitraryVersions -> Property
prop_channel_simultaneous_open_IO (ArbitraryVersions Versions VersionNumber VersionData Bool
clientVersions Versions VersionNumber VersionData Bool
serverVersions) =
  IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ IO (Channel IO ByteString, Channel IO ByteString)
-> Codec
     (Handshake VersionNumber Term) DeserialiseFailure IO ByteString
-> VersionDataCodec Term VersionNumber VersionData
-> Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool
-> IO Property
forall (m :: * -> *) vData vNumber.
(MonadAsync m, MonadCatch m, Acceptable vData, Ord vNumber) =>
m (Channel m ByteString, Channel m ByteString)
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
-> VersionDataCodec Term vNumber vData
-> Versions vNumber vData Bool
-> Versions vNumber vData Bool
-> m Property
prop_channel_simultaneous_open
                 IO (Channel IO ByteString, Channel IO ByteString)
forall (m :: * -> *) a. MonadSTM m => m (Channel m a, Channel m a)
createConnectedChannels
                 Codec
  (Handshake VersionNumber Term) DeserialiseFailure IO ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (Handshake VersionNumber Term) DeserialiseFailure m ByteString
versionNumberHandshakeCodec
                 ((VersionNumber -> CodecCBORTerm Text VersionData)
-> VersionDataCodec Term VersionNumber VersionData
forall vNumber vData.
(vNumber -> CodecCBORTerm Text vData)
-> VersionDataCodec Term vNumber vData
cborTermVersionDataCodec VersionNumber -> CodecCBORTerm Text VersionData
dataCodecCBORTerm)
                 Versions VersionNumber VersionData Bool
clientVersions
                 Versions VersionNumber VersionData Bool
serverVersions


prop_channel_simultaneous_open_sim
    :: forall vNumber vData m.
       ( Alternative (STM m)
       , MonadAsync       m
       , MonadDelay       m
       , MonadLabelledSTM m
       , MonadMask        m
       , MonadThrow  (STM m)
       , MonadTime        m
       , MonadTimer       m
       , Acceptable vData
       , Ord vNumber
       )
    => Codec (Handshake vNumber CBOR.Term)
              CBOR.DeserialiseFailure m ByteString
    -> VersionDataCodec CBOR.Term vNumber vData
    -> Versions vNumber vData Bool
    -> Versions vNumber vData Bool
    -> m Property
prop_channel_simultaneous_open_sim :: forall vNumber vData (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m,
 MonadLabelledSTM m, MonadMask m, MonadThrow (STM m), MonadTime m,
 MonadTimer m, Acceptable vData, Ord vNumber) =>
Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
-> VersionDataCodec Term vNumber vData
-> Versions vNumber vData Bool
-> Versions vNumber vData Bool
-> m Property
prop_channel_simultaneous_open_sim Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
codec VersionDataCodec Term vNumber vData
versionDataCodec
                                   Versions vNumber vData Bool
clientVersions Versions vNumber vData Bool
serverVersions =
    let attenuation :: BearerInfo
attenuation = BearerInfo
noAttenuation { biConnectionDelay = 1 } in
    Tracer
  m (WithAddr (TestAddress Int) (SnocketTrace m (TestAddress Int)))
-> BearerInfo
-> Map (NormalisedId (TestAddress Int)) (Script BearerInfo)
-> (Snocket m (FD m (TestAddress Int)) (TestAddress Int)
    -> m (ObservableNetworkState (TestAddress Int)) -> m Property)
-> m Property
forall (m :: * -> *) peerAddr a.
(Alternative (STM m), MonadDelay m, MonadLabelledSTM m,
 MonadMask m, MonadTimer m, MonadThrow (STM m),
 GlobalAddressScheme peerAddr, Ord peerAddr, Typeable peerAddr,
 Show peerAddr) =>
Tracer
  m
  (WithAddr
     (TestAddress peerAddr) (SnocketTrace m (TestAddress peerAddr)))
-> BearerInfo
-> Map (NormalisedId (TestAddress peerAddr)) (Script BearerInfo)
-> (Snocket m (FD m (TestAddress peerAddr)) (TestAddress peerAddr)
    -> m (ObservableNetworkState (TestAddress peerAddr)) -> m a)
-> m a
withSnocket Tracer
  m (WithAddr (TestAddress Int) (SnocketTrace m (TestAddress Int)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                BearerInfo
attenuation
                Map (NormalisedId (TestAddress Int)) (Script BearerInfo)
forall k a. Map k a
Map.empty
              ((Snocket m (FD m (TestAddress Int)) (TestAddress Int)
  -> m (ObservableNetworkState (TestAddress Int)) -> m Property)
 -> m Property)
-> (Snocket m (FD m (TestAddress Int)) (TestAddress Int)
    -> m (ObservableNetworkState (TestAddress Int)) -> m Property)
-> m Property
forall a b. (a -> b) -> a -> b
$ \Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn m (ObservableNetworkState (TestAddress Int))
_ -> do
      let addr, addr' :: TestAddress Int
          addr :: TestAddress Int
addr  = Int -> TestAddress Int
forall addr. addr -> TestAddress addr
Snocket.TestAddress Int
1
          addr' :: TestAddress Int
addr' = Int -> TestAddress Int
forall addr. addr -> TestAddress addr
Snocket.TestAddress Int
2
      -- listening snockets
      m (FD m (TestAddress Int))
-> (FD m (TestAddress Int) -> m ())
-> (FD m (TestAddress Int) -> m Property)
-> m Property
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> AddressFamily (TestAddress Int) -> m (FD m (TestAddress Int))
forall (m :: * -> *) fd addr.
Snocket m fd addr -> AddressFamily addr -> m fd
Snocket.open  Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn AddressFamily (TestAddress Int)
forall addr1. AddressFamily (TestAddress addr1)
Snocket.TestFamily)
              (Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> FD m (TestAddress Int) -> m ()
forall (m :: * -> *) fd addr. Snocket m fd addr -> fd -> m ()
Snocket.close Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn) ((FD m (TestAddress Int) -> m Property) -> m Property)
-> (FD m (TestAddress Int) -> m Property) -> m Property
forall a b. (a -> b) -> a -> b
$ \FD m (TestAddress Int)
fdLst ->
        m (FD m (TestAddress Int))
-> (FD m (TestAddress Int) -> m ())
-> (FD m (TestAddress Int) -> m Property)
-> m Property
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> AddressFamily (TestAddress Int) -> m (FD m (TestAddress Int))
forall (m :: * -> *) fd addr.
Snocket m fd addr -> AddressFamily addr -> m fd
Snocket.open  Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn AddressFamily (TestAddress Int)
forall addr1. AddressFamily (TestAddress addr1)
Snocket.TestFamily)
                (Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> FD m (TestAddress Int) -> m ()
forall (m :: * -> *) fd addr. Snocket m fd addr -> fd -> m ()
Snocket.close Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn) ((FD m (TestAddress Int) -> m Property) -> m Property)
-> (FD m (TestAddress Int) -> m Property) -> m Property
forall a b. (a -> b) -> a -> b
$ \FD m (TestAddress Int)
fdLst' -> do
          Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> FD m (TestAddress Int) -> TestAddress Int -> m ()
forall (m :: * -> *) fd addr.
Snocket m fd addr -> fd -> addr -> m ()
Snocket.bind Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn FD m (TestAddress Int)
fdLst  TestAddress Int
addr
          Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> FD m (TestAddress Int) -> TestAddress Int -> m ()
forall (m :: * -> *) fd addr.
Snocket m fd addr -> fd -> addr -> m ()
Snocket.bind Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn FD m (TestAddress Int)
fdLst' TestAddress Int
addr'
          Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> FD m (TestAddress Int) -> m ()
forall (m :: * -> *) fd addr. Snocket m fd addr -> fd -> m ()
Snocket.listen Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn FD m (TestAddress Int)
fdLst
          Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> FD m (TestAddress Int) -> m ()
forall (m :: * -> *) fd addr. Snocket m fd addr -> fd -> m ()
Snocket.listen Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn FD m (TestAddress Int)
fdLst'
          -- connection snockets
          m (FD m (TestAddress Int), FD m (TestAddress Int))
-> ((FD m (TestAddress Int), FD m (TestAddress Int)) -> m ())
-> ((FD m (TestAddress Int), FD m (TestAddress Int)) -> m Property)
-> m Property
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket ((,) (FD m (TestAddress Int)
 -> FD m (TestAddress Int)
 -> (FD m (TestAddress Int), FD m (TestAddress Int)))
-> m (FD m (TestAddress Int))
-> m (FD m (TestAddress Int)
      -> (FD m (TestAddress Int), FD m (TestAddress Int)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> AddressFamily (TestAddress Int) -> m (FD m (TestAddress Int))
forall (m :: * -> *) fd addr.
Snocket m fd addr -> AddressFamily addr -> m fd
Snocket.open Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn AddressFamily (TestAddress Int)
forall addr1. AddressFamily (TestAddress addr1)
Snocket.TestFamily
                       m (FD m (TestAddress Int)
   -> (FD m (TestAddress Int), FD m (TestAddress Int)))
-> m (FD m (TestAddress Int))
-> m (FD m (TestAddress Int), FD m (TestAddress Int))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> AddressFamily (TestAddress Int) -> m (FD m (TestAddress Int))
forall (m :: * -> *) fd addr.
Snocket m fd addr -> AddressFamily addr -> m fd
Snocket.open Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn AddressFamily (TestAddress Int)
forall addr1. AddressFamily (TestAddress addr1)
Snocket.TestFamily
                  )
                  (\(FD m (TestAddress Int)
fdConn, FD m (TestAddress Int)
fdConn') ->
                      -- we need concurrently close both sockets: they need to
                      -- communicate between each other while they close.
                      Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> FD m (TestAddress Int) -> m ()
forall (m :: * -> *) fd addr. Snocket m fd addr -> fd -> m ()
Snocket.close Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn FD m (TestAddress Int)
fdConn
                      m () -> m () -> m ()
forall a b. m a -> m b -> m ()
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m ()
`concurrently_`
                      Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> FD m (TestAddress Int) -> m ()
forall (m :: * -> *) fd addr. Snocket m fd addr -> fd -> m ()
Snocket.close Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn FD m (TestAddress Int)
fdConn'
                  ) (((FD m (TestAddress Int), FD m (TestAddress Int)) -> m Property)
 -> m Property)
-> ((FD m (TestAddress Int), FD m (TestAddress Int)) -> m Property)
-> m Property
forall a b. (a -> b) -> a -> b
$ \(FD m (TestAddress Int)
fdConn, FD m (TestAddress Int)
fdConn') -> do
            Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> FD m (TestAddress Int) -> TestAddress Int -> m ()
forall (m :: * -> *) fd addr.
Snocket m fd addr -> fd -> addr -> m ()
Snocket.bind Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn FD m (TestAddress Int)
fdConn  TestAddress Int
addr
            Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> FD m (TestAddress Int) -> TestAddress Int -> m ()
forall (m :: * -> *) fd addr.
Snocket m fd addr -> fd -> addr -> m ()
Snocket.bind Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn FD m (TestAddress Int)
fdConn' TestAddress Int
addr'
            m () -> m () -> m ()
forall a b. m a -> m b -> m ()
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m ()
concurrently_
              (Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> FD m (TestAddress Int) -> TestAddress Int -> m ()
forall (m :: * -> *) fd addr.
Snocket m fd addr -> fd -> addr -> m ()
Snocket.connect Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn FD m (TestAddress Int)
fdConn  TestAddress Int
addr')
              (Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> FD m (TestAddress Int) -> TestAddress Int -> m ()
forall (m :: * -> *) fd addr.
Snocket m fd addr -> fd -> addr -> m ()
Snocket.connect Snocket m (FD m (TestAddress Int)) (TestAddress Int)
sn FD m (TestAddress Int)
fdConn' TestAddress Int
addr)
            bearer  <- MakeBearer m (FD m (TestAddress Int))
-> MakeBearerCb m (FD m (TestAddress Int))
forall (m :: * -> *) fd. MakeBearer m fd -> MakeBearerCb m fd
Mx.getBearer MakeBearer m (FD m (TestAddress Int))
forall addr (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m, MonadThrow m, Show addr) =>
MakeBearer m (FD m (TestAddress addr))
makeFDBearer
                        DiffTime
1
                        FD m (TestAddress Int)
fdConn
                        Maybe (ReadBuffer m)
forall a. Maybe a
Nothing
            bearer' <- Mx.getBearer makeFDBearer
                        1
                        fdConn'
                        Nothing
            let chann  = Tracer m BearerTrace
-> Bearer m -> MiniProtocolNum -> MiniProtocolDir -> ByteChannel m
forall (m :: * -> *).
Functor m =>
Tracer m BearerTrace
-> Bearer m -> MiniProtocolNum -> MiniProtocolDir -> ByteChannel m
bearerAsChannel Tracer m BearerTrace
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Bearer m
bearer  (Word16 -> MiniProtocolNum
MiniProtocolNum Word16
0) MiniProtocolDir
InitiatorDir
                chann' = Tracer m BearerTrace
-> Bearer m -> MiniProtocolNum -> MiniProtocolDir -> ByteChannel m
forall (m :: * -> *).
Functor m =>
Tracer m BearerTrace
-> Bearer m -> MiniProtocolNum -> MiniProtocolDir -> ByteChannel m
bearerAsChannel Tracer m BearerTrace
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Bearer m
bearer' (Word16 -> MiniProtocolNum
MiniProtocolNum Word16
0) MiniProtocolDir
InitiatorDir
            res <- prop_channel_simultaneous_open
              (pure (chann, chann'))
              codec
              versionDataCodec
              clientVersions
              serverVersions
            return res


prop_channel_simultaneous_open_SimNet :: ArbitraryVersions
                                                        -> Property
prop_channel_simultaneous_open_SimNet :: ArbitraryVersions -> Property
prop_channel_simultaneous_open_SimNet
  (ArbitraryVersions Versions VersionNumber VersionData Bool
clientVersions Versions VersionNumber VersionData Bool
serverVersions) =
    (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$ Codec
  (Handshake VersionNumber Term)
  DeserialiseFailure
  (IOSim s)
  ByteString
-> VersionDataCodec Term VersionNumber VersionData
-> Versions VersionNumber VersionData Bool
-> Versions VersionNumber VersionData Bool
-> IOSim s Property
forall vNumber vData (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m,
 MonadLabelledSTM m, MonadMask m, MonadThrow (STM m), MonadTime m,
 MonadTimer m, Acceptable vData, Ord vNumber) =>
Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
-> VersionDataCodec Term vNumber vData
-> Versions vNumber vData Bool
-> Versions vNumber vData Bool
-> m Property
prop_channel_simultaneous_open_sim
      Codec
  (Handshake VersionNumber Term)
  DeserialiseFailure
  (IOSim s)
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (Handshake VersionNumber Term) DeserialiseFailure m ByteString
versionNumberHandshakeCodec
      ((VersionNumber -> CodecCBORTerm Text VersionData)
-> VersionDataCodec Term VersionNumber VersionData
forall vNumber vData.
(vNumber -> CodecCBORTerm Text vData)
-> VersionDataCodec Term vNumber vData
cborTermVersionDataCodec VersionNumber -> CodecCBORTerm Text VersionData
dataCodecCBORTerm)
      Versions VersionNumber VersionData Bool
clientVersions
      Versions VersionNumber VersionData Bool
serverVersions


--
-- Codec tests
--

instance Eq (AnyMessage (Handshake VersionNumber CBOR.Term)) where
  AnyMessage (MsgProposeVersions Map vNumber1 vParams1
vs) == :: AnyMessage (Handshake VersionNumber Term)
-> AnyMessage (Handshake VersionNumber Term) -> Bool
== AnyMessage (MsgProposeVersions Map vNumber1 vParams1
vs')
    = Map vNumber1 vParams1
vs Map vNumber1 vParams1 -> Map vNumber1 vParams1 -> Bool
forall a. Eq a => a -> a -> Bool
== Map vNumber1 vParams1
Map vNumber1 vParams1
vs'

  AnyMessage (MsgReplyVersions Map vNumber1 vParams1
vs) == AnyMessage (MsgReplyVersions Map vNumber1 vParams1
vs')
    = Map vNumber1 vParams1
vs Map vNumber1 vParams1 -> Map vNumber1 vParams1 -> Bool
forall a. Eq a => a -> a -> Bool
== Map vNumber1 vParams1
Map vNumber1 vParams1
vs'

  AnyMessage (MsgAcceptVersion vNumber1
vNumber vParams1
vParams) == AnyMessage (MsgAcceptVersion vNumber1
vNumber' vParams1
vParams')
    = vNumber1
vNumber vNumber1 -> vNumber1 -> Bool
forall a. Eq a => a -> a -> Bool
== vNumber1
vNumber1
vNumber' Bool -> Bool -> Bool
&& vParams1
vParams vParams1 -> vParams1 -> Bool
forall a. Eq a => a -> a -> Bool
== vParams1
vParams1
vParams'

  AnyMessage (MsgRefuse RefuseReason vNumber1
vReason) == AnyMessage (MsgRefuse RefuseReason vNumber1
vReason')
    = RefuseReason vNumber1
vReason RefuseReason vNumber1 -> RefuseReason vNumber1 -> Bool
forall a. Eq a => a -> a -> Bool
== RefuseReason vNumber1
RefuseReason vNumber1
vReason'

  AnyMessage (Handshake VersionNumber Term)
_ == AnyMessage (Handshake VersionNumber Term)
_ = Bool
False

instance Arbitrary (AnyMessage (Handshake VersionNumber CBOR.Term)) where
  arbitrary :: Gen (AnyMessage (Handshake VersionNumber Term))
arbitrary = [Gen (AnyMessage (Handshake VersionNumber Term))]
-> Gen (AnyMessage (Handshake VersionNumber Term))
forall a. HasCallStack => [Gen a] -> Gen a
oneof
    [     Message (Handshake VersionNumber Term) 'StPropose 'StConfirm
-> AnyMessage (Handshake VersionNumber Term)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage
        (Message (Handshake VersionNumber Term) 'StPropose 'StConfirm
 -> AnyMessage (Handshake VersionNumber Term))
-> (Versions VersionNumber VersionData Bool
    -> Message (Handshake VersionNumber Term) 'StPropose 'StConfirm)
-> Versions VersionNumber VersionData Bool
-> AnyMessage (Handshake VersionNumber Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map VersionNumber Term
-> Message (Handshake VersionNumber Term) 'StPropose 'StConfirm
forall vNumber1 vParams1.
Map vNumber1 vParams1
-> Message (Handshake vNumber1 vParams1) 'StPropose 'StConfirm
MsgProposeVersions
        (Map VersionNumber Term
 -> Message (Handshake VersionNumber Term) 'StPropose 'StConfirm)
-> (Versions VersionNumber VersionData Bool
    -> Map VersionNumber Term)
-> Versions VersionNumber VersionData Bool
-> Message (Handshake VersionNumber Term) 'StPropose 'StConfirm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VersionNumber -> Version VersionData Bool -> Term)
-> Map VersionNumber (Version VersionData Bool)
-> Map VersionNumber Term
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\VersionNumber
v -> CodecCBORTerm Text VersionData -> VersionData -> Term
forall fail a. CodecCBORTerm fail a -> a -> Term
encodeTerm (VersionNumber -> CodecCBORTerm Text VersionData
dataCodecCBORTerm VersionNumber
v) (VersionData -> Term)
-> (Version VersionData Bool -> VersionData)
-> Version VersionData Bool
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version VersionData Bool -> VersionData
forall vData r. Version vData r -> vData
versionData)
        (Map VersionNumber (Version VersionData Bool)
 -> Map VersionNumber Term)
-> (Versions VersionNumber VersionData Bool
    -> Map VersionNumber (Version VersionData Bool))
-> Versions VersionNumber VersionData Bool
-> Map VersionNumber Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Versions VersionNumber VersionData Bool
-> Map VersionNumber (Version VersionData Bool)
forall vNum vData r.
Versions vNum vData r -> Map vNum (Version vData r)
getVersions
      (Versions VersionNumber VersionData Bool
 -> AnyMessage (Handshake VersionNumber Term))
-> Gen (Versions VersionNumber VersionData Bool)
-> Gen (AnyMessage (Handshake VersionNumber Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Versions VersionNumber VersionData Bool)
genVersions

    ,     Message (Handshake VersionNumber Term) 'StConfirm 'StDone
-> AnyMessage (Handshake VersionNumber Term)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage
        (Message (Handshake VersionNumber Term) 'StConfirm 'StDone
 -> AnyMessage (Handshake VersionNumber Term))
-> (Versions VersionNumber VersionData Bool
    -> Message (Handshake VersionNumber Term) 'StConfirm 'StDone)
-> Versions VersionNumber VersionData Bool
-> AnyMessage (Handshake VersionNumber Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map VersionNumber Term
-> Message (Handshake VersionNumber Term) 'StConfirm 'StDone
forall vNumber1 vParams1.
Map vNumber1 vParams1
-> Message (Handshake vNumber1 vParams1) 'StConfirm 'StDone
MsgReplyVersions
        (Map VersionNumber Term
 -> Message (Handshake VersionNumber Term) 'StConfirm 'StDone)
-> (Versions VersionNumber VersionData Bool
    -> Map VersionNumber Term)
-> Versions VersionNumber VersionData Bool
-> Message (Handshake VersionNumber Term) 'StConfirm 'StDone
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VersionNumber -> Version VersionData Bool -> Term)
-> Map VersionNumber (Version VersionData Bool)
-> Map VersionNumber Term
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\VersionNumber
v -> CodecCBORTerm Text VersionData -> VersionData -> Term
forall fail a. CodecCBORTerm fail a -> a -> Term
encodeTerm (VersionNumber -> CodecCBORTerm Text VersionData
dataCodecCBORTerm VersionNumber
v) (VersionData -> Term)
-> (Version VersionData Bool -> VersionData)
-> Version VersionData Bool
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version VersionData Bool -> VersionData
forall vData r. Version vData r -> vData
versionData)
        (Map VersionNumber (Version VersionData Bool)
 -> Map VersionNumber Term)
-> (Versions VersionNumber VersionData Bool
    -> Map VersionNumber (Version VersionData Bool))
-> Versions VersionNumber VersionData Bool
-> Map VersionNumber Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Versions VersionNumber VersionData Bool
-> Map VersionNumber (Version VersionData Bool)
forall vNum vData r.
Versions vNum vData r -> Map vNum (Version vData r)
getVersions
      (Versions VersionNumber VersionData Bool
 -> AnyMessage (Handshake VersionNumber Term))
-> Gen (Versions VersionNumber VersionData Bool)
-> Gen (AnyMessage (Handshake VersionNumber Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Versions VersionNumber VersionData Bool)
genVersions

    ,     Message (Handshake VersionNumber Term) 'StConfirm 'StDone
-> AnyMessage (Handshake VersionNumber Term)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage
        (Message (Handshake VersionNumber Term) 'StConfirm 'StDone
 -> AnyMessage (Handshake VersionNumber Term))
-> ((VersionNumber, Term)
    -> Message (Handshake VersionNumber Term) 'StConfirm 'StDone)
-> (VersionNumber, Term)
-> AnyMessage (Handshake VersionNumber Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VersionNumber
 -> Term
 -> Message (Handshake VersionNumber Term) 'StConfirm 'StDone)
-> (VersionNumber, Term)
-> Message (Handshake VersionNumber Term) 'StConfirm 'StDone
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry VersionNumber
-> Term
-> Message (Handshake VersionNumber Term) 'StConfirm 'StDone
forall vNumber1 vParams1.
vNumber1
-> vParams1
-> Message (Handshake vNumber1 vParams1) 'StConfirm 'StDone
MsgAcceptVersion
      ((VersionNumber, Term)
 -> AnyMessage (Handshake VersionNumber Term))
-> Gen (VersionNumber, Term)
-> Gen (AnyMessage (Handshake VersionNumber Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (VersionNumber, Term)
genValidVersion'

    ,     Message (Handshake VersionNumber Term) 'StConfirm 'StDone
-> AnyMessage (Handshake VersionNumber Term)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage
        (Message (Handshake VersionNumber Term) 'StConfirm 'StDone
 -> AnyMessage (Handshake VersionNumber Term))
-> (ArbitraryRefuseReason
    -> Message (Handshake VersionNumber Term) 'StConfirm 'StDone)
-> ArbitraryRefuseReason
-> AnyMessage (Handshake VersionNumber Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RefuseReason VersionNumber
-> Message (Handshake VersionNumber Term) 'StConfirm 'StDone
forall {k1} vNumber1 (vParams :: k1).
RefuseReason vNumber1
-> Message (Handshake vNumber1 vParams) 'StConfirm 'StDone
MsgRefuse
        (RefuseReason VersionNumber
 -> Message (Handshake VersionNumber Term) 'StConfirm 'StDone)
-> (ArbitraryRefuseReason -> RefuseReason VersionNumber)
-> ArbitraryRefuseReason
-> Message (Handshake VersionNumber Term) 'StConfirm 'StDone
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArbitraryRefuseReason -> RefuseReason VersionNumber
runArbitraryRefuseReason
      (ArbitraryRefuseReason
 -> AnyMessage (Handshake VersionNumber Term))
-> Gen ArbitraryRefuseReason
-> Gen (AnyMessage (Handshake VersionNumber Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ArbitraryRefuseReason
forall a. Arbitrary a => Gen a
arbitrary
    ]
    where
      genValidVersion' :: Gen (VersionNumber, CBOR.Term)
      genValidVersion' :: Gen (VersionNumber, Term)
genValidVersion' = do
        vn <- Gen VersionNumber
forall a. Arbitrary a => Gen a
arbitrary
        Version _ vData <- genValidVersion vn
        pure (vn, encodeTerm (dataCodecCBORTerm vn) vData)


newtype ArbitraryRefuseReason = ArbitraryRefuseReason {
    ArbitraryRefuseReason -> RefuseReason VersionNumber
runArbitraryRefuseReason :: RefuseReason VersionNumber
  }
  deriving (ArbitraryRefuseReason -> ArbitraryRefuseReason -> Bool
(ArbitraryRefuseReason -> ArbitraryRefuseReason -> Bool)
-> (ArbitraryRefuseReason -> ArbitraryRefuseReason -> Bool)
-> Eq ArbitraryRefuseReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArbitraryRefuseReason -> ArbitraryRefuseReason -> Bool
== :: ArbitraryRefuseReason -> ArbitraryRefuseReason -> Bool
$c/= :: ArbitraryRefuseReason -> ArbitraryRefuseReason -> Bool
/= :: ArbitraryRefuseReason -> ArbitraryRefuseReason -> Bool
Eq, Int -> ArbitraryRefuseReason -> ShowS
[ArbitraryRefuseReason] -> ShowS
ArbitraryRefuseReason -> String
(Int -> ArbitraryRefuseReason -> ShowS)
-> (ArbitraryRefuseReason -> String)
-> ([ArbitraryRefuseReason] -> ShowS)
-> Show ArbitraryRefuseReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArbitraryRefuseReason -> ShowS
showsPrec :: Int -> ArbitraryRefuseReason -> ShowS
$cshow :: ArbitraryRefuseReason -> String
show :: ArbitraryRefuseReason -> String
$cshowList :: [ArbitraryRefuseReason] -> ShowS
showList :: [ArbitraryRefuseReason] -> ShowS
Show)


instance Arbitrary ArbitraryRefuseReason where
    arbitrary :: Gen ArbitraryRefuseReason
arbitrary = RefuseReason VersionNumber -> ArbitraryRefuseReason
ArbitraryRefuseReason (RefuseReason VersionNumber -> ArbitraryRefuseReason)
-> Gen (RefuseReason VersionNumber) -> Gen ArbitraryRefuseReason
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Gen (RefuseReason VersionNumber)]
-> Gen (RefuseReason VersionNumber)
forall a. HasCallStack => [Gen a] -> Gen a
oneof
      [ [VersionNumber] -> [Int] -> RefuseReason VersionNumber
forall vNumber. [vNumber] -> [Int] -> RefuseReason vNumber
VersionMismatch
          ([VersionNumber] -> [Int] -> RefuseReason VersionNumber)
-> Gen [VersionNumber] -> Gen ([Int] -> RefuseReason VersionNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [VersionNumber]
forall a. Arbitrary a => Gen a
arbitrary
          -- this argument is not supposed to be sent, only received:
          Gen ([Int] -> RefuseReason VersionNumber)
-> Gen [Int] -> Gen (RefuseReason VersionNumber)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Int] -> Gen [Int]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      , VersionNumber -> Text -> RefuseReason VersionNumber
forall vNumber. vNumber -> Text -> RefuseReason vNumber
HandshakeDecodeError (VersionNumber -> Text -> RefuseReason VersionNumber)
-> Gen VersionNumber -> Gen (Text -> RefuseReason VersionNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen VersionNumber
forall a. Arbitrary a => Gen a
arbitrary Gen (Text -> RefuseReason VersionNumber)
-> Gen Text -> Gen (RefuseReason VersionNumber)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Text
arbitraryText
      , VersionNumber -> Text -> RefuseReason VersionNumber
forall vNumber. vNumber -> Text -> RefuseReason vNumber
Refused (VersionNumber -> Text -> RefuseReason VersionNumber)
-> Gen VersionNumber -> Gen (Text -> RefuseReason VersionNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen VersionNumber
forall a. Arbitrary a => Gen a
arbitrary Gen (Text -> RefuseReason VersionNumber)
-> Gen Text -> Gen (RefuseReason VersionNumber)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Text
arbitraryText
      ]
      where
        arbitraryText :: Gen Text
arbitraryText = String -> Text
T.pack (String -> Text) -> Gen String -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String
forall a. Arbitrary a => Gen a
arbitrary


--
--  TODO: these tests should be moved to 'ouroboros-network-framework'
--

-- TODO: we are not testing the cases where we decode version numbers that we do
-- not know about.
prop_codec_RefuseReason
  :: ArbitraryRefuseReason
  -> Bool
prop_codec_RefuseReason :: ArbitraryRefuseReason -> Bool
prop_codec_RefuseReason (ArbitraryRefuseReason RefuseReason VersionNumber
vReason) =
  case (forall s. Decoder s (RefuseReason VersionNumber))
-> ByteString
-> Either
     DeserialiseFailure (ByteString, RefuseReason VersionNumber)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes
        (CodecCBORTerm (String, Maybe Int) VersionNumber
-> Decoder s (RefuseReason VersionNumber)
forall failure vNumber s.
Show failure =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Decoder s (RefuseReason vNumber)
decodeRefuseReason CodecCBORTerm (String, Maybe Int) VersionNumber
versionNumberCodec)
        (Encoding -> ByteString
CBOR.toLazyByteString (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ CodecCBORTerm (String, Maybe Int) VersionNumber
-> RefuseReason VersionNumber -> Encoding
forall fail vNumber.
CodecCBORTerm fail vNumber -> RefuseReason vNumber -> Encoding
encodeRefuseReason CodecCBORTerm (String, Maybe Int) VersionNumber
versionNumberCodec RefuseReason VersionNumber
vReason) of
    Left DeserialiseFailure
_                  -> Bool
False
    Right (ByteString
bytes, RefuseReason VersionNumber
vReason') -> ByteString -> Bool
BL.null ByteString
bytes Bool -> Bool -> Bool
&& RefuseReason VersionNumber
vReason' RefuseReason VersionNumber -> RefuseReason VersionNumber -> Bool
forall a. Eq a => a -> a -> Bool
== RefuseReason VersionNumber
vReason

prop_codec_Handshake
  :: AnyMessage (Handshake VersionNumber CBOR.Term)
  -> Property
prop_codec_Handshake :: AnyMessage (Handshake VersionNumber Term) -> Property
prop_codec_Handshake AnyMessage (Handshake VersionNumber Term)
msg =
  (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow (Codec
  (Handshake VersionNumber Term)
  DeserialiseFailure
  (IOSim s)
  ByteString
-> AnyMessage (Handshake VersionNumber Term) -> IOSim s Property
forall ps failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage ps), Show (AnyMessage ps),
 Show failure) =>
Codec ps failure m bytes -> AnyMessage ps -> m Property
prop_codecM (CodecCBORTerm (String, Maybe Int) VersionNumber
-> Codec
     (Handshake VersionNumber Term)
     DeserialiseFailure
     (IOSim s)
     ByteString
forall vNumber (m :: * -> *) failure.
(MonadST m, Ord vNumber, Show failure) =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
codecHandshake CodecCBORTerm (String, Maybe Int) VersionNumber
versionNumberCodec) AnyMessage (Handshake VersionNumber Term)
msg)

prop_codec_splits2_Handshake
  :: AnyMessage (Handshake VersionNumber CBOR.Term)
  -> Property
prop_codec_splits2_Handshake :: AnyMessage (Handshake VersionNumber Term) -> Property
prop_codec_splits2_Handshake AnyMessage (Handshake VersionNumber Term)
msg =
  (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((ByteString -> [[ByteString]])
-> Codec
     (Handshake VersionNumber Term)
     DeserialiseFailure
     (IOSim s)
     ByteString
-> AnyMessage (Handshake VersionNumber Term)
-> IOSim s Property
forall ps failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage ps), Show (AnyMessage ps), Show failure,
 Monoid bytes) =>
(bytes -> [[bytes]])
-> Codec ps failure m bytes -> AnyMessage ps -> m Property
prop_codec_splitsM ByteString -> [[ByteString]]
splits2 (CodecCBORTerm (String, Maybe Int) VersionNumber
-> Codec
     (Handshake VersionNumber Term)
     DeserialiseFailure
     (IOSim s)
     ByteString
forall vNumber (m :: * -> *) failure.
(MonadST m, Ord vNumber, Show failure) =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
codecHandshake CodecCBORTerm (String, Maybe Int) VersionNumber
versionNumberCodec) AnyMessage (Handshake VersionNumber Term)
msg)

prop_codec_splits3_Handshake
  :: AnyMessage (Handshake VersionNumber CBOR.Term)
  -> Property
prop_codec_splits3_Handshake :: AnyMessage (Handshake VersionNumber Term) -> Property
prop_codec_splits3_Handshake AnyMessage (Handshake VersionNumber Term)
msg =
  (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((ByteString -> [[ByteString]])
-> Codec
     (Handshake VersionNumber Term)
     DeserialiseFailure
     (IOSim s)
     ByteString
-> AnyMessage (Handshake VersionNumber Term)
-> IOSim s Property
forall ps failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage ps), Show (AnyMessage ps), Show failure,
 Monoid bytes) =>
(bytes -> [[bytes]])
-> Codec ps failure m bytes -> AnyMessage ps -> m Property
prop_codec_splitsM ByteString -> [[ByteString]]
splits3 (CodecCBORTerm (String, Maybe Int) VersionNumber
-> Codec
     (Handshake VersionNumber Term)
     DeserialiseFailure
     (IOSim s)
     ByteString
forall vNumber (m :: * -> *) failure.
(MonadST m, Ord vNumber, Show failure) =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
codecHandshake CodecCBORTerm (String, Maybe Int) VersionNumber
versionNumberCodec) AnyMessage (Handshake VersionNumber Term)
msg)

prop_codec_cbor
  :: AnyMessage (Handshake VersionNumber CBOR.Term)
  -> Property
prop_codec_cbor :: AnyMessage (Handshake VersionNumber Term) -> Property
prop_codec_cbor AnyMessage (Handshake VersionNumber Term)
msg =
  (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow (CodecF
  (Handshake VersionNumber Term)
  DeserialiseFailure
  (IOSim s)
  SomeMessage
  ByteString
-> AnyMessage (Handshake VersionNumber Term) -> IOSim s Property
forall ps (m :: * -> *) (f :: ps -> *).
Monad m =>
CodecF ps DeserialiseFailure m f ByteString
-> AnyMessage ps -> m Property
prop_codec_cborM (CodecCBORTerm (String, Maybe Int) VersionNumber
-> CodecF
     (Handshake VersionNumber Term)
     DeserialiseFailure
     (IOSim s)
     SomeMessage
     ByteString
forall vNumber (m :: * -> *) failure.
(MonadST m, Ord vNumber, Show failure) =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
codecHandshake CodecCBORTerm (String, Maybe Int) VersionNumber
versionNumberCodec) AnyMessage (Handshake VersionNumber Term)
msg)

-- | Check that the encoder produces a valid CBOR.
--
prop_codec_valid_cbor
  :: AnyMessage (Handshake VersionNumber CBOR.Term)
  -> Property
prop_codec_valid_cbor :: AnyMessage (Handshake VersionNumber Term) -> Property
prop_codec_valid_cbor = Codec
  (Handshake VersionNumber Term) DeserialiseFailure IO ByteString
-> AnyMessage (Handshake VersionNumber Term) -> Property
forall ps (f :: ps -> *).
CodecF ps DeserialiseFailure IO f ByteString
-> AnyMessage ps -> Property
prop_codec_valid_cbor_encoding (CodecCBORTerm (String, Maybe Int) VersionNumber
-> Codec
     (Handshake VersionNumber Term) DeserialiseFailure IO ByteString
forall vNumber (m :: * -> *) failure.
(MonadST m, Ord vNumber, Show failure) =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Codec (Handshake vNumber Term) DeserialiseFailure m ByteString
codecHandshake CodecCBORTerm (String, Maybe Int) VersionNumber
versionNumberCodec)