{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE RankNTypes                 #-}

{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE DeriveGeneric              #-}

module Ouroboros.Network.Protocol.LocalTxSubmission.Test
  ( tests
  , Tx (..)
  , Reject (..)
  ) where

import Data.ByteString.Lazy (ByteString)

import Control.Monad.Class.MonadAsync (MonadAsync)
import Control.Monad.Class.MonadST (MonadST)
import Control.Monad.Class.MonadThrow (MonadCatch)
import Control.Monad.IOSim
import Control.Monad.ST (runST)
import Control.Tracer (nullTracer)

import Codec.Serialise (DeserialiseFailure, Serialise)
import Codec.Serialise qualified as Serialise (decode, encode)

import Network.TypedProtocol.Codec hiding (prop_codec)
import Network.TypedProtocol.Proofs

import Ouroboros.Network.Channel
import Ouroboros.Network.Driver.Simple (runConnectedPeers)
import Ouroboros.Network.Util.ShowProxy

import Ouroboros.Network.Protocol.LocalTxSubmission.Client
import Ouroboros.Network.Protocol.LocalTxSubmission.Codec
import Ouroboros.Network.Protocol.LocalTxSubmission.Direct
import Ouroboros.Network.Protocol.LocalTxSubmission.Examples
import Ouroboros.Network.Protocol.LocalTxSubmission.Server
import Ouroboros.Network.Protocol.LocalTxSubmission.Type

import Test.Data.CDDL (Any (..))
import Test.Ouroboros.Network.Testing.Utils (prop_codec_cborM,
           prop_codec_valid_cbor_encoding, splits2, splits3)

import Control.DeepSeq
import GHC.Generics
import Test.QuickCheck as QC
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
import Text.Show.Functions ()


--
-- Test cases
--

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup TestName
"Ouroboros.Network.Protocol"
    [ TestName -> [TestTree] -> TestTree
testGroup TestName
"LocalTxSubmission"
        [ TestName
-> ((Tx -> SubmitResult Reject) -> [Tx] -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"direct"              (Tx -> SubmitResult Reject) -> [Tx] -> Bool
prop_direct
        , TestName
-> ((Tx -> SubmitResult Reject) -> [Tx] -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connect"             (Tx -> SubmitResult Reject) -> [Tx] -> Bool
prop_connect
        , TestName
-> (AnyMessage (LocalTxSubmission Tx Reject) -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec"               AnyMessage (LocalTxSubmission Tx Reject) -> Bool
prop_codec
        , TestName
-> (AnyMessage (LocalTxSubmission Tx Reject) -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec 2-splits"      AnyMessage (LocalTxSubmission Tx Reject) -> Bool
prop_codec_splits2
        , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec 3-splits"    (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ Int
-> (AnyMessage (LocalTxSubmission Tx Reject) -> Bool) -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
30
                                             AnyMessage (LocalTxSubmission Tx Reject) -> Bool
prop_codec_splits3
        , TestName
-> (AnyMessage (LocalTxSubmission Tx Reject) -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec cbor"          AnyMessage (LocalTxSubmission Tx Reject) -> Bool
prop_codec_cbor
        , TestName
-> (AnyMessage (LocalTxSubmission Tx Reject) -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec valid cbor"    AnyMessage (LocalTxSubmission Tx Reject) -> Property
prop_codec_valid_cbor
        , TestName
-> ((Tx -> SubmitResult Reject) -> [Tx] -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"channel ST"          (Tx -> SubmitResult Reject) -> [Tx] -> Bool
prop_channel_ST
        , TestName
-> ((Tx -> SubmitResult Reject) -> [Tx] -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"channel IO"          (Tx -> SubmitResult Reject) -> [Tx] -> Property
prop_channel_IO
        , TestName
-> ((Tx -> SubmitResult Reject) -> [Tx] -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"pipe IO"             (Tx -> SubmitResult Reject) -> [Tx] -> Property
prop_pipe_IO
        ]
    ]


--
-- Common types & clients and servers used in the tests in this module.
--

newtype Tx = Tx Any
  deriving (Tx -> Tx -> Bool
(Tx -> Tx -> Bool) -> (Tx -> Tx -> Bool) -> Eq Tx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tx -> Tx -> Bool
== :: Tx -> Tx -> Bool
$c/= :: Tx -> Tx -> Bool
/= :: Tx -> Tx -> Bool
Eq, Int -> Tx -> ShowS
[Tx] -> ShowS
Tx -> TestName
(Int -> Tx -> ShowS)
-> (Tx -> TestName) -> ([Tx] -> ShowS) -> Show Tx
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tx -> ShowS
showsPrec :: Int -> Tx -> ShowS
$cshow :: Tx -> TestName
show :: Tx -> TestName
$cshowList :: [Tx] -> ShowS
showList :: [Tx] -> ShowS
Show, Gen Tx
Gen Tx -> (Tx -> [Tx]) -> Arbitrary Tx
Tx -> [Tx]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen Tx
arbitrary :: Gen Tx
$cshrink :: Tx -> [Tx]
shrink :: Tx -> [Tx]
Arbitrary, (forall b. Tx -> Gen b -> Gen b) -> CoArbitrary Tx
forall b. Tx -> Gen b -> Gen b
forall a. (forall b. a -> Gen b -> Gen b) -> CoArbitrary a
$ccoarbitrary :: forall b. Tx -> Gen b -> Gen b
coarbitrary :: forall b. Tx -> Gen b -> Gen b
CoArbitrary, [Tx] -> Encoding
Tx -> Encoding
(Tx -> Encoding)
-> (forall s. Decoder s Tx)
-> ([Tx] -> Encoding)
-> (forall s. Decoder s [Tx])
-> Serialise Tx
forall s. Decoder s [Tx]
forall s. Decoder s Tx
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: Tx -> Encoding
encode :: Tx -> Encoding
$cdecode :: forall s. Decoder s Tx
decode :: forall s. Decoder s Tx
$cencodeList :: [Tx] -> Encoding
encodeList :: [Tx] -> Encoding
$cdecodeList :: forall s. Decoder s [Tx]
decodeList :: forall s. Decoder s [Tx]
Serialise, (forall x. Tx -> Rep Tx x)
-> (forall x. Rep Tx x -> Tx) -> Generic Tx
forall x. Rep Tx x -> Tx
forall x. Tx -> Rep Tx x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Tx -> Rep Tx x
from :: forall x. Tx -> Rep Tx x
$cto :: forall x. Rep Tx x -> Tx
to :: forall x. Rep Tx x -> Tx
Generic, Tx -> ()
(Tx -> ()) -> NFData Tx
forall a. (a -> ()) -> NFData a
$crnf :: Tx -> ()
rnf :: Tx -> ()
NFData)

instance ShowProxy Tx where

newtype Reject = Reject Int
  deriving (Reject -> Reject -> Bool
(Reject -> Reject -> Bool)
-> (Reject -> Reject -> Bool) -> Eq Reject
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Reject -> Reject -> Bool
== :: Reject -> Reject -> Bool
$c/= :: Reject -> Reject -> Bool
/= :: Reject -> Reject -> Bool
Eq, Int -> Reject -> ShowS
[Reject] -> ShowS
Reject -> TestName
(Int -> Reject -> ShowS)
-> (Reject -> TestName) -> ([Reject] -> ShowS) -> Show Reject
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Reject -> ShowS
showsPrec :: Int -> Reject -> ShowS
$cshow :: Reject -> TestName
show :: Reject -> TestName
$cshowList :: [Reject] -> ShowS
showList :: [Reject] -> ShowS
Show, Gen Reject
Gen Reject -> (Reject -> [Reject]) -> Arbitrary Reject
Reject -> [Reject]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen Reject
arbitrary :: Gen Reject
$cshrink :: Reject -> [Reject]
shrink :: Reject -> [Reject]
Arbitrary, [Reject] -> Encoding
Reject -> Encoding
(Reject -> Encoding)
-> (forall s. Decoder s Reject)
-> ([Reject] -> Encoding)
-> (forall s. Decoder s [Reject])
-> Serialise Reject
forall s. Decoder s [Reject]
forall s. Decoder s Reject
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: Reject -> Encoding
encode :: Reject -> Encoding
$cdecode :: forall s. Decoder s Reject
decode :: forall s. Decoder s Reject
$cencodeList :: [Reject] -> Encoding
encodeList :: [Reject] -> Encoding
$cdecodeList :: forall s. Decoder s [Reject]
decodeList :: forall s. Decoder s [Reject]
Serialise, (forall x. Reject -> Rep Reject x)
-> (forall x. Rep Reject x -> Reject) -> Generic Reject
forall x. Rep Reject x -> Reject
forall x. Reject -> Rep Reject x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Reject -> Rep Reject x
from :: forall x. Reject -> Rep Reject x
$cto :: forall x. Rep Reject x -> Reject
to :: forall x. Rep Reject x -> Reject
Generic, Reject -> ()
(Reject -> ()) -> NFData Reject
forall a. (a -> ()) -> NFData a
$crnf :: Reject -> ()
rnf :: Reject -> ()
NFData)

instance ShowProxy Reject where


--
-- Properties going directly, not via Peer.
--

-- | Run a simple tx-submission client and server, directly on the wrappers,
-- without going via the 'Peer'.
--
prop_direct :: (Tx -> SubmitResult Reject) -> [Tx] -> Bool
prop_direct :: (Tx -> SubmitResult Reject) -> [Tx] -> Bool
prop_direct Tx -> SubmitResult Reject
p [Tx]
txs =
    (forall s.
 IOSim s ([(Tx, SubmitResult Reject)], [(Tx, SubmitResult Reject)]))
-> ([(Tx, SubmitResult Reject)], [(Tx, SubmitResult Reject)])
forall a. (forall s. IOSim s a) -> a
runSimOrThrow
      (LocalTxSubmissionClient
  Tx Reject (IOSim s) [(Tx, SubmitResult Reject)]
-> LocalTxSubmissionServer
     Tx Reject (IOSim s) [(Tx, SubmitResult Reject)]
-> IOSim
     s ([(Tx, SubmitResult Reject)], [(Tx, SubmitResult Reject)])
forall tx reject (m :: * -> *) a b.
Monad m =>
LocalTxSubmissionClient tx reject m a
-> LocalTxSubmissionServer tx reject m b -> m (a, b)
direct
        ([Tx]
-> LocalTxSubmissionClient
     Tx Reject (IOSim s) [(Tx, SubmitResult Reject)]
forall tx reject (m :: * -> *).
Applicative m =>
[tx]
-> LocalTxSubmissionClient tx reject m [(tx, SubmitResult reject)]
localTxSubmissionClient [Tx]
txs)
        ((Tx -> SubmitResult Reject)
-> LocalTxSubmissionServer
     Tx Reject (IOSim s) [(Tx, SubmitResult Reject)]
forall tx reject (m :: * -> *).
Applicative m =>
(tx -> SubmitResult reject)
-> LocalTxSubmissionServer tx reject m [(tx, SubmitResult reject)]
localTxSubmissionServer Tx -> SubmitResult Reject
p))
  ([(Tx, SubmitResult Reject)], [(Tx, SubmitResult Reject)])
-> ([(Tx, SubmitResult Reject)], [(Tx, SubmitResult Reject)])
-> Bool
forall a. Eq a => a -> a -> Bool
==
    ([(Tx, SubmitResult Reject)]
txs', [(Tx, SubmitResult Reject)]
txs')
  where
    txs' :: [(Tx, SubmitResult Reject)]
txs' = [ (Tx
tx, Tx -> SubmitResult Reject
p Tx
tx) | Tx
tx <- [Tx]
txs ]


--
-- Properties going via Peer, but without using a channel
--

-- | Run a simple tx-submission client and server, going via the 'Peer'
-- representation, but without going via a channel.
--
-- This test converts the pipelined server peer to a non-pipelined peer
-- before connecting it with the client.
--
prop_connect :: (Tx -> SubmitResult Reject) -> [Tx] -> Bool
prop_connect :: (Tx -> SubmitResult Reject) -> [Tx] -> Bool
prop_connect Tx -> SubmitResult Reject
p [Tx]
txs =
    case (forall s.
 IOSim
   s
   ([(Tx, SubmitResult Reject)], [(Tx, SubmitResult Reject)],
    TerminalStates (LocalTxSubmission Tx Reject)))
-> ([(Tx, SubmitResult Reject)], [(Tx, SubmitResult Reject)],
    TerminalStates (LocalTxSubmission Tx Reject))
forall a. (forall s. IOSim s a) -> a
runSimOrThrow
           (Peer
  (LocalTxSubmission Tx Reject)
  'AsClient
  'NonPipelined
  'StIdle
  (IOSim s)
  [(Tx, SubmitResult Reject)]
-> Peer
     (LocalTxSubmission Tx Reject)
     (FlipAgency 'AsClient)
     'NonPipelined
     'StIdle
     (IOSim s)
     [(Tx, SubmitResult Reject)]
-> IOSim
     s
     ([(Tx, SubmitResult Reject)], [(Tx, SubmitResult Reject)],
      TerminalStates (LocalTxSubmission Tx Reject))
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
             (LocalTxSubmissionClient
  Tx Reject (IOSim s) [(Tx, SubmitResult Reject)]
-> Peer
     (LocalTxSubmission Tx Reject)
     'AsClient
     'NonPipelined
     'StIdle
     (IOSim s)
     [(Tx, SubmitResult Reject)]
forall tx reject (m :: * -> *) a.
Monad m =>
LocalTxSubmissionClient tx reject m a
-> Client (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
localTxSubmissionClientPeer (LocalTxSubmissionClient
   Tx Reject (IOSim s) [(Tx, SubmitResult Reject)]
 -> Peer
      (LocalTxSubmission Tx Reject)
      'AsClient
      'NonPipelined
      'StIdle
      (IOSim s)
      [(Tx, SubmitResult Reject)])
-> LocalTxSubmissionClient
     Tx Reject (IOSim s) [(Tx, SubmitResult Reject)]
-> Peer
     (LocalTxSubmission Tx Reject)
     'AsClient
     'NonPipelined
     'StIdle
     (IOSim s)
     [(Tx, SubmitResult Reject)]
forall a b. (a -> b) -> a -> b
$
              [Tx]
-> LocalTxSubmissionClient
     Tx Reject (IOSim s) [(Tx, SubmitResult Reject)]
forall tx reject (m :: * -> *).
Applicative m =>
[tx]
-> LocalTxSubmissionClient tx reject m [(tx, SubmitResult reject)]
localTxSubmissionClient [Tx]
txs)
             (IOSim
  s
  (LocalTxSubmissionServer
     Tx Reject (IOSim s) [(Tx, SubmitResult Reject)])
-> Server
     (LocalTxSubmission Tx Reject)
     'NonPipelined
     'StIdle
     (IOSim s)
     [(Tx, SubmitResult Reject)]
forall tx reject (m :: * -> *) a.
Monad m =>
m (LocalTxSubmissionServer tx reject m a)
-> Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
localTxSubmissionServerPeer (IOSim
   s
   (LocalTxSubmissionServer
      Tx Reject (IOSim s) [(Tx, SubmitResult Reject)])
 -> Server
      (LocalTxSubmission Tx Reject)
      'NonPipelined
      'StIdle
      (IOSim s)
      [(Tx, SubmitResult Reject)])
-> IOSim
     s
     (LocalTxSubmissionServer
        Tx Reject (IOSim s) [(Tx, SubmitResult Reject)])
-> Server
     (LocalTxSubmission Tx Reject)
     'NonPipelined
     'StIdle
     (IOSim s)
     [(Tx, SubmitResult Reject)]
forall a b. (a -> b) -> a -> b
$ LocalTxSubmissionServer
  Tx Reject (IOSim s) [(Tx, SubmitResult Reject)]
-> IOSim
     s
     (LocalTxSubmissionServer
        Tx Reject (IOSim s) [(Tx, SubmitResult Reject)])
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalTxSubmissionServer
   Tx Reject (IOSim s) [(Tx, SubmitResult Reject)]
 -> IOSim
      s
      (LocalTxSubmissionServer
         Tx Reject (IOSim s) [(Tx, SubmitResult Reject)]))
-> LocalTxSubmissionServer
     Tx Reject (IOSim s) [(Tx, SubmitResult Reject)]
-> IOSim
     s
     (LocalTxSubmissionServer
        Tx Reject (IOSim s) [(Tx, SubmitResult Reject)])
forall a b. (a -> b) -> a -> b
$
              (Tx -> SubmitResult Reject)
-> LocalTxSubmissionServer
     Tx Reject (IOSim s) [(Tx, SubmitResult Reject)]
forall tx reject (m :: * -> *).
Applicative m =>
(tx -> SubmitResult reject)
-> LocalTxSubmissionServer tx reject m [(tx, SubmitResult reject)]
localTxSubmissionServer Tx -> SubmitResult Reject
p)) of

      ([(Tx, SubmitResult Reject)]
a, [(Tx, SubmitResult Reject)]
b, TerminalStates SingLocalTxSubmission st
StateToken st
SingDone SingLocalTxSubmission 'StDone
StateToken st
SingDone) ->
        ([(Tx, SubmitResult Reject)]
a, [(Tx, SubmitResult Reject)]
b) ([(Tx, SubmitResult Reject)], [(Tx, SubmitResult Reject)])
-> ([(Tx, SubmitResult Reject)], [(Tx, SubmitResult Reject)])
-> Bool
forall a. Eq a => a -> a -> Bool
== ([(Tx, SubmitResult Reject)]
txs', [(Tx, SubmitResult Reject)]
txs')
  where
    txs' :: [(Tx, SubmitResult Reject)]
txs' = [ (Tx
tx, Tx -> SubmitResult Reject
p Tx
tx) | Tx
tx <- [Tx]
txs ]


--
-- Properties using a channel
--

-- | Run a local tx-submission client and server using connected channels.
--
prop_channel :: (MonadAsync m, MonadCatch m, MonadST m)
             => m (Channel m ByteString, Channel m ByteString)
             -> (Tx -> SubmitResult Reject) -> [Tx]
             -> m Bool
prop_channel :: forall (m :: * -> *).
(MonadAsync m, MonadCatch m, MonadST m) =>
m (Channel m ByteString, Channel m ByteString)
-> (Tx -> SubmitResult Reject) -> [Tx] -> m Bool
prop_channel m (Channel m ByteString, Channel m ByteString)
createChannels Tx -> SubmitResult Reject
p [Tx]
txs =

    (([(Tx, SubmitResult Reject)]
txs', [(Tx, SubmitResult Reject)]
txs') ([(Tx, SubmitResult Reject)], [(Tx, SubmitResult Reject)])
-> ([(Tx, SubmitResult Reject)], [(Tx, SubmitResult Reject)])
-> Bool
forall a. Eq a => a -> a -> Bool
==) (([(Tx, SubmitResult Reject)], [(Tx, SubmitResult Reject)])
 -> Bool)
-> m ([(Tx, SubmitResult Reject)], [(Tx, SubmitResult Reject)])
-> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>

    m (Channel m ByteString, Channel m ByteString)
-> Tracer m (Role, TraceSendRecv (LocalTxSubmission Tx Reject))
-> Codec
     (LocalTxSubmission Tx Reject) DeserialiseFailure m ByteString
-> Peer
     (LocalTxSubmission Tx Reject)
     'AsClient
     'NonPipelined
     'StIdle
     m
     [(Tx, SubmitResult Reject)]
-> Peer
     (LocalTxSubmission Tx Reject)
     (FlipAgency 'AsClient)
     'NonPipelined
     'StIdle
     m
     [(Tx, SubmitResult Reject)]
-> m ([(Tx, SubmitResult Reject)], [(Tx, SubmitResult Reject)])
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 (LocalTxSubmission Tx Reject))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      Codec (LocalTxSubmission Tx Reject) DeserialiseFailure m ByteString
forall (m :: * -> *).
MonadST m =>
Codec (LocalTxSubmission Tx Reject) DeserialiseFailure m ByteString
codec
      (LocalTxSubmissionClient Tx Reject m [(Tx, SubmitResult Reject)]
-> Peer
     (LocalTxSubmission Tx Reject)
     'AsClient
     'NonPipelined
     'StIdle
     m
     [(Tx, SubmitResult Reject)]
forall tx reject (m :: * -> *) a.
Monad m =>
LocalTxSubmissionClient tx reject m a
-> Client (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
localTxSubmissionClientPeer (LocalTxSubmissionClient Tx Reject m [(Tx, SubmitResult Reject)]
 -> Peer
      (LocalTxSubmission Tx Reject)
      'AsClient
      'NonPipelined
      'StIdle
      m
      [(Tx, SubmitResult Reject)])
-> LocalTxSubmissionClient Tx Reject m [(Tx, SubmitResult Reject)]
-> Peer
     (LocalTxSubmission Tx Reject)
     'AsClient
     'NonPipelined
     'StIdle
     m
     [(Tx, SubmitResult Reject)]
forall a b. (a -> b) -> a -> b
$
       [Tx]
-> LocalTxSubmissionClient Tx Reject m [(Tx, SubmitResult Reject)]
forall tx reject (m :: * -> *).
Applicative m =>
[tx]
-> LocalTxSubmissionClient tx reject m [(tx, SubmitResult reject)]
localTxSubmissionClient [Tx]
txs)
      (m (LocalTxSubmissionServer Tx Reject m [(Tx, SubmitResult Reject)])
-> Server
     (LocalTxSubmission Tx Reject)
     'NonPipelined
     'StIdle
     m
     [(Tx, SubmitResult Reject)]
forall tx reject (m :: * -> *) a.
Monad m =>
m (LocalTxSubmissionServer tx reject m a)
-> Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
localTxSubmissionServerPeer (m (LocalTxSubmissionServer
      Tx Reject m [(Tx, SubmitResult Reject)])
 -> Server
      (LocalTxSubmission Tx Reject)
      'NonPipelined
      'StIdle
      m
      [(Tx, SubmitResult Reject)])
-> m (LocalTxSubmissionServer
        Tx Reject m [(Tx, SubmitResult Reject)])
-> Server
     (LocalTxSubmission Tx Reject)
     'NonPipelined
     'StIdle
     m
     [(Tx, SubmitResult Reject)]
forall a b. (a -> b) -> a -> b
$ LocalTxSubmissionServer Tx Reject m [(Tx, SubmitResult Reject)]
-> m (LocalTxSubmissionServer
        Tx Reject m [(Tx, SubmitResult Reject)])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalTxSubmissionServer Tx Reject m [(Tx, SubmitResult Reject)]
 -> m (LocalTxSubmissionServer
         Tx Reject m [(Tx, SubmitResult Reject)]))
-> LocalTxSubmissionServer Tx Reject m [(Tx, SubmitResult Reject)]
-> m (LocalTxSubmissionServer
        Tx Reject m [(Tx, SubmitResult Reject)])
forall a b. (a -> b) -> a -> b
$
       (Tx -> SubmitResult Reject)
-> LocalTxSubmissionServer Tx Reject m [(Tx, SubmitResult Reject)]
forall tx reject (m :: * -> *).
Applicative m =>
(tx -> SubmitResult reject)
-> LocalTxSubmissionServer tx reject m [(tx, SubmitResult reject)]
localTxSubmissionServer Tx -> SubmitResult Reject
p)
  where
    txs' :: [(Tx, SubmitResult Reject)]
txs' = [ (Tx
tx, Tx -> SubmitResult Reject
p Tx
tx) | Tx
tx <- [Tx]
txs ]


-- | Run 'prop_channel' in the simulation monad.
--
prop_channel_ST :: (Tx -> SubmitResult Reject) -> [Tx] -> Bool
prop_channel_ST :: (Tx -> SubmitResult Reject) -> [Tx] -> Bool
prop_channel_ST Tx -> SubmitResult Reject
p [Tx]
txs =
    (forall s. IOSim s Bool) -> Bool
forall a. (forall s. IOSim s a) -> a
runSimOrThrow
      (IOSim
  s (Channel (IOSim s) ByteString, Channel (IOSim s) ByteString)
-> (Tx -> SubmitResult Reject) -> [Tx] -> IOSim s Bool
forall (m :: * -> *).
(MonadAsync m, MonadCatch m, MonadST m) =>
m (Channel m ByteString, Channel m ByteString)
-> (Tx -> SubmitResult Reject) -> [Tx] -> m Bool
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 Tx -> SubmitResult Reject
p [Tx]
txs)


-- | Run 'prop_channel' in the IO monad.
--
prop_channel_IO :: (Tx -> SubmitResult Reject) -> [Tx] -> Property
prop_channel_IO :: (Tx -> SubmitResult Reject) -> [Tx] -> Property
prop_channel_IO Tx -> SubmitResult Reject
p [Tx]
txs =
    IO Bool -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO (Channel IO ByteString, Channel IO ByteString)
-> (Tx -> SubmitResult Reject) -> [Tx] -> IO Bool
forall (m :: * -> *).
(MonadAsync m, MonadCatch m, MonadST m) =>
m (Channel m ByteString, Channel m ByteString)
-> (Tx -> SubmitResult Reject) -> [Tx] -> m Bool
prop_channel IO (Channel IO ByteString, Channel IO ByteString)
forall (m :: * -> *) a. MonadSTM m => m (Channel m a, Channel m a)
createConnectedChannels Tx -> SubmitResult Reject
p [Tx]
txs)


-- | Run 'prop_channel' in the IO monad using local pipes.
--
prop_pipe_IO :: (Tx -> SubmitResult Reject) -> [Tx] -> Property
prop_pipe_IO :: (Tx -> SubmitResult Reject) -> [Tx] -> Property
prop_pipe_IO Tx -> SubmitResult Reject
p [Tx]
txs =
    IO Bool -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO (Channel IO ByteString, Channel IO ByteString)
-> (Tx -> SubmitResult Reject) -> [Tx] -> IO Bool
forall (m :: * -> *).
(MonadAsync m, MonadCatch m, MonadST m) =>
m (Channel m ByteString, Channel m ByteString)
-> (Tx -> SubmitResult Reject) -> [Tx] -> m Bool
prop_channel IO (Channel IO ByteString, Channel IO ByteString)
createPipeConnectedChannels Tx -> SubmitResult Reject
p [Tx]
txs)


--
-- Codec properties
--

instance Arbitrary (AnyMessage (LocalTxSubmission Tx Reject)) where
  arbitrary :: Gen (AnyMessage (LocalTxSubmission Tx Reject))
arbitrary = [Gen (AnyMessage (LocalTxSubmission Tx Reject))]
-> Gen (AnyMessage (LocalTxSubmission Tx Reject))
forall a. [Gen a] -> Gen a
oneof
    [ Message (LocalTxSubmission Tx Reject) 'StIdle 'StBusy
-> AnyMessage (LocalTxSubmission Tx Reject)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (Message (LocalTxSubmission Tx Reject) 'StIdle 'StBusy
 -> AnyMessage (LocalTxSubmission Tx Reject))
-> Gen (Message (LocalTxSubmission Tx Reject) 'StIdle 'StBusy)
-> Gen (AnyMessage (LocalTxSubmission Tx Reject))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (Tx -> Message (LocalTxSubmission Tx Reject) 'StIdle 'StBusy
forall {k1} tx1 (reject :: k1).
tx1 -> Message (LocalTxSubmission tx1 reject) 'StIdle 'StBusy
MsgSubmitTx (Tx -> Message (LocalTxSubmission Tx Reject) 'StIdle 'StBusy)
-> Gen Tx
-> Gen (Message (LocalTxSubmission Tx Reject) 'StIdle 'StBusy)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Tx
forall a. Arbitrary a => Gen a
arbitrary)

    , Message (LocalTxSubmission Tx Reject) 'StBusy 'StIdle
-> AnyMessage (LocalTxSubmission Tx Reject)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (Message (LocalTxSubmission Tx Reject) 'StBusy 'StIdle
 -> AnyMessage (LocalTxSubmission Tx Reject))
-> Gen (Message (LocalTxSubmission Tx Reject) 'StBusy 'StIdle)
-> Gen (AnyMessage (LocalTxSubmission Tx Reject))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Message (LocalTxSubmission Tx Reject) 'StBusy 'StIdle
-> Gen (Message (LocalTxSubmission Tx Reject) 'StBusy 'StIdle)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Message (LocalTxSubmission Tx Reject) 'StBusy 'StIdle
forall {k} {k1} (tx :: k) (reject :: k1).
Message (LocalTxSubmission tx reject) 'StBusy 'StIdle
MsgAcceptTx

    , Message (LocalTxSubmission Tx Reject) 'StBusy 'StIdle
-> AnyMessage (LocalTxSubmission Tx Reject)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (Message (LocalTxSubmission Tx Reject) 'StBusy 'StIdle
 -> AnyMessage (LocalTxSubmission Tx Reject))
-> Gen (Message (LocalTxSubmission Tx Reject) 'StBusy 'StIdle)
-> Gen (AnyMessage (LocalTxSubmission Tx Reject))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (Reject -> Message (LocalTxSubmission Tx Reject) 'StBusy 'StIdle
forall {k} reject1 (tx :: k).
reject1 -> Message (LocalTxSubmission tx reject1) 'StBusy 'StIdle
MsgRejectTx (Reject -> Message (LocalTxSubmission Tx Reject) 'StBusy 'StIdle)
-> Gen Reject
-> Gen (Message (LocalTxSubmission Tx Reject) 'StBusy 'StIdle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Reject
forall a. Arbitrary a => Gen a
arbitrary)

    , Message (LocalTxSubmission Tx Reject) 'StIdle 'StDone
-> AnyMessage (LocalTxSubmission Tx Reject)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (Message (LocalTxSubmission Tx Reject) 'StIdle 'StDone
 -> AnyMessage (LocalTxSubmission Tx Reject))
-> Gen (Message (LocalTxSubmission Tx Reject) 'StIdle 'StDone)
-> Gen (AnyMessage (LocalTxSubmission Tx Reject))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Message (LocalTxSubmission Tx Reject) 'StIdle 'StDone
-> Gen (Message (LocalTxSubmission Tx Reject) 'StIdle 'StDone)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Message (LocalTxSubmission Tx Reject) 'StIdle 'StDone
forall {k} {k1} (tx :: k) (reject :: k1).
Message (LocalTxSubmission tx reject) 'StIdle 'StDone
MsgDone
    ]

instance (Eq tx, Eq reject) =>
          Eq (AnyMessage (LocalTxSubmission tx reject)) where

  == :: AnyMessage (LocalTxSubmission tx reject)
-> AnyMessage (LocalTxSubmission tx reject) -> Bool
(==) (AnyMessage (MsgSubmitTx tx1
tx))
       (AnyMessage (MsgSubmitTx tx1
tx')) = tx1
tx tx1 -> tx1 -> Bool
forall a. Eq a => a -> a -> Bool
== tx1
tx1
tx'

  (==) (AnyMessage Message (LocalTxSubmission tx reject) st st'
R:MessageLocalTxSubmissionfromto (*) (*) tx reject st st'
MsgAcceptTx)
       (AnyMessage Message (LocalTxSubmission tx reject) st st'
R:MessageLocalTxSubmissionfromto (*) (*) tx reject st st'
MsgAcceptTx) = Bool
True

  (==) (AnyMessage (MsgRejectTx reject1
rej))
       (AnyMessage (MsgRejectTx reject1
rej')) = reject1
rej reject1 -> reject1 -> Bool
forall a. Eq a => a -> a -> Bool
== reject1
reject1
rej'

  (==) (AnyMessage Message (LocalTxSubmission tx reject) st st'
R:MessageLocalTxSubmissionfromto (*) (*) tx reject st st'
MsgDone)
       (AnyMessage Message (LocalTxSubmission tx reject) st st'
R:MessageLocalTxSubmissionfromto (*) (*) tx reject st st'
MsgDone) = Bool
True

  AnyMessage (LocalTxSubmission tx reject)
_ == AnyMessage (LocalTxSubmission tx reject)
_ = Bool
False

instance Arbitrary a => Arbitrary (SubmitResult a) where
  arbitrary :: Gen (SubmitResult a)
arbitrary =
    [(Int, Gen (SubmitResult a))] -> Gen (SubmitResult a)
forall a. [(Int, Gen a)] -> Gen a
QC.frequency
      [ (Int
1, SubmitResult a -> Gen (SubmitResult a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubmitResult a
forall reason. SubmitResult reason
SubmitSuccess)
      , (Int
3, a -> SubmitResult a
forall reason. reason -> SubmitResult reason
SubmitFail (a -> SubmitResult a) -> Gen a -> Gen (SubmitResult a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
arbitrary)
      ]
  shrink :: SubmitResult a -> [SubmitResult a]
shrink = [SubmitResult a] -> SubmitResult a -> [SubmitResult a]
forall a b. a -> b -> a
const []


codec :: MonadST m
       => Codec (LocalTxSubmission Tx Reject)
                DeserialiseFailure
                m ByteString
codec :: forall (m :: * -> *).
MonadST m =>
Codec (LocalTxSubmission Tx Reject) DeserialiseFailure m ByteString
codec = (Tx -> Encoding)
-> (forall s. Decoder s Tx)
-> (Reject -> Encoding)
-> (forall s. Decoder s Reject)
-> Codec
     (LocalTxSubmission Tx Reject) DeserialiseFailure m ByteString
forall tx reject (m :: * -> *).
MonadST m =>
(tx -> Encoding)
-> (forall s. Decoder s tx)
-> (reject -> Encoding)
-> (forall s. Decoder s reject)
-> Codec
     (LocalTxSubmission tx reject) DeserialiseFailure m ByteString
codecLocalTxSubmission
          Tx -> Encoding
forall a. Serialise a => a -> Encoding
Serialise.encode Decoder s Tx
forall s. Decoder s Tx
forall a s. Serialise a => Decoder s a
Serialise.decode
          Reject -> Encoding
forall a. Serialise a => a -> Encoding
Serialise.encode Decoder s Reject
forall s. Decoder s Reject
forall a s. Serialise a => Decoder s a
Serialise.decode


-- | Check the codec round trip property.
--
prop_codec :: AnyMessage (LocalTxSubmission Tx Reject) -> Bool
prop_codec :: AnyMessage (LocalTxSubmission Tx Reject) -> Bool
prop_codec AnyMessage (LocalTxSubmission Tx Reject)
msg =
  (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST (Codec
  (LocalTxSubmission Tx Reject) DeserialiseFailure (ST s) ByteString
-> AnyMessage (LocalTxSubmission Tx Reject) -> ST s Bool
forall ps failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage ps)) =>
Codec ps failure m bytes -> AnyMessage ps -> m Bool
prop_codecM Codec
  (LocalTxSubmission Tx Reject) DeserialiseFailure (ST s) ByteString
forall (m :: * -> *).
MonadST m =>
Codec (LocalTxSubmission Tx Reject) DeserialiseFailure m ByteString
codec AnyMessage (LocalTxSubmission Tx Reject)
msg)

-- | Check for data chunk boundary problems in the codec using 2 chunks.
--
prop_codec_splits2 :: AnyMessage (LocalTxSubmission Tx Reject) -> Bool
prop_codec_splits2 :: AnyMessage (LocalTxSubmission Tx Reject) -> Bool
prop_codec_splits2 AnyMessage (LocalTxSubmission Tx Reject)
msg =
  (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST ((ByteString -> [[ByteString]])
-> Codec
     (LocalTxSubmission Tx Reject) DeserialiseFailure (ST s) ByteString
-> AnyMessage (LocalTxSubmission Tx Reject)
-> ST s Bool
forall ps failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage ps)) =>
(bytes -> [[bytes]])
-> Codec ps failure m bytes -> AnyMessage ps -> m Bool
prop_codec_splitsM ByteString -> [[ByteString]]
splits2 Codec
  (LocalTxSubmission Tx Reject) DeserialiseFailure (ST s) ByteString
forall (m :: * -> *).
MonadST m =>
Codec (LocalTxSubmission Tx Reject) DeserialiseFailure m ByteString
codec AnyMessage (LocalTxSubmission Tx Reject)
msg)

-- | Check for data chunk boundary problems in the codec using 3 chunks.
--
prop_codec_splits3 :: AnyMessage (LocalTxSubmission Tx Reject) -> Bool
prop_codec_splits3 :: AnyMessage (LocalTxSubmission Tx Reject) -> Bool
prop_codec_splits3 AnyMessage (LocalTxSubmission Tx Reject)
msg =
  (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST ((ByteString -> [[ByteString]])
-> Codec
     (LocalTxSubmission Tx Reject) DeserialiseFailure (ST s) ByteString
-> AnyMessage (LocalTxSubmission Tx Reject)
-> ST s Bool
forall ps failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage ps)) =>
(bytes -> [[bytes]])
-> Codec ps failure m bytes -> AnyMessage ps -> m Bool
prop_codec_splitsM ByteString -> [[ByteString]]
splits3 Codec
  (LocalTxSubmission Tx Reject) DeserialiseFailure (ST s) ByteString
forall (m :: * -> *).
MonadST m =>
Codec (LocalTxSubmission Tx Reject) DeserialiseFailure m ByteString
codec AnyMessage (LocalTxSubmission Tx Reject)
msg)

prop_codec_cbor
  :: AnyMessage (LocalTxSubmission Tx Reject)
  -> Bool
prop_codec_cbor :: AnyMessage (LocalTxSubmission Tx Reject) -> Bool
prop_codec_cbor AnyMessage (LocalTxSubmission Tx Reject)
msg =
  (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST (Codec
  (LocalTxSubmission Tx Reject) DeserialiseFailure (ST s) ByteString
-> AnyMessage (LocalTxSubmission Tx Reject) -> ST s Bool
forall ps (m :: * -> *).
Monad m =>
Codec ps DeserialiseFailure m ByteString -> AnyMessage ps -> m Bool
prop_codec_cborM Codec
  (LocalTxSubmission Tx Reject) DeserialiseFailure (ST s) ByteString
forall (m :: * -> *).
MonadST m =>
Codec (LocalTxSubmission Tx Reject) DeserialiseFailure m ByteString
codec AnyMessage (LocalTxSubmission Tx Reject)
msg)

-- | Check that the encoder produces a valid CBOR.
--
prop_codec_valid_cbor
  :: AnyMessage (LocalTxSubmission Tx Reject)
  -> Property
prop_codec_valid_cbor :: AnyMessage (LocalTxSubmission Tx Reject) -> Property
prop_codec_valid_cbor = Codec
  (LocalTxSubmission Tx Reject) DeserialiseFailure IO ByteString
-> AnyMessage (LocalTxSubmission Tx Reject) -> Property
forall ps.
Codec ps DeserialiseFailure IO ByteString
-> AnyMessage ps -> Property
prop_codec_valid_cbor_encoding Codec
  (LocalTxSubmission Tx Reject) DeserialiseFailure IO ByteString
forall (m :: * -> *).
MonadST m =>
Codec (LocalTxSubmission Tx Reject) DeserialiseFailure m ByteString
codec