{-# LANGUAGE DuplicateRecordFields #-}

module Hydra.API.ServerSpec where

import Hydra.Prelude hiding (decodeUtf8, seq)
import Test.Hydra.Prelude

import Cardano.Binary (decodeFull', serialize')
import Conduit (yieldMany)
import Control.Concurrent.Class.MonadSTM (
  check,
  modifyTVar',
  newTVarIO,
  readTQueue,
  readTVarIO,
  tryReadTQueue,
  writeTQueue,
  writeTVar,
 )
import Control.Lens ((^?))
import Control.Tracer.JSON (Tracer, showLogsOnFailure)
import Data.Aeson (Value, (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Lens (key, _Number, _String)
import Data.EventSource (EventSink (..), EventSource (..), HasEventId (getEventId))
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Data.Text.Encoding (decodeUtf8)
import Data.Text.IO (hPutStrLn)
import Data.Version (showVersion)
import Hydra.API.APIServerLog (APIServerLog)
import Hydra.API.ClientInput (ClientInput (Init))
import Hydra.API.Server (APIServerConfig (..), RunServerException (..), Server, mkTimedServerOutputFromStateEvent, projectCommitInfo, projectNetworkInfo, sendMessage, withAPIServer)
import Hydra.API.ServerOutput (ApiEncoding (..), ApiMessage (..), ClientMessage (..), CommitInfo (..), InvalidInput (..), NetworkInfo (..), ServerOutput (..), ServerOutputConfig (..), TimedServerOutput (..), WithAddressedTx (..), WithUTxO (..), input)
import Hydra.API.ServerOutputFilter (ServerOutputFilter (..))
import Hydra.API.WSServer (mkServerOutputConfig, queryParamsOf, shouldServeHistory)
import Hydra.Chain (
  Chain (Chain),
  checkNonADAAssets,
  draftDepositTx,
  postTx,
  submitTx,
 )
import Hydra.HeadLogic.Outcome qualified as Outcome
import Hydra.HeadLogic.State (FanoutMode (..))
import Hydra.HeadLogic.StateEvent (StateEvent (..))
import Hydra.HeadLogicSpec (inIdleState, inOpenState, testSnapshot)
import Hydra.Ledger.Simple (SimpleTx (..))
import Hydra.Network (Host (..), PortNumber, StallReason (..))
import Hydra.NetworkVersions qualified as NetworkVersions
import Hydra.Options (defaultRunOptions)
import Hydra.Tx.Accumulator qualified as Accumulator
import Hydra.Tx.Crypto (MultiSignature)
import Hydra.Tx.IsTx (txId, utxoFromTx)
import Hydra.Tx.Party (Party)
import Hydra.Tx.Snapshot (Snapshot (Snapshot, utxo, utxoToCommit))
import Network.Simple.WSS qualified as WSS
import Network.Socket (Socket, close)
import Network.TLS (ClientHooks (onServerCertificate), ClientParams (clientHooks), defaultParamsClient)
import Network.Wai.Handler.Warp qualified as Warp
import Network.WebSockets (Connection, ConnectionException, receiveData, runClient, sendBinaryData)
import System.IO.Error (isAlreadyInUseError)
import Test.Hydra.HeadLogic.StateEvent (genStateEvent)
import Test.Hydra.Ledger.Simple (aValidTx, utxoRefs)
import Test.Hydra.Node.Fixture (testEnvironment)
import Test.Hydra.Tx.Fixture (alice, defaultPParams, testHeadId)
import Test.Hydra.Tx.Gen ()
import Test.QuickCheck (checkCoverage, cover, forAllShrink, generate, listOf, suchThat)
import Test.QuickCheck.Arbitrary.ADT (ADTArbitrary (..), ConstructorArbitraryPair (..), toADTArbitrary)
import Test.QuickCheck.Monadic (monadicIO, monitor, pick, run)

spec :: Spec
spec :: Spec
spec =
  do
    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"should fail on port in use" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer -> NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        -- The first server serves a socket bound since allocation, so nothing
        -- can take the port in a gap between picking it and binding it. The
        -- second is handed the bare port and has to bind it itself, which is
        -- what must be refused.
        (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
          Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ ->
            PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerBindingPort PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) Tracer IO APIServerLog
tracer (\(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"should have not started")
              IO () -> Selector RunServerException -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` \case
                RunServerException{$sel:port:RunServerException :: RunServerException -> PortNumber
port = PortNumber
errorPort, IOException
ioException :: IOException
$sel:ioException:RunServerException :: RunServerException -> IOException
ioException} ->
                  PortNumber
errorPort PortNumber -> PortNumber -> Bool
forall a. Eq a => a -> a -> Bool
== PortNumber
port Bool -> Bool -> Bool
&& IOException -> Bool
isAlreadyInUseError IOException
ioException

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"greets" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer ->
          (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
            Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ -> do
              PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
                Natural -> Connection -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
Natural -> Connection -> (Value -> Maybe a) -> IO a
waitMatch Natural
5 Connection
conn ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (Value -> Bool) -> Value -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Bool
matchGreetings

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Greetings should contain the hydra-node version" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer ->
          (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
            Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ -> do
              PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
                Value
version <- Natural -> Connection -> (Value -> Maybe Value) -> IO Value
forall a.
HasCallStack =>
Natural -> Connection -> (Value -> Maybe a) -> IO a
waitMatch Natural
5 Connection
conn ((Value -> Maybe Value) -> IO Value)
-> (Value -> Maybe Value) -> IO Value
forall a b. (a -> b) -> a -> b
$ \Value
v -> do
                  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value -> Bool
matchGreetings Value
v
                  Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"hydraNodeVersion"
                Value
version Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` String -> Value
forall a. ToJSON a => a -> Value
toJSON (Version -> String
showVersion Version
NetworkVersions.hydraNodeVersion)

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"greets a client that connects during a broadcast stall" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      -- Whether the node can currently get its messages out is live state, not
      -- history: past outputs are only replayed on request ("history=yes"), so
      -- 'Greetings' is where a freshly connected client has to learn it. Read
      -- live rather than projected precisely so it cannot report a stall that
      -- ended before the node restarted.
      NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
20 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer ->
          (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port -> do
            TVar (Maybe StallReason)
stalled <- Maybe StallReason -> IO (TVar IO (Maybe StallReason))
forall a. a -> IO (TVar IO a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO Maybe StallReason
forall a. Maybe a
Nothing
            Socket
-> IO (Maybe StallReason)
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerStalledWhen Socket
sock (TVar IO (Maybe StallReason) -> IO (Maybe StallReason)
forall a. TVar IO a -> IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar (Maybe StallReason)
TVar IO (Maybe StallReason)
stalled) PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ -> do
              let greetedWith :: Maybe StallReason -> IO ()
greetedWith Maybe StallReason
expected =
                    PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
                      Value
greeted <- Natural -> Connection -> (Value -> Maybe Value) -> IO Value
forall a.
HasCallStack =>
Natural -> Connection -> (Value -> Maybe a) -> IO a
waitMatch Natural
5 Connection
conn ((Value -> Maybe Value) -> IO Value)
-> (Value -> Maybe Value) -> IO Value
forall a b. (a -> b) -> a -> b
$ \Value
v -> do
                        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value -> Bool
matchGreetings Value
v
                        Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"networkInfo" Getting (First Value) Value Value
-> Getting (First Value) Value Value
-> Getting (First Value) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"broadcastStall"
                      Value
greeted Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Maybe StallReason -> Value
forall a. ToJSON a => a -> Value
toJSON Maybe StallReason
expected
              Maybe StallReason -> IO ()
greetedWith (forall a. Maybe a
Nothing @StallReason)
              -- Which condition it is reaches the client too, not just that
              -- there is one: only 'NoProgress' means unreachable.
              STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar IO (Maybe StallReason) -> Maybe StallReason -> STM IO ()
forall a. TVar IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar (Maybe StallReason)
TVar IO (Maybe StallReason)
stalled (StallReason -> Maybe StallReason
forall a. a -> Maybe a
Just StallReason
NoProgress)
              Maybe StallReason -> IO ()
greetedWith (StallReason -> Maybe StallReason
forall a. a -> Maybe a
Just StallReason
NoProgress)
              STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar IO (Maybe StallReason) -> Maybe StallReason -> STM IO ()
forall a. TVar IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar (Maybe StallReason)
TVar IO (Maybe StallReason)
stalled (StallReason -> Maybe StallReason
forall a. a -> Maybe a
Just StallReason
BacklogFull)
              Maybe StallReason -> IO ()
greetedWith (StallReason -> Maybe StallReason
forall a. a -> Maybe a
Just StallReason
BacklogFull)
              -- ... and does not latch once it recovers.
              STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar IO (Maybe StallReason) -> Maybe StallReason -> STM IO ()
forall a. TVar IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar (Maybe StallReason)
TVar IO (Maybe StallReason)
stalled Maybe StallReason
forall a. Maybe a
Nothing
              Maybe StallReason -> IO ()
greetedWith (forall a. Maybe a
Nothing @StallReason)

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"sends server outputs to all connected clients" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      TQueue Value
queue <- String -> IO (TQueue IO Value)
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> m (TQueue m a)
newLabelledTQueueIO String
"queue"
      Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer -> NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port -> do
          Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink{HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent :: HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent :: forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent}, Server SimpleTx IO
_) -> do
            TVar Int
semaphore <- String -> Int -> IO (TVar IO Int)
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"semaphore" Int
0
            (String, IO ()) -> (Async IO () -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (Async m a -> m b) -> m b
withAsyncLabelled
              ( String
"concurrent-test-clients"
              , (String, IO ()) -> (String, IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (String, m b) -> m ()
concurrentlyLabelled_
                  (String
"concurrent-test-client-1", PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue IO Value -> TVar IO Int -> Connection -> IO ()
testClient TQueue Value
TQueue IO Value
queue TVar Int
TVar IO Int
semaphore)
                  (String
"concurrent-test-client-2", PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue IO Value -> TVar IO Int -> Connection -> IO ()
testClient TQueue Value
TQueue IO Value
queue TVar Int
TVar IO Int
semaphore)
              )
              ((Async IO () -> IO ()) -> IO ())
-> (Async IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async IO ()
_ -> do
                TVar IO Int -> IO ()
forall (m :: * -> *) a.
(MonadSTM m, Ord a, Num a) =>
TVar m a -> m ()
waitForClients TVar Int
TVar IO Int
semaphore
                NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
10 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                  STM IO [Value] -> IO [Value]
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Int -> STM Value -> STM [Value]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (TQueue IO Value -> STM IO Value
forall a. TQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue Value
TQueue IO Value
queue))
                    IO [Value] -> ([Value] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Value] -> [Value -> Bool] -> IO ()
forall a. (HasCallStack, Show a) => [a] -> [a -> Bool] -> IO ()
`shouldSatisfyAll` [Value -> Bool
matchGreetings, Value -> Bool
matchGreetings])

                StateEvent SimpleTx
arbitraryEvent <- Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate Gen (StateEvent SimpleTx)
genStateEventForApi
                let expectedMessage :: Value
expectedMessage =
                      TimedServerOutput SimpleTx -> Value
forall a. ToJSON a => a -> Value
toJSON (TimedServerOutput SimpleTx -> Value)
-> TimedServerOutput SimpleTx -> Value
forall a b. (a -> b) -> a -> b
$
                        TimedServerOutput SimpleTx
-> Maybe (TimedServerOutput SimpleTx) -> TimedServerOutput SimpleTx
forall a. a -> Maybe a -> a
fromMaybe (Text -> TimedServerOutput SimpleTx
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"failed to convert stateEvent") (Maybe (TimedServerOutput SimpleTx) -> TimedServerOutput SimpleTx)
-> Maybe (TimedServerOutput SimpleTx) -> TimedServerOutput SimpleTx
forall a b. (a -> b) -> a -> b
$
                          Maybe (Snapshot SimpleTx)
-> StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent Maybe (Snapshot SimpleTx)
forall a. Maybe a
Nothing StateEvent SimpleTx
arbitraryEvent
                StateEvent SimpleTx -> IO ()
HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent StateEvent SimpleTx
arbitraryEvent
                NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
10 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM IO [Value] -> IO [Value]
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Int -> STM Value -> STM [Value]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (TQueue IO Value -> STM IO Value
forall a. TQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue Value
TQueue IO Value
queue)) IO [Value] -> [Value] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [Value
expectedMessage, Value
expectedMessage]
                NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
10 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM IO (Maybe Value) -> IO (Maybe Value)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TQueue IO Value -> STM IO (Maybe Value)
forall a. TQueue IO a -> STM IO (Maybe a)
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m (Maybe a)
tryReadTQueue TQueue Value
TQueue IO Value
queue) IO (Maybe Value) -> Maybe Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Maybe Value
forall a. Maybe a
Nothing

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"sends server output history to all connected clients (using given event source)" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer -> NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        StateEvent SimpleTx
stateEvent <- Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate Gen (StateEvent SimpleTx)
genStateEventForApi
        let expectedMessage :: Value
expectedMessage =
              TimedServerOutput SimpleTx -> Value
forall a. ToJSON a => a -> Value
toJSON (TimedServerOutput SimpleTx -> Value)
-> TimedServerOutput SimpleTx -> Value
forall a b. (a -> b) -> a -> b
$
                TimedServerOutput SimpleTx
-> Maybe (TimedServerOutput SimpleTx) -> TimedServerOutput SimpleTx
forall a. a -> Maybe a -> a
fromMaybe (Text -> TimedServerOutput SimpleTx
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"failed to convert stateEvent") (Maybe (TimedServerOutput SimpleTx) -> TimedServerOutput SimpleTx)
-> Maybe (TimedServerOutput SimpleTx) -> TimedServerOutput SimpleTx
forall a b. (a -> b) -> a -> b
$
                  Maybe (Snapshot SimpleTx)
-> StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent Maybe (Snapshot SimpleTx)
forall a. Maybe a
Nothing StateEvent SimpleTx
stateEvent
        let eventSource :: EventSource (StateEvent SimpleTx) IO
eventSource = [StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource [StateEvent SimpleTx
stateEvent]

        TQueue Value
queue1 <- String -> IO (TQueue IO Value)
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> m (TQueue m a)
newLabelledTQueueIO String
"queue1"
        TQueue Value
queue2 <- String -> IO (TQueue IO Value)
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> m (TQueue m a)
newLabelledTQueueIO String
"queue2"
        (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port -> do
          Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice EventSource (StateEvent SimpleTx) IO
eventSource Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ -> do
            TVar Int
semaphore <- String -> Int -> IO (TVar IO Int)
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"semaphore" Int
0
            (String, IO ()) -> (Async IO () -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (Async m a -> m b) -> m b
withAsyncLabelled
              ( String
"concurrent-test-clients"
              , (String, IO ()) -> (String, IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (String, m b) -> m ()
concurrentlyLabelled_
                  (String
"concurrent-test-client-queue1", PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?history=yes" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue IO Value -> TVar IO Int -> Connection -> IO ()
testClient TQueue Value
TQueue IO Value
queue1 TVar Int
TVar IO Int
semaphore)
                  (String
"concurrent-test-client-queue2", PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?history=yes" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue IO Value -> TVar IO Int -> Connection -> IO ()
testClient TQueue Value
TQueue IO Value
queue2 TVar Int
TVar IO Int
semaphore)
              )
              ((Async IO () -> IO ()) -> IO ())
-> (Async IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async IO ()
_ -> do
                TVar IO Int -> IO ()
forall (m :: * -> *) a.
(MonadSTM m, Ord a, Num a) =>
TVar m a -> m ()
waitForClients TVar Int
TVar IO Int
semaphore
                NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
10 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                  STM IO Value -> IO Value
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TQueue IO Value -> STM IO Value
forall a. TQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue Value
TQueue IO Value
queue1) IO Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Value
expectedMessage
                  STM IO Value -> IO Value
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TQueue IO Value -> STM IO Value
forall a. TQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue Value
TQueue IO Value
queue1) IO Value -> (Value -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> (Value -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` Value -> Bool
matchGreetings)
                NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
10 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                  STM IO Value -> IO Value
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TQueue IO Value -> STM IO Value
forall a. TQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue Value
TQueue IO Value
queue2) IO Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Value
expectedMessage
                  STM IO Value -> IO Value
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TQueue IO Value -> STM IO Value
forall a. TQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue Value
TQueue IO Value
queue2) IO Value -> (Value -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> (Value -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` Value -> Bool
matchGreetings)

    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"echoes history (past outputs) to client upon reconnection" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$
      Gen [StateEvent SimpleTx]
-> ([StateEvent SimpleTx] -> [[StateEvent SimpleTx]])
-> ([StateEvent SimpleTx] -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink (Gen (StateEvent SimpleTx) -> Gen [StateEvent SimpleTx]
forall a. Gen a -> Gen [a]
listOf Gen (StateEvent SimpleTx)
genStateEventForApi) [StateEvent SimpleTx] -> [[StateEvent SimpleTx]]
forall a. Arbitrary a => a -> [a]
shrink (([StateEvent SimpleTx] -> Property) -> Property)
-> ([StateEvent SimpleTx] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[StateEvent SimpleTx]
events -> do
        let expectedMessages :: [Value]
expectedMessages = (TimedServerOutput SimpleTx -> Value)
-> [TimedServerOutput SimpleTx] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map TimedServerOutput SimpleTx -> Value
forall a. ToJSON a => a -> Value
toJSON ([TimedServerOutput SimpleTx] -> [Value])
-> [TimedServerOutput SimpleTx] -> [Value]
forall a b. (a -> b) -> a -> b
$ (StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx))
-> [StateEvent SimpleTx] -> [TimedServerOutput SimpleTx]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe (Snapshot SimpleTx)
-> StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent Maybe (Snapshot SimpleTx)
forall a. Maybe a
Nothing) [StateEvent SimpleTx]
events
        Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage (Property -> Property)
-> (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
0.1 ([StateEvent SimpleTx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StateEvent SimpleTx]
events) String
"no message when reconnecting"
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
0.1 ([StateEvent SimpleTx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StateEvent SimpleTx]
events Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) String
"only one message when reconnecting"
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 ([StateEvent SimpleTx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StateEvent SimpleTx]
events Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) String
"more than one message when reconnecting"
          IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$
            Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer ->
              (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
                Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource [StateEvent SimpleTx]
events) Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink{HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent :: forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent :: HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent}, Server SimpleTx IO
_) -> do
                  (StateEvent SimpleTx -> IO ()) -> [StateEvent SimpleTx] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StateEvent SimpleTx -> IO ()
HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent [StateEvent SimpleTx]
events
                  PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?history=yes" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
                    [ByteString]
received <- NominalDiffTime -> IO [ByteString] -> IO [ByteString]
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
20 (IO [ByteString] -> IO [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ Int -> IO ByteString -> IO [ByteString]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([StateEvent SimpleTx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StateEvent SimpleTx]
events Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn)
                    case (ByteString -> Either String Value)
-> [ByteString] -> Either String [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode [ByteString]
received of
                      Left{} -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to decode messages:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> String
forall b a. (Show a, IsString b) => a -> b
show [ByteString]
received
                      Right [Value]
actualMessages -> do
                        [Value] -> [Value]
forall a. HasCallStack => [a] -> [a]
List.init [Value]
actualMessages [Value] -> [Value] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [Value]
expectedMessages
                        [Value] -> Value
forall a. HasCallStack => [a] -> a
List.last [Value]
actualMessages Value -> (Value -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` Value -> Bool
matchGreetings

    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not echo history if client says no" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$
      Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage (Property -> Property)
-> (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
        [StateEvent SimpleTx]
history <- Gen [StateEvent SimpleTx] -> PropertyM IO [StateEvent SimpleTx]
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick (Gen [StateEvent SimpleTx] -> PropertyM IO [StateEvent SimpleTx])
-> Gen [StateEvent SimpleTx] -> PropertyM IO [StateEvent SimpleTx]
forall a b. (a -> b) -> a -> b
$ Gen (StateEvent SimpleTx) -> Gen [StateEvent SimpleTx]
forall a. Gen a -> Gen [a]
listOf Gen (StateEvent SimpleTx)
genStateEventForApi
        (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
0.1 ([StateEvent SimpleTx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StateEvent SimpleTx]
history) String
"no message when reconnecting"
        (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
0.1 ([StateEvent SimpleTx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StateEvent SimpleTx]
history Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) String
"only one message when reconnecting"
        (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor ((Property -> Property) -> PropertyM IO ())
-> (Property -> Property) -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 ([StateEvent SimpleTx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StateEvent SimpleTx]
history Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) String
"more than one message when reconnecting"
        IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer ->
            (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
              Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource [StateEvent SimpleTx]
history) Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink{HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent :: forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent :: HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent}, Server SimpleTx IO
_) -> do
                (StateEvent SimpleTx -> IO ()) -> [StateEvent SimpleTx] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StateEvent SimpleTx -> IO ()
HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent [StateEvent SimpleTx]
history
                -- start client that doesn't want to see the history. Passing
                -- 'history=no' and passing nothing at all take the same branch
                -- of 'shouldServeHistory', so this covers the default too.
                PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?history=no" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
                  -- NOTE: Assert on the *first* message rather than draining up
                  -- to the greeting. 'wsApp' forwards history before the
                  -- greeting, so a 'waitMatch' for the greeting would swallow
                  -- any replay and pass whether or not history was served.
                  --
                  -- The longer-than-typical budget here is because this is a
                  -- property test running ~100 iterations; each iteration spins
                  -- up a full WS server, and the per-iteration 5s default was
                  -- racing with CPU contention when the full hydra-node test
                  -- suite runs in parallel.
                  ByteString
greeting <- NominalDiffTime -> IO ByteString -> IO ByteString
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
20 (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn
                  case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode ByteString
greeting of
                    Left{} -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to decode greeting:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall b a. (Show a, IsString b) => a -> b
show ByteString
greeting
                    Right (Value
v :: Value) -> Value
v Value -> (Value -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` Value -> Bool
matchGreetings

                  StateEvent SimpleTx
notHistoryMessage :: StateEvent SimpleTx <- Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate Gen (StateEvent SimpleTx)
genStateEventForApi
                  StateEvent SimpleTx -> IO ()
HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent StateEvent SimpleTx
notHistoryMessage

                  -- Receive one more message. The messages we sent
                  -- before client connected are ignored as expected and client can
                  -- see only this last sent message.
                  [ByteString]
received <- NominalDiffTime -> IO [ByteString] -> IO [ByteString]
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
20 (IO [ByteString] -> IO [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ Int -> IO ByteString -> IO [ByteString]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
1 (Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn)

                  case (ByteString -> Either String (TimedServerOutput SimpleTx))
-> [ByteString] -> Either String [TimedServerOutput SimpleTx]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ByteString -> Either String (TimedServerOutput SimpleTx)
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode [ByteString]
received of
                    Left{} -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to decode messages:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> String
forall b a. (Show a, IsString b) => a -> b
show [ByteString]
received
                    Right [TimedServerOutput SimpleTx]
timedOutputs -> do
                      [TimedServerOutput SimpleTx]
timedOutputs [TimedServerOutput SimpleTx]
-> [TimedServerOutput SimpleTx] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [TimedServerOutput SimpleTx
-> Maybe (TimedServerOutput SimpleTx) -> TimedServerOutput SimpleTx
forall a. a -> Maybe a -> a
fromMaybe (Text -> TimedServerOutput SimpleTx
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"failed to convert stateEvent") (Maybe (TimedServerOutput SimpleTx) -> TimedServerOutput SimpleTx)
-> Maybe (TimedServerOutput SimpleTx) -> TimedServerOutput SimpleTx
forall a b. (a -> b) -> a -> b
$ Maybe (Snapshot SimpleTx)
-> StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent Maybe (Snapshot SimpleTx)
forall a. Maybe a
Nothing StateEvent SimpleTx
notHistoryMessage]

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"removes UTXO from snapshot when clients request it" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
      Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer -> NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
          Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink{HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent :: forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent :: HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent}, Server SimpleTx IO
_) -> do
            Snapshot SimpleTx
snapshot <- Gen (Snapshot SimpleTx) -> IO (Snapshot SimpleTx)
forall a. Gen a -> IO a
generate Gen (Snapshot SimpleTx)
forall a. Arbitrary a => Gen a
arbitrary
            StateEvent SimpleTx
snapshotConfirmedMessage <-
              Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate (Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx))
-> Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a b. (a -> b) -> a -> b
$
                StateChanged SimpleTx -> Gen (StateEvent SimpleTx)
forall tx. StateChanged tx -> Gen (StateEvent tx)
genStateEvent (StateChanged SimpleTx -> Gen (StateEvent SimpleTx))
-> StateChanged SimpleTx -> Gen (StateEvent SimpleTx)
forall a b. (a -> b) -> a -> b
$
                  Outcome.SnapshotConfirmed
                    { $sel:headId:NetworkConnected :: HeadId
headId = HeadId
testHeadId
                    , $sel:snapshot:NetworkConnected :: Maybe (Snapshot SimpleTx)
snapshot = Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
snapshot
                    , $sel:signatures:NetworkConnected :: MultiSignature (Snapshot SimpleTx)
signatures = MultiSignature (Snapshot SimpleTx)
forall a. Monoid a => a
mempty
                    }

            PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?snapshot-utxo=no" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
              StateEvent SimpleTx -> IO ()
HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent StateEvent SimpleTx
snapshotConfirmedMessage

              Natural -> Connection -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
Natural -> Connection -> (Value -> Maybe a) -> IO a
waitMatch Natural
5 Connection
conn ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
v ->
                Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Maybe Value -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Value -> Bool) -> Maybe Value -> Bool
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"utxo"

    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"sequence numbers on history are based on the event id" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$
      Gen [StateEvent SimpleTx]
-> ([StateEvent SimpleTx] -> [[StateEvent SimpleTx]])
-> ([StateEvent SimpleTx] -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink (Gen (StateEvent SimpleTx) -> Gen [StateEvent SimpleTx]
forall a. Gen a -> Gen [a]
listOf Gen (StateEvent SimpleTx)
genStateEventForApi) [StateEvent SimpleTx] -> [[StateEvent SimpleTx]]
forall a. Arbitrary a => a -> [a]
shrink (([StateEvent SimpleTx] -> Property) -> Property)
-> ([StateEvent SimpleTx] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[StateEvent SimpleTx]
events -> do
        PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
          IO () -> PropertyM IO ()
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO () -> PropertyM IO ()) -> IO () -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$
            -- NOTE: 20s, matching the similar property test above, so the
            -- timeout doesn't fire just because the full tasty suite is
            -- running many of these in parallel and starving each server's
            -- WS read of CPU.
            Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer -> NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
20 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
                Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource [StateEvent SimpleTx]
events) Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ -> do
                  PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?history=yes" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
                    -- NOTE: Expect all history + greetings
                    [ByteString]
received :: [ByteString] <- Int -> IO ByteString -> IO [ByteString]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([StateEvent SimpleTx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StateEvent SimpleTx]
events Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn)
                    let [Word64]
seqs :: [Word64] = (ByteString -> Maybe Word64) -> [ByteString] -> [Word64]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ByteString
v -> ByteString
v ByteString
-> Getting (First Scientific) ByteString Scientific
-> Maybe Scientific
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' ByteString Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"seq" ((Value -> Const (First Scientific) Value)
 -> ByteString -> Const (First Scientific) ByteString)
-> ((Scientific -> Const (First Scientific) Scientific)
    -> Value -> Const (First Scientific) Value)
-> Getting (First Scientific) ByteString Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scientific -> Const (First Scientific) Scientific)
-> Value -> Const (First Scientific) Value
forall t. AsNumber t => Prism' t Scientific
Prism' Value Scientific
_Number Maybe Scientific -> (Scientific -> Word64) -> Maybe Word64
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Scientific -> Word64
forall b. Integral b => Scientific -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate) [ByteString]
received
                    [Word64]
seqs [Word64] -> [Word64] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` StateEvent SimpleTx -> Word64
forall a. HasEventId a => a -> Word64
getEventId (StateEvent SimpleTx -> Word64)
-> [StateEvent SimpleTx] -> [Word64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StateEvent SimpleTx]
events

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"displays correctly headStatus and snapshotUtxo in a Greeting message" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
      Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer ->
        (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port -> do
          -- Use a single headId throughout so the headId validation in
          -- 'aggregateNodeState' does not drop events from a mismatched head.
          HeadId
headId <- Gen HeadId -> IO HeadId
forall a. Gen a -> IO a
generate Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary

          -- Prime some relevant server outputs already into event source to
          -- check whether the latest headStatus is loaded correctly.
          [StateEvent SimpleTx]
existingStateChanges <-
            Gen [StateEvent SimpleTx] -> IO [StateEvent SimpleTx]
forall a. Gen a -> IO a
generate (Gen [StateEvent SimpleTx] -> IO [StateEvent SimpleTx])
-> Gen [StateEvent SimpleTx] -> IO [StateEvent SimpleTx]
forall a b. (a -> b) -> a -> b
$
              (Gen (StateChanged SimpleTx) -> Gen (StateEvent SimpleTx))
-> [Gen (StateChanged SimpleTx)] -> Gen [StateEvent SimpleTx]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
                (Gen (StateChanged SimpleTx)
-> (StateChanged SimpleTx -> Gen (StateEvent SimpleTx))
-> Gen (StateEvent SimpleTx)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StateChanged SimpleTx -> Gen (StateEvent SimpleTx)
forall tx. StateChanged tx -> Gen (StateEvent tx)
genStateEvent)
                [ HeadParameters
-> ChainStateType SimpleTx
-> HeadId
-> HeadSeed
-> [Party]
-> StateChanged SimpleTx
HeadParameters
-> SimpleChainState
-> HeadId
-> HeadSeed
-> [Party]
-> StateChanged SimpleTx
forall tx.
HeadParameters
-> ChainStateType tx
-> HeadId
-> HeadSeed
-> [Party]
-> StateChanged tx
Outcome.HeadOpened (HeadParameters
 -> SimpleChainState
 -> HeadId
 -> HeadSeed
 -> [Party]
 -> StateChanged SimpleTx)
-> Gen HeadParameters
-> Gen
     (SimpleChainState
      -> HeadId -> HeadSeed -> [Party] -> StateChanged SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen HeadParameters
forall a. Arbitrary a => Gen a
arbitrary Gen
  (SimpleChainState
   -> HeadId -> HeadSeed -> [Party] -> StateChanged SimpleTx)
-> Gen SimpleChainState
-> Gen (HeadId -> HeadSeed -> [Party] -> StateChanged SimpleTx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SimpleChainState
forall a. Arbitrary a => Gen a
arbitrary Gen (HeadId -> HeadSeed -> [Party] -> StateChanged SimpleTx)
-> Gen HeadId -> Gen (HeadSeed -> [Party] -> StateChanged SimpleTx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadId -> Gen HeadId
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadId
headId Gen (HeadSeed -> [Party] -> StateChanged SimpleTx)
-> Gen HeadSeed -> Gen ([Party] -> StateChanged SimpleTx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen HeadSeed
forall a. Arbitrary a => Gen a
arbitrary Gen ([Party] -> StateChanged SimpleTx)
-> Gen [Party] -> Gen (StateChanged SimpleTx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen [Party]
forall a. Arbitrary a => Gen a
arbitrary
                ]
          let eventSource :: EventSource (StateEvent SimpleTx) IO
eventSource = [StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource [StateEvent SimpleTx]
existingStateChanges

          Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice EventSource (StateEvent SimpleTx) IO
eventSource Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink{HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent :: forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent :: HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent}, Server SimpleTx IO
_) -> do
            let generateSnapshot :: Gen (StateChanged SimpleTx)
generateSnapshot =
                  (HeadId
-> Maybe (Snapshot SimpleTx)
-> MultiSignature (Snapshot SimpleTx)
-> StateChanged SimpleTx
forall tx.
HeadId
-> Maybe (Snapshot tx)
-> MultiSignature (Snapshot tx)
-> StateChanged tx
Outcome.SnapshotConfirmed HeadId
headId (Maybe (Snapshot SimpleTx)
 -> MultiSignature (Snapshot SimpleTx) -> StateChanged SimpleTx)
-> (Snapshot SimpleTx -> Maybe (Snapshot SimpleTx))
-> Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx)
-> StateChanged SimpleTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just (Snapshot SimpleTx
 -> MultiSignature (Snapshot SimpleTx) -> StateChanged SimpleTx)
-> Gen (Snapshot SimpleTx)
-> Gen
     (MultiSignature (Snapshot SimpleTx) -> StateChanged SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Snapshot SimpleTx)
forall a. Arbitrary a => Gen a
arbitrary) Gen (MultiSignature (Snapshot SimpleTx) -> StateChanged SimpleTx)
-> Gen (MultiSignature (Snapshot SimpleTx))
-> Gen (StateChanged SimpleTx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (MultiSignature (Snapshot SimpleTx))
forall a. Arbitrary a => Gen a
arbitrary

            HasCallStack => PortNumber -> (Value -> Maybe ()) -> IO ()
PortNumber -> (Value -> Maybe ()) -> IO ()
waitForValue PortNumber
port ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
v -> do
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"headStatus" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
Aeson.String Text
"Open")
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"snapshotUtxo" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Array -> Value
Aeson.Array Array
forall a. Monoid a => a
mempty)

            snapShotConfirmedMsg :: StateEvent SimpleTx
snapShotConfirmedMsg@StateEvent{$sel:stateChanged:StateEvent :: forall tx. StateEvent tx -> StateChanged tx
stateChanged = Outcome.SnapshotConfirmed{$sel:snapshot:NetworkConnected :: forall tx. StateChanged tx -> Maybe (Snapshot tx)
snapshot = Just Snapshot{UTxOType SimpleTx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo :: UTxOType SimpleTx
utxo, Maybe (UTxOType SimpleTx)
$sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit :: Maybe (UTxOType SimpleTx)
utxoToCommit}}} <-
              Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate (Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx))
-> Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a b. (a -> b) -> a -> b
$ StateChanged SimpleTx -> Gen (StateEvent SimpleTx)
forall tx. StateChanged tx -> Gen (StateEvent tx)
genStateEvent (StateChanged SimpleTx -> Gen (StateEvent SimpleTx))
-> Gen (StateChanged SimpleTx) -> Gen (StateEvent SimpleTx)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen (StateChanged SimpleTx)
generateSnapshot

            StateEvent SimpleTx -> IO ()
HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent StateEvent SimpleTx
snapShotConfirmedMsg
            HasCallStack => PortNumber -> (Value -> Maybe ()) -> IO ()
PortNumber -> (Value -> Maybe ()) -> IO ()
waitForValue PortNumber
port ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
v -> do
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"headStatus" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
Aeson.String Text
"Open")
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"snapshotUtxo" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Set SimpleTxOut -> Value
forall a. ToJSON a => a -> Value
toJSON (Set SimpleTxOut -> Value) -> Set SimpleTxOut -> Value
forall a b. (a -> b) -> a -> b
$ Set SimpleTxOut
UTxOType SimpleTx
utxo Set SimpleTxOut -> Set SimpleTxOut -> Set SimpleTxOut
forall a. Semigroup a => a -> a -> a
<> Set SimpleTxOut -> Maybe (Set SimpleTxOut) -> Set SimpleTxOut
forall a. a -> Maybe a -> a
fromMaybe Set SimpleTxOut
forall a. Monoid a => a
mempty Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
utxoToCommit)

            snapShotConfirmedMsg' :: StateEvent SimpleTx
snapShotConfirmedMsg'@StateEvent
              { $sel:stateChanged:StateEvent :: forall tx. StateEvent tx -> StateChanged tx
stateChanged =
                Outcome.SnapshotConfirmed{$sel:snapshot:NetworkConnected :: forall tx. StateChanged tx -> Maybe (Snapshot tx)
snapshot = Just Snapshot{$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo = UTxOType SimpleTx
utxo', $sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit = Maybe (UTxOType SimpleTx)
utxoToCommit'}}
              } <-
              Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate (Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx))
-> Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a b. (a -> b) -> a -> b
$ StateChanged SimpleTx -> Gen (StateEvent SimpleTx)
forall tx. StateChanged tx -> Gen (StateEvent tx)
genStateEvent (StateChanged SimpleTx -> Gen (StateEvent SimpleTx))
-> Gen (StateChanged SimpleTx) -> Gen (StateEvent SimpleTx)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen (StateChanged SimpleTx)
generateSnapshot
            StateEvent SimpleTx
headClosedMsg <-
              Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate (Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx))
-> Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a b. (a -> b) -> a -> b
$
                StateChanged SimpleTx -> Gen (StateEvent SimpleTx)
forall tx. StateChanged tx -> Gen (StateEvent tx)
genStateEvent
                  (StateChanged SimpleTx -> Gen (StateEvent SimpleTx))
-> Gen (StateChanged SimpleTx) -> Gen (StateEvent SimpleTx)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ( HeadId
-> SnapshotNumber
-> ChainStateType SimpleTx
-> UTCTime
-> StateChanged SimpleTx
forall tx.
HeadId
-> SnapshotNumber
-> ChainStateType tx
-> UTCTime
-> StateChanged tx
Outcome.HeadClosed HeadId
headId (SnapshotNumber
 -> SimpleChainState -> UTCTime -> StateChanged SimpleTx)
-> Gen SnapshotNumber
-> Gen (SimpleChainState -> UTCTime -> StateChanged SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen SnapshotNumber
forall a. Arbitrary a => Gen a
arbitrary Gen (SimpleChainState -> UTCTime -> StateChanged SimpleTx)
-> Gen SimpleChainState -> Gen (UTCTime -> StateChanged SimpleTx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SimpleChainState
forall a. Arbitrary a => Gen a
arbitrary Gen (UTCTime -> StateChanged SimpleTx)
-> Gen UTCTime -> Gen (StateChanged SimpleTx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen UTCTime
forall a. Arbitrary a => Gen a
arbitrary
                      )
            StateEvent SimpleTx
readyToFanoutMsg <- Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate (Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx))
-> Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a b. (a -> b) -> a -> b
$ StateChanged SimpleTx -> Gen (StateEvent SimpleTx)
forall tx. StateChanged tx -> Gen (StateEvent tx)
genStateEvent Outcome.HeadIsReadyToFanout{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId}

            (StateEvent SimpleTx -> IO ()) -> [StateEvent SimpleTx] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StateEvent SimpleTx -> IO ()
HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent [StateEvent SimpleTx
snapShotConfirmedMsg', StateEvent SimpleTx
headClosedMsg, StateEvent SimpleTx
readyToFanoutMsg]
            HasCallStack => PortNumber -> (Value -> Maybe ()) -> IO ()
PortNumber -> (Value -> Maybe ()) -> IO ()
waitForValue PortNumber
port ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
v -> do
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"headStatus" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
Aeson.String Text
"FanoutPossible")
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"snapshotUtxo" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Set SimpleTxOut -> Value
forall a. ToJSON a => a -> Value
toJSON (Set SimpleTxOut -> Value) -> Set SimpleTxOut -> Value
forall a b. (a -> b) -> a -> b
$ Set SimpleTxOut
UTxOType SimpleTx
utxo' Set SimpleTxOut -> Set SimpleTxOut -> Set SimpleTxOut
forall a. Semigroup a => a -> a -> a
<> Set SimpleTxOut -> Maybe (Set SimpleTxOut) -> Set SimpleTxOut
forall a. a -> Maybe a -> a
fromMaybe Set SimpleTxOut
forall a. Monoid a => a
mempty Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
utxoToCommit')

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"greets with correct head status and snapshot utxo after restart" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
      Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer ->
        (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port -> do
          headIsOpenMsg :: StateChanged SimpleTx
headIsOpenMsg@Outcome.HeadOpened{$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId = HeadId
openedHeadId} <- Gen (StateChanged SimpleTx) -> IO (StateChanged SimpleTx)
forall a. Gen a -> IO a
generate (Gen (StateChanged SimpleTx) -> IO (StateChanged SimpleTx))
-> Gen (StateChanged SimpleTx) -> IO (StateChanged SimpleTx)
forall a b. (a -> b) -> a -> b
$ HeadParameters
-> ChainStateType SimpleTx
-> HeadId
-> HeadSeed
-> [Party]
-> StateChanged SimpleTx
HeadParameters
-> SimpleChainState
-> HeadId
-> HeadSeed
-> [Party]
-> StateChanged SimpleTx
forall tx.
HeadParameters
-> ChainStateType tx
-> HeadId
-> HeadSeed
-> [Party]
-> StateChanged tx
Outcome.HeadOpened (HeadParameters
 -> SimpleChainState
 -> HeadId
 -> HeadSeed
 -> [Party]
 -> StateChanged SimpleTx)
-> Gen HeadParameters
-> Gen
     (SimpleChainState
      -> HeadId -> HeadSeed -> [Party] -> StateChanged SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen HeadParameters
forall a. Arbitrary a => Gen a
arbitrary Gen
  (SimpleChainState
   -> HeadId -> HeadSeed -> [Party] -> StateChanged SimpleTx)
-> Gen SimpleChainState
-> Gen (HeadId -> HeadSeed -> [Party] -> StateChanged SimpleTx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SimpleChainState
forall a. Arbitrary a => Gen a
arbitrary Gen (HeadId -> HeadSeed -> [Party] -> StateChanged SimpleTx)
-> Gen HeadId -> Gen (HeadSeed -> [Party] -> StateChanged SimpleTx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary Gen (HeadSeed -> [Party] -> StateChanged SimpleTx)
-> Gen HeadSeed -> Gen ([Party] -> StateChanged SimpleTx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen HeadSeed
forall a. Arbitrary a => Gen a
arbitrary Gen ([Party] -> StateChanged SimpleTx)
-> Gen [Party] -> Gen (StateChanged SimpleTx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen [Party]
forall a. Arbitrary a => Gen a
arbitrary

          let generateSnapshot :: IO (StateChanged SimpleTx)
generateSnapshot = Gen (StateChanged SimpleTx) -> IO (StateChanged SimpleTx)
forall a. Gen a -> IO a
generate (Gen (StateChanged SimpleTx) -> IO (StateChanged SimpleTx))
-> Gen (StateChanged SimpleTx) -> IO (StateChanged SimpleTx)
forall a b. (a -> b) -> a -> b
$ (HeadId
-> Maybe (Snapshot SimpleTx)
-> MultiSignature (Snapshot SimpleTx)
-> StateChanged SimpleTx
forall tx.
HeadId
-> Maybe (Snapshot tx)
-> MultiSignature (Snapshot tx)
-> StateChanged tx
Outcome.SnapshotConfirmed HeadId
openedHeadId (Maybe (Snapshot SimpleTx)
 -> MultiSignature (Snapshot SimpleTx) -> StateChanged SimpleTx)
-> (Snapshot SimpleTx -> Maybe (Snapshot SimpleTx))
-> Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx)
-> StateChanged SimpleTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just (Snapshot SimpleTx
 -> MultiSignature (Snapshot SimpleTx) -> StateChanged SimpleTx)
-> Gen (Snapshot SimpleTx)
-> Gen
     (MultiSignature (Snapshot SimpleTx) -> StateChanged SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Snapshot SimpleTx)
forall a. Arbitrary a => Gen a
arbitrary) Gen (MultiSignature (Snapshot SimpleTx) -> StateChanged SimpleTx)
-> Gen (MultiSignature (Snapshot SimpleTx))
-> Gen (StateChanged SimpleTx)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (MultiSignature (Snapshot SimpleTx))
forall a. Arbitrary a => Gen a
arbitrary
          snapShotConfirmedMsg :: StateChanged SimpleTx
snapShotConfirmedMsg@Outcome.SnapshotConfirmed{$sel:snapshot:NetworkConnected :: forall tx. StateChanged tx -> Maybe (Snapshot tx)
snapshot = Just Snapshot{UTxOType SimpleTx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo :: UTxOType SimpleTx
utxo, Maybe (UTxOType SimpleTx)
$sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit :: Maybe (UTxOType SimpleTx)
utxoToCommit}} <- IO (StateChanged SimpleTx)
generateSnapshot

          [StateEvent SimpleTx]
stateEvents :: [StateEvent SimpleTx] <- Gen [StateEvent SimpleTx] -> IO [StateEvent SimpleTx]
forall a. Gen a -> IO a
generate (Gen [StateEvent SimpleTx] -> IO [StateEvent SimpleTx])
-> Gen [StateEvent SimpleTx] -> IO [StateEvent SimpleTx]
forall a b. (a -> b) -> a -> b
$ (StateChanged SimpleTx -> Gen (StateEvent SimpleTx))
-> [StateChanged SimpleTx] -> Gen [StateEvent SimpleTx]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM StateChanged SimpleTx -> Gen (StateEvent SimpleTx)
forall tx. StateChanged tx -> Gen (StateEvent tx)
genStateEvent [StateChanged SimpleTx
headIsOpenMsg, StateChanged SimpleTx
snapShotConfirmedMsg]
          let eventSource :: EventSource (StateEvent SimpleTx) IO
eventSource = [StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource [StateEvent SimpleTx]
stateEvents

          let expectedUtxos :: Value
expectedUtxos = Set SimpleTxOut -> Value
forall a. ToJSON a => a -> Value
toJSON (Set SimpleTxOut -> Value) -> Set SimpleTxOut -> Value
forall a b. (a -> b) -> a -> b
$ Set SimpleTxOut
UTxOType SimpleTx
utxo Set SimpleTxOut -> Set SimpleTxOut -> Set SimpleTxOut
forall a. Semigroup a => a -> a -> a
<> Set SimpleTxOut -> Maybe (Set SimpleTxOut) -> Set SimpleTxOut
forall a. a -> Maybe a -> a
fromMaybe Set SimpleTxOut
forall a. Monoid a => a
mempty Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
utxoToCommit
          Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice EventSource (StateEvent SimpleTx) IO
eventSource Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ -> do
            HasCallStack => PortNumber -> (Value -> Maybe ()) -> IO ()
PortNumber -> (Value -> Maybe ()) -> IO ()
waitForValue PortNumber
port ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
v -> do
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"headStatus" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
Aeson.String Text
"Open")
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"snapshotUtxo" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just Value
expectedUtxos

          Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice EventSource (StateEvent SimpleTx) IO
eventSource Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ -> do
            HasCallStack => PortNumber -> (Value -> Maybe ()) -> IO ()
PortNumber -> (Value -> Maybe ()) -> IO ()
waitForValue PortNumber
port ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
v -> do
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"headStatus" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
Aeson.String Text
"Open")
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"snapshotUtxo" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just Value
expectedUtxos

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"sends an error when input cannot be decoded" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
      NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket Socket -> PortNumber -> IO ()
sendsAnErrorWhenInputCannotBeDecoded

    -- The snapshot decodes fine; it is forcing its
    -- accumulator that throws, and this server would do that while tracing the
    -- input -- on the log writer thread, taking logging and eventually the
    -- whole node with it. So the size has to be rejected as part of decoding.
    -- The assertion that matters here is that the connection survives and stays
    -- usable: a reply at all means nothing forced the accumulator.
    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"sends an error when a side-loaded snapshot exceeds the accumulator limit" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
      NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer ->
          (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
            Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ ->
              PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
con -> do
                ByteString
_greeting :: ByteString <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
con
                MultiSignature (Snapshot SimpleTx)
signatures <- Gen (MultiSignature (Snapshot SimpleTx))
-> IO (MultiSignature (Snapshot SimpleTx))
forall a. Gen a -> IO a
generate (forall a. Arbitrary a => Gen a
arbitrary @(MultiSignature (Snapshot SimpleTx)))
                let bigCount :: Int
bigCount = Int
Accumulator.maxAccumulatorSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                    oversized :: ByteString
oversized =
                      Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$
                        [Pair] -> Value
Aeson.object
                          [ Key
"tag" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String Text
"SideLoadSnapshot"
                          , Key
"snapshot"
                              Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
Aeson.object
                                [ Key
"tag" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String Text
"ConfirmedSnapshot"
                                , Key
"snapshot"
                                    Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
Aeson.object
                                      [ Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
testHeadId
                                      , Key
"version" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int
0 :: Int)
                                      , Key
"number" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int
1 :: Int)
                                      , Key
"confirmed" Key -> [SimpleTx] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ([] :: [SimpleTx])
                                      , Key
"utxo" Key -> Set SimpleTxOut -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Integer] -> UTxOType SimpleTx
utxoRefs [Integer
1 .. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bigCount]
                                      ]
                                , Key
"signatures" Key -> MultiSignature (Snapshot SimpleTx) -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= MultiSignature (Snapshot SimpleTx)
signatures
                                ]
                          ]
                Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendBinaryData Connection
con ByteString
oversized
                ByteString
msg <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
con
                case forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode @InvalidInput ByteString
msg of
                  Left{} -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to decode output " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall b a. (Show a, IsString b) => a -> b
show ByteString
msg
                  Right InvalidInput{String
reason :: String
$sel:reason:InvalidInput :: InvalidInput -> String
reason} ->
                    String
reason String -> String -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
Accumulator.maxAccumulatorSize
                -- Still alive and still serving.
                Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendBinaryData Connection
con (ByteString
"not a valid message" :: ByteString)
                ByteString
_ :: ByteString <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
con
                () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"CBOR encoding" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"sends a CBOR-encoded greeting when connecting with encoding=cbor" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer ->
            (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
              Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ ->
                PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?encoding=cbor&history=no" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
                  ByteString
bytes :: ByteString <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn
                  case forall a. FromCBOR a => ByteString -> Either DecoderError a
decodeFull' @(ApiMessage SimpleTx) ByteString
bytes of
                    Left DecoderError
err -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to decode CBOR greeting: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DecoderError -> String
forall b a. (Show a, IsString b) => a -> b
show DecoderError
err
                    Right ApiGreetings{} -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    Right ApiMessage SimpleTx
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected ApiGreetings, but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ApiMessage SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show ApiMessage SimpleTx
other

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"sends server outputs CBOR-encoded to clients connected with encoding=cbor" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer ->
            (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
              Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink{HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent :: forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent :: HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent}, Server SimpleTx IO
_) ->
                PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?encoding=cbor&history=no" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
                  ByteString
_greeting :: ByteString <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn
                  StateEvent SimpleTx
arbitraryEvent <- Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate Gen (StateEvent SimpleTx)
genStateEventForApi
                  let expectedMessage :: TimedServerOutput SimpleTx
expectedMessage =
                        TimedServerOutput SimpleTx
-> Maybe (TimedServerOutput SimpleTx) -> TimedServerOutput SimpleTx
forall a. a -> Maybe a -> a
fromMaybe (Text -> TimedServerOutput SimpleTx
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"failed to convert stateEvent") (Maybe (TimedServerOutput SimpleTx) -> TimedServerOutput SimpleTx)
-> Maybe (TimedServerOutput SimpleTx) -> TimedServerOutput SimpleTx
forall a b. (a -> b) -> a -> b
$
                          Maybe (Snapshot SimpleTx)
-> StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent Maybe (Snapshot SimpleTx)
forall a. Maybe a
Nothing StateEvent SimpleTx
arbitraryEvent
                  StateEvent SimpleTx -> IO ()
HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent StateEvent SimpleTx
arbitraryEvent
                  ByteString
bytes :: ByteString <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn
                  case forall a. FromCBOR a => ByteString -> Either DecoderError a
decodeFull' @(ApiMessage SimpleTx) ByteString
bytes of
                    Left DecoderError
err -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to decode CBOR server output: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DecoderError -> String
forall b a. (Show a, IsString b) => a -> b
show DecoderError
err
                    Right (ApiTimedServerOutput TimedServerOutput SimpleTx
timedOutput) -> TimedServerOutput SimpleTx
timedOutput TimedServerOutput SimpleTx -> TimedServerOutput SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` TimedServerOutput SimpleTx
expectedMessage
                    Right ApiMessage SimpleTx
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected ApiTimedServerOutput, but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ApiMessage SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show ApiMessage SimpleTx
other

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"accepts CBOR-encoded client inputs when connected with encoding=cbor" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer ->
            (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port -> do
              TQueue (ClientInput SimpleTx)
inputs <- String -> IO (TQueue IO (ClientInput SimpleTx))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> m (TQueue m a)
newLabelledTQueueIO String
"cbor-inputs"
              let recordInput :: ClientInput SimpleTx -> IO ()
recordInput = STM () -> IO ()
STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM () -> IO ())
-> (ClientInput SimpleTx -> STM ())
-> ClientInput SimpleTx
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TQueue IO (ClientInput SimpleTx)
-> ClientInput SimpleTx -> STM IO ()
forall a. TQueue IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> a -> STM m ()
writeTQueue TQueue (ClientInput SimpleTx)
TQueue IO (ClientInput SimpleTx)
inputs
              Maybe Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> (ClientInput SimpleTx -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerWithCallback (Socket -> Maybe Socket
forall a. a -> Maybe a
Just Socket
sock) PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) Tracer IO APIServerLog
tracer ClientInput SimpleTx -> IO ()
recordInput (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ ->
                PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?encoding=cbor&history=no" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
                  ByteString
_greeting :: ByteString <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn
                  Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendBinaryData Connection
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ClientInput SimpleTx -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' (ClientInput SimpleTx
forall tx. ClientInput tx
Init :: ClientInput SimpleTx)
                  NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
10 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM IO (ClientInput SimpleTx) -> IO (ClientInput SimpleTx)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TQueue IO (ClientInput SimpleTx) -> STM IO (ClientInput SimpleTx)
forall a. TQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue (ClientInput SimpleTx)
TQueue IO (ClientInput SimpleTx)
inputs) IO (ClientInput SimpleTx) -> ClientInput SimpleTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` ClientInput SimpleTx
forall tx. ClientInput tx
Init

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"sends a CBOR-encoded InvalidInput when input is not valid CBOR" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer ->
            (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
              Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ ->
                PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?encoding=cbor&history=no" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
                  ByteString
_greeting :: ByteString <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn
                  let garbage :: ByteString
garbage = ByteString
"not a valid CBOR message" :: ByteString
                  Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendBinaryData Connection
conn ByteString
garbage
                  ByteString
bytes :: ByteString <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn
                  case forall a. FromCBOR a => ByteString -> Either DecoderError a
decodeFull' @(ApiMessage SimpleTx) ByteString
bytes of
                    Left DecoderError
err -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to decode CBOR InvalidInput: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DecoderError -> String
forall b a. (Show a, IsString b) => a -> b
show DecoderError
err
                    Right (ApiInvalidInput InvalidInput{$sel:input:InvalidInput :: InvalidInput -> Text
input = Text
echoed}) ->
                      Text
echoed Text -> Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` ByteString -> Text
encodeBase16 ByteString
garbage
                    Right ApiMessage SimpleTx
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected ApiInvalidInput, but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ApiMessage SimpleTx -> String
forall b a. (Show a, IsString b) => a -> b
show ApiMessage SimpleTx
other

    -- The filter's own semantics live in 'Hydra.API.ServerOutputFilterSpec'.
    -- What matters here is the wiring that spec cannot reach: the address from
    -- the query string arriving at the filter, both output paths consulting
    -- it, and client messages bypassing it.
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"address filtering" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"consults the filter with the address from the query string" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer -> NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
20 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          StateEvent SimpleTx
event <- Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate Gen (StateEvent SimpleTx)
genStateEventForApi
          (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
            Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> ServerOutputFilter SimpleTx
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerWithFilter Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) (Text -> ServerOutputFilter SimpleTx
forall tx. Text -> ServerOutputFilter tx
onlyAddress Text
"addr_test1vp") Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink{HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent :: forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent :: HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent}, Server SimpleTx IO
_) ->
              PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?address=addr_test1vp" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
matching ->
                PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?address=addr_test1vq" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
other -> do
                  Natural -> Connection -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
Natural -> Connection -> (Value -> Maybe a) -> IO a
waitMatch Natural
20 Connection
matching ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (Value -> Bool) -> Value -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Bool
matchGreetings
                  Natural -> Connection -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
Natural -> Connection -> (Value -> Maybe a) -> IO a
waitMatch Natural
20 Connection
other ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (Value -> Bool) -> Value -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Bool
matchGreetings
                  StateEvent SimpleTx -> IO ()
HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent StateEvent SimpleTx
event
                  Natural -> Connection -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
Natural -> Connection -> (Value -> Maybe a) -> IO a
waitMatch Natural
20 Connection
matching ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (Value -> Bool) -> Value -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== TimedServerOutput SimpleTx -> Value
forall a. ToJSON a => a -> Value
toJSON (StateEvent SimpleTx -> TimedServerOutput SimpleTx
timedOutputOf StateEvent SimpleTx
event))
                  HasCallStack => Connection -> IO ()
Connection -> IO ()
receivesNothing Connection
other

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"drops rejected outputs from the live stream" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer -> NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
20 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          StateEvent SimpleTx
event <- Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate Gen (StateEvent SimpleTx)
genStateEventForApi
          (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
            Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> ServerOutputFilter SimpleTx
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerWithFilter Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) ServerOutputFilter SimpleTx
forall tx. ServerOutputFilter tx
rejectEverything Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink{HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent :: forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent :: HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent}, Server SimpleTx IO
_) ->
              PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?address=addr_test1vp" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
con -> do
                -- The greeting bypasses the filter, so it still arrives.
                Natural -> Connection -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
Natural -> Connection -> (Value -> Maybe a) -> IO a
waitMatch Natural
20 Connection
con ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (Value -> Bool) -> Value -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Bool
matchGreetings
                StateEvent SimpleTx -> IO ()
HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent StateEvent SimpleTx
event
                HasCallStack => Connection -> IO ()
Connection -> IO ()
receivesNothing Connection
con

      -- Replayed history goes through 'forwardHistory', a call site separate
      -- from the live stream. It is forwarded BEFORE the greeting, so this has
      -- to assert the first frame: waiting for the greeting would drain the
      -- very output under test and pass whatever the filter does (see the same
      -- trap noted for "does not echo history if client says no").
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"applies the filter to replayed history" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer -> NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
20 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          StateEvent SimpleTx
event <- Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate Gen (StateEvent SimpleTx)
genStateEventForApi
          (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
            Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> ServerOutputFilter SimpleTx
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerWithFilter Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource [StateEvent SimpleTx
event]) ServerOutputFilter SimpleTx
forall tx. ServerOutputFilter tx
allowEverythingServerOutputFilter Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ ->
              PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?history=yes&address=addr_test1vp" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
con ->
                HasCallStack => Connection -> IO Value
Connection -> IO Value
nextFrame Connection
con IO Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` TimedServerOutput SimpleTx -> Value
forall a. ToJSON a => a -> Value
toJSON (StateEvent SimpleTx -> TimedServerOutput SimpleTx
timedOutputOf StateEvent SimpleTx
event)
          (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
            Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> ServerOutputFilter SimpleTx
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerWithFilter Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource [StateEvent SimpleTx
event]) ServerOutputFilter SimpleTx
forall tx. ServerOutputFilter tx
rejectEverything Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ ->
              PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?history=yes&address=addr_test1vp" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
                HasCallStack => Connection -> IO Value
Connection -> IO Value
nextFrame (Connection -> IO Value) -> (Value -> IO ()) -> Connection -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Value -> (Value -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` Value -> Bool
matchGreetings)

      -- Without an address the filter must not be consulted at all, which is
      -- the branch every ordinary client takes.
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not filter a client that gave no address" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer -> NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
20 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          StateEvent SimpleTx
event <- Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate Gen (StateEvent SimpleTx)
genStateEventForApi
          (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
            Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> ServerOutputFilter SimpleTx
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerWithFilter Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) ServerOutputFilter SimpleTx
forall tx. ServerOutputFilter tx
rejectEverything Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink{HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent :: forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent :: HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent}, Server SimpleTx IO
_) ->
              PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
con -> do
                Natural -> Connection -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
Natural -> Connection -> (Value -> Maybe a) -> IO a
waitMatch Natural
20 Connection
con ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (Value -> Bool) -> Value -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Bool
matchGreetings
                StateEvent SimpleTx -> IO ()
HasEventId (StateEvent SimpleTx) => StateEvent SimpleTx -> IO ()
putEvent StateEvent SimpleTx
event
                Natural -> Connection -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
Natural -> Connection -> (Value -> Maybe a) -> IO a
waitMatch Natural
20 Connection
con ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (Value -> Bool) -> Value -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== TimedServerOutput SimpleTx -> Value
forall a. ToJSON a => a -> Value
toJSON (StateEvent SimpleTx -> TimedServerOutput SimpleTx
timedOutputOf StateEvent SimpleTx
event))

      -- A 'ClientMessage' carries no transaction to match an address against,
      -- so a filtered client must still receive it; otherwise an error or a
      -- rejected command would silently never reach it.
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"never filters client messages" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer -> NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
20 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          let message :: ClientMessage SimpleTx
              message :: ClientMessage SimpleTx
message = RejectedInputBecauseUnsynced{$sel:clientInput:CommandFailed :: ClientInput SimpleTx
clientInput = ClientInput SimpleTx
forall tx. ClientInput tx
Init, $sel:drift:CommandFailed :: NominalDiffTime
drift = NominalDiffTime
1}
          (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port ->
            Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> ServerOutputFilter SimpleTx
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerWithFilter Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) ServerOutputFilter SimpleTx
forall tx. ServerOutputFilter tx
rejectEverything Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO
_, Server SimpleTx IO
server) ->
              PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?address=addr_test1vp" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
con -> do
                Natural -> Connection -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
Natural -> Connection -> (Value -> Maybe a) -> IO a
waitMatch Natural
20 Connection
con ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (Value -> Bool) -> Value -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Bool
matchGreetings
                Server SimpleTx IO -> ClientMessage SimpleTx -> IO ()
forall tx (m :: * -> *). Server tx m -> ClientMessage tx -> m ()
sendMessage Server SimpleTx IO
server ClientMessage SimpleTx
message
                Natural -> Connection -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
Natural -> Connection -> (Value -> Maybe a) -> IO a
waitMatch Natural
20 Connection
con ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (Value -> Bool) -> Value -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== ClientMessage SimpleTx -> Value
forall a. ToJSON a => a -> Value
toJSON ClientMessage SimpleTx
message)

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"connection query string" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      let configFor :: ByteString -> ServerOutputConfig
configFor = Query -> ServerOutputConfig
mkServerOutputConfig (Query -> ServerOutputConfig)
-> (ByteString -> Query) -> ByteString -> ServerOutputConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Query
queryParamsOf
          addressIn :: ByteString -> WithAddressedTx
addressIn = ServerOutputConfig -> WithAddressedTx
addressInTx (ServerOutputConfig -> WithAddressedTx)
-> (ByteString -> ServerOutputConfig)
-> ByteString
-> WithAddressedTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ServerOutputConfig
configFor
          utxoIn :: ByteString -> WithUTxO
utxoIn = ServerOutputConfig -> WithUTxO
utxoInSnapshot (ServerOutputConfig -> WithUTxO)
-> (ByteString -> ServerOutputConfig) -> ByteString -> WithUTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ServerOutputConfig
configFor
          encodingIn :: ByteString -> ApiEncoding
encodingIn = ServerOutputConfig -> ApiEncoding
encoding (ServerOutputConfig -> ApiEncoding)
-> (ByteString -> ServerOutputConfig) -> ByteString -> ApiEncoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ServerOutputConfig
configFor

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"filters on the given address" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        ByteString -> WithAddressedTx
addressIn ByteString
"/?address=addr_test1vp" WithAddressedTx -> WithAddressedTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text -> WithAddressedTx
WithAddressedTx Text
"addr_test1vp"

      -- An empty filter would match nothing, since addresses are compared
      -- exactly, and the client would silently see no transaction outputs.
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ignores an address without a value" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        ByteString -> WithAddressedTx
addressIn ByteString
"/?address=" WithAddressedTx -> WithAddressedTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` WithAddressedTx
WithoutAddressedTx
        ByteString -> WithAddressedTx
addressIn ByteString
"/?address" WithAddressedTx -> WithAddressedTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` WithAddressedTx
WithoutAddressedTx

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"skips valueless addresses in favour of a later one" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        ByteString -> WithAddressedTx
addressIn ByteString
"/?address&address=addr_test1vp" WithAddressedTx -> WithAddressedTx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text -> WithAddressedTx
WithAddressedTx Text
"addr_test1vp"

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"omits the snapshot utxo on request" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        ByteString -> WithUTxO
utxoIn ByteString
"/?snapshot-utxo=no" WithUTxO -> WithUTxO -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` WithUTxO
WithoutUTxO
        ByteString -> WithUTxO
utxoIn ByteString
"/" WithUTxO -> WithUTxO -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` WithUTxO
WithUTxO

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"switches to CBOR on request" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        ByteString -> ApiEncoding
encodingIn ByteString
"/?encoding=cbor" ApiEncoding -> ApiEncoding -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` ApiEncoding
CborEncoding
        ByteString -> ApiEncoding
encodingIn ByteString
"/" ApiEncoding -> ApiEncoding -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` ApiEncoding
JsonEncoding

      -- Replay is opt-in: only an explicit 'yes' turns it on, so 'history=no'
      -- and no parameter at all behave identically.
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"serves history on request" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        Query -> Bool
shouldServeHistory (ByteString -> Query
queryParamsOf ByteString
"/?history=yes") Bool -> Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Bool
True
        Query -> Bool
shouldServeHistory (ByteString -> Query
queryParamsOf ByteString
"/?history=no") Bool -> Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Bool
False
        Query -> Bool
shouldServeHistory (ByteString -> Query
queryParamsOf ByteString
"/") Bool -> Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Bool
False

      -- A malformed query used to raise a parse exception during connection
      -- setup; now it just leaves the client with the defaults.
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"falls back to the defaults on a malformed query" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        ByteString -> ServerOutputConfig
configFor ByteString
"/?%%&=&address"
          ServerOutputConfig -> ServerOutputConfig -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` ServerOutputConfig{$sel:utxoInSnapshot:ServerOutputConfig :: WithUTxO
utxoInSnapshot = WithUTxO
WithUTxO, $sel:addressInTx:ServerOutputConfig :: WithAddressedTx
addressInTx = WithAddressedTx
WithoutAddressedTx, $sel:encoding:ServerOutputConfig :: ApiEncoding
encoding = ApiEncoding
JsonEncoding}

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"TLS support" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"accepts TLS connections when configured" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer ->
          (Socket -> PortNumber -> IO ()) -> IO ()
forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket ((Socket -> PortNumber -> IO ()) -> IO ())
-> (Socket -> PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock PortNumber
port -> do
            let config :: APIServerConfig
config =
                  APIServerConfig
                    { $sel:host:APIServerConfig :: IP
host = IP
"127.0.0.1"
                    , PortNumber
port :: PortNumber
$sel:port:APIServerConfig :: PortNumber
port
                    , $sel:tlsCertPath:APIServerConfig :: Maybe String
tlsCertPath = String -> Maybe String
forall a. a -> Maybe a
Just String
"test/tls/certificate.pem"
                    , $sel:tlsKeyPath:APIServerConfig :: Maybe String
tlsKeyPath = String -> Maybe String
forall a. a -> Maybe a
Just String
"test/tls/key.pem"
                    , $sel:apiTransactionTimeout:APIServerConfig :: ApiTransactionTimeout
apiTransactionTimeout = ApiTransactionTimeout
1000000
                    , $sel:listenSocket:APIServerConfig :: Maybe Socket
listenSocket = Socket -> Maybe Socket
forall a. a -> Maybe a
Just Socket
sock
                    }
                initialChainState :: SimpleChainState
initialChainState = SimpleChainState
0
            forall tx.
IsChainState tx =>
APIServerConfig
-> RunOptions
-> Environment
-> Party
-> EventSource (StateEvent tx) IO
-> Tracer IO APIServerLog
-> ChainStateType tx
-> Chain tx IO
-> PParams LedgerEra
-> ServerOutputFilter tx
-> IO (Maybe StallReason)
-> (ClientInput tx -> IO ())
-> ((EventSink (StateEvent tx) IO, Server tx IO) -> IO ())
-> IO ()
withAPIServer @SimpleTx APIServerConfig
config RunOptions
defaultRunOptions Environment
testEnvironment Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) Tracer IO APIServerLog
tracer ChainStateType SimpleTx
SimpleChainState
initialChainState Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle PParams LedgerEra
defaultPParams ServerOutputFilter SimpleTx
forall tx. ServerOutputFilter tx
allowEverythingServerOutputFilter (Maybe StallReason -> IO (Maybe StallReason)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe StallReason
forall a. Maybe a
Nothing) ClientInput SimpleTx -> IO ()
forall (m :: * -> *) a. Applicative m => a -> m ()
noop (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ -> do
              let clientParams :: ClientParams
clientParams = String -> ByteString -> ClientParams
defaultParamsClient String
"127.0.0.1" ByteString
""
                  allowAnyParams :: ClientParams
allowAnyParams =
                    ClientParams
clientParams{clientHooks = (clientHooks clientParams){onServerCertificate = \CertificateStore
_ ValidationCache
_ ServiceID
_ CertificateChain
_ -> [FailedReason] -> IO [FailedReason]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []}}
              ClientParams
-> String
-> String
-> ByteString
-> [(ByteString, ByteString)]
-> ((Connection, SockAddr) -> IO ())
-> IO ()
forall (m :: * -> *) r.
(MonadIO m, MonadMask m) =>
ClientParams
-> String
-> String
-> ByteString
-> [(ByteString, ByteString)]
-> ((Connection, SockAddr) -> m r)
-> m r
WSS.connect ClientParams
allowAnyParams String
"127.0.0.1" (PortNumber -> String
forall b a. (Show a, IsString b) => a -> b
show PortNumber
port) ByteString
"/" [] (((Connection, SockAddr) -> IO ()) -> IO ())
-> ((Connection, SockAddr) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Connection
conn, SockAddr
_) -> do
                Natural -> Connection -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
Natural -> Connection -> (Value -> Maybe a) -> IO a
waitMatch Natural
5 Connection
conn ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (Value -> Bool) -> Value -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Bool
matchGreetings

    -- 'mkTimedServerOutputFromStateEvent' decides which internal state changes
    -- reach clients and as what. Every other test of the output pipeline
    -- computes its expectation by calling that same function, so it cannot
    -- catch a mapping that sends the wrong output or silently stops surfacing
    -- one. Hence a table naming each translation, checked against the
    -- constructors that actually exist.
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"state change to client output" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"classifies exactly the state changes that exist" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        [String]
actual <- IO [String]
stateChangeConstructors
        [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ((String, Maybe Text) -> String
forall a b. (a, b) -> a
fst ((String, Maybe Text) -> String)
-> [(String, Maybe Text)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, Maybe Text)]
surfacedOutputs) [String] -> [String] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [String] -> [String]
forall a. Ord a => [a] -> [a]
sort [String]
actual

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"translates each state change to its expected output" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        [(String, StateChanged SimpleTx)]
samples <- IO [(String, StateChanged SimpleTx)]
sampleStateChanges
        [(String, StateChanged SimpleTx)]
-> ((String, StateChanged SimpleTx) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, StateChanged SimpleTx)]
samples (((String, StateChanged SimpleTx) -> IO ()) -> IO ())
-> ((String, StateChanged SimpleTx) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
name, StateChanged SimpleTx
stateChanged) -> do
          Maybe Text
expected <-
            IO (Maybe Text)
-> (Maybe Text -> IO (Maybe Text))
-> Maybe (Maybe Text)
-> IO (Maybe Text)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO (Maybe Text)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO (Maybe Text)) -> String -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ String
"state change " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not in surfacedOutputs") Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Maybe Text) -> IO (Maybe Text))
-> Maybe (Maybe Text) -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$
              String -> [(String, Maybe Text)] -> Maybe (Maybe Text)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup String
name [(String, Maybe Text)]
surfacedOutputs
          StateEvent SimpleTx
event <- Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate (Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx))
-> Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a b. (a -> b) -> a -> b
$ StateChanged SimpleTx -> Gen (StateEvent SimpleTx)
forall tx. StateChanged tx -> Gen (StateEvent tx)
genStateEvent StateChanged SimpleTx
stateChanged
          let actual :: Maybe Text
actual = TimedServerOutput SimpleTx -> Text
outputTagOf (TimedServerOutput SimpleTx -> Text)
-> Maybe (TimedServerOutput SimpleTx) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Snapshot SimpleTx)
-> StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent (Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
aSeenSnapshot) StateEvent SimpleTx
event
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe Text
actual Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
expected) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> String
forall b a. (Show a, IsString b) => a -> b
show Maybe Text
expected String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> String
forall b a. (Show a, IsString b) => a -> b
show Maybe Text
actual

      -- The table above compares tags, which cannot see inside a payload. These
      -- are the three arms that rename or derive a field rather than copying
      -- it, so they are where a wrong wiring survives a matching tag.
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not swap the two UTxO sets of a partial fanout" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let distributed :: UTxOType SimpleTx
distributed = [Integer] -> UTxOType SimpleTx
utxoRefs [Integer
1, Integer
2]
            remaining :: UTxOType SimpleTx
remaining = [Integer] -> UTxOType SimpleTx
utxoRefs [Integer
3]
        StateEvent SimpleTx
event <-
          Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate (Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx))
-> (StateChanged SimpleTx -> Gen (StateEvent SimpleTx))
-> StateChanged SimpleTx
-> IO (StateEvent SimpleTx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateChanged SimpleTx -> Gen (StateEvent SimpleTx)
forall tx. StateChanged tx -> Gen (StateEvent tx)
genStateEvent (StateChanged SimpleTx -> IO (StateEvent SimpleTx))
-> StateChanged SimpleTx -> IO (StateEvent SimpleTx)
forall a b. (a -> b) -> a -> b
$
            Outcome.HeadPartialFannedOut
              { $sel:headId:NetworkConnected :: HeadId
headId = HeadId
testHeadId
              , $sel:distributedOutputs:NetworkConnected :: UTxOType SimpleTx
distributedOutputs = Set SimpleTxOut
UTxOType SimpleTx
distributed
              , $sel:remainingOutputs:NetworkConnected :: UTxOType SimpleTx
remainingOutputs = Set SimpleTxOut
UTxOType SimpleTx
remaining
              , $sel:chainState:NetworkConnected :: ChainStateType SimpleTx
chainState = ChainStateType SimpleTx
SimpleChainState
0
              , $sel:mode:NetworkConnected :: FanoutMode SimpleTx
mode = FanoutMode SimpleTx
forall tx. FanoutMode tx
AutoDrain
              }
        case TimedServerOutput SimpleTx -> ServerOutput SimpleTx
forall tx. TimedServerOutput tx -> ServerOutput tx
output (TimedServerOutput SimpleTx -> ServerOutput SimpleTx)
-> Maybe (TimedServerOutput SimpleTx)
-> Maybe (ServerOutput SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Snapshot SimpleTx)
-> StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent Maybe (Snapshot SimpleTx)
forall a. Maybe a
Nothing StateEvent SimpleTx
event of
          Just HeadPartiallyFannedOut{UTxOType SimpleTx
distributedUTxO :: UTxOType SimpleTx
$sel:distributedUTxO:NetworkConnected :: forall tx. ServerOutput tx -> UTxOType tx
distributedUTxO, UTxOType SimpleTx
remainingUTxO :: UTxOType SimpleTx
$sel:remainingUTxO:NetworkConnected :: forall tx. ServerOutput tx -> UTxOType tx
remainingUTxO} -> do
            Set SimpleTxOut
UTxOType SimpleTx
distributedUTxO Set SimpleTxOut -> Set SimpleTxOut -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Set SimpleTxOut
distributed
            Set SimpleTxOut
UTxOType SimpleTx
remainingUTxO Set SimpleTxOut -> Set SimpleTxOut -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Set SimpleTxOut
remaining
          Maybe (ServerOutput SimpleTx)
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"expected HeadPartiallyFannedOut, got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe (ServerOutput SimpleTx) -> String
forall b a. (Show a, IsString b) => a -> b
show Maybe (ServerOutput SimpleTx)
other

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reports the transaction id of an applied transaction" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let tx :: SimpleTx
tx = Integer -> SimpleTx
aValidTx Integer
42
        StateEvent SimpleTx
event <-
          Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate (Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx))
-> (StateChanged SimpleTx -> Gen (StateEvent SimpleTx))
-> StateChanged SimpleTx
-> IO (StateEvent SimpleTx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateChanged SimpleTx -> Gen (StateEvent SimpleTx)
forall tx. StateChanged tx -> Gen (StateEvent tx)
genStateEvent (StateChanged SimpleTx -> IO (StateEvent SimpleTx))
-> StateChanged SimpleTx -> IO (StateEvent SimpleTx)
forall a b. (a -> b) -> a -> b
$
            Outcome.TransactionAppliedToLocalUTxO{$sel:headId:NetworkConnected :: HeadId
headId = HeadId
testHeadId, SimpleTx
tx :: SimpleTx
$sel:tx:NetworkConnected :: SimpleTx
tx}
        case TimedServerOutput SimpleTx -> ServerOutput SimpleTx
forall tx. TimedServerOutput tx -> ServerOutput tx
output (TimedServerOutput SimpleTx -> ServerOutput SimpleTx)
-> Maybe (TimedServerOutput SimpleTx)
-> Maybe (ServerOutput SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Snapshot SimpleTx)
-> StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent Maybe (Snapshot SimpleTx)
forall a. Maybe a
Nothing StateEvent SimpleTx
event of
          Just TxValid{TxIdType SimpleTx
transactionId :: TxIdType SimpleTx
$sel:transactionId:NetworkConnected :: forall tx. ServerOutput tx -> TxIdType tx
transactionId} -> Integer
TxIdType SimpleTx
transactionId Integer -> Integer -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId SimpleTx
tx
          Maybe (ServerOutput SimpleTx)
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"expected TxValid, got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe (ServerOutput SimpleTx) -> String
forall b a. (Show a, IsString b) => a -> b
show Maybe (ServerOutput SimpleTx)
other

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"derives the decommitted UTxO from the decommit transaction" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let decommitTx :: SimpleTx
decommitTx = Integer -> SimpleTx
aValidTx Integer
42
        StateEvent SimpleTx
event <-
          Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate (Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx))
-> (StateChanged SimpleTx -> Gen (StateEvent SimpleTx))
-> StateChanged SimpleTx
-> IO (StateEvent SimpleTx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateChanged SimpleTx -> Gen (StateEvent SimpleTx)
forall tx. StateChanged tx -> Gen (StateEvent tx)
genStateEvent (StateChanged SimpleTx -> IO (StateEvent SimpleTx))
-> StateChanged SimpleTx -> IO (StateEvent SimpleTx)
forall a b. (a -> b) -> a -> b
$
            Outcome.DecommitRecorded{$sel:headId:NetworkConnected :: HeadId
headId = HeadId
testHeadId, SimpleTx
decommitTx :: SimpleTx
$sel:decommitTx:NetworkConnected :: SimpleTx
decommitTx}
        case TimedServerOutput SimpleTx -> ServerOutput SimpleTx
forall tx. TimedServerOutput tx -> ServerOutput tx
output (TimedServerOutput SimpleTx -> ServerOutput SimpleTx)
-> Maybe (TimedServerOutput SimpleTx)
-> Maybe (ServerOutput SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Snapshot SimpleTx)
-> StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent Maybe (Snapshot SimpleTx)
forall a. Maybe a
Nothing StateEvent SimpleTx
event of
          Just DecommitRequested{UTxOType SimpleTx
utxoToDecommit :: UTxOType SimpleTx
$sel:utxoToDecommit:NetworkConnected :: forall tx. ServerOutput tx -> UTxOType tx
utxoToDecommit} -> Set SimpleTxOut
UTxOType SimpleTx
utxoToDecommit Set SimpleTxOut -> Set SimpleTxOut -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SimpleTx -> UTxOType SimpleTx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx SimpleTx
decommitTx
          Maybe (ServerOutput SimpleTx)
other -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"expected DecommitRequested, got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe (ServerOutput SimpleTx) -> String
forall b a. (Show a, IsString b) => a -> b
show Maybe (ServerOutput SimpleTx)
other

      -- Why the seen-snapshot argument exists: on the normal signing path a
      -- 'SnapshotConfirmed' carries no snapshot of its own, so with none seen
      -- there is nothing to send and the client hears nothing at all.
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cannot surface a confirmed snapshot it has never seen" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        StateEvent SimpleTx
event <-
          Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx)
forall a. Gen a -> IO a
generate (Gen (StateEvent SimpleTx) -> IO (StateEvent SimpleTx))
-> (StateChanged SimpleTx -> Gen (StateEvent SimpleTx))
-> StateChanged SimpleTx
-> IO (StateEvent SimpleTx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateChanged SimpleTx -> Gen (StateEvent SimpleTx)
forall tx. StateChanged tx -> Gen (StateEvent tx)
genStateEvent (StateChanged SimpleTx -> IO (StateEvent SimpleTx))
-> StateChanged SimpleTx -> IO (StateEvent SimpleTx)
forall a b. (a -> b) -> a -> b
$
            Outcome.SnapshotConfirmed{$sel:headId:NetworkConnected :: HeadId
headId = HeadId
testHeadId, $sel:snapshot:NetworkConnected :: Maybe (Snapshot SimpleTx)
snapshot = Maybe (Snapshot SimpleTx)
forall a. Maybe a
Nothing, $sel:signatures:NetworkConnected :: MultiSignature (Snapshot SimpleTx)
signatures = MultiSignature (Snapshot SimpleTx)
forall a. Monoid a => a
mempty}
        Maybe (Snapshot SimpleTx)
-> StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent Maybe (Snapshot SimpleTx)
forall a. Maybe a
Nothing StateEvent SimpleTx
event Maybe (TimedServerOutput SimpleTx)
-> (Maybe (TimedServerOutput SimpleTx) -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` Maybe (TimedServerOutput SimpleTx) -> Bool
forall a. Maybe a -> Bool
isNothing
        TimedServerOutput SimpleTx -> Text
outputTagOf
          (TimedServerOutput SimpleTx -> Text)
-> Maybe (TimedServerOutput SimpleTx) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Snapshot SimpleTx)
-> StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent (Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just Snapshot SimpleTx
aSeenSnapshot) StateEvent SimpleTx
event
            Maybe Text -> Maybe Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"SnapshotConfirmed"

    -- Read models served by the HTTP API. A wrong arm in either fails
    -- silently: deposits stop being draftable, or 'Greetings' reports the
    -- wrong connectivity.
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"projectCommitInfo" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"allows committing once the head is open" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        CommitInfo -> StateChanged SimpleTx -> CommitInfo
forall tx. CommitInfo -> StateChanged tx -> CommitInfo
projectCommitInfo CommitInfo
CannotCommit StateChanged SimpleTx
anOpenedHead CommitInfo -> CommitInfo -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` HeadId -> CommitInfo
IncrementalCommit HeadId
testHeadId

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"stops allowing commits once the head is closed" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        CommitInfo -> StateChanged SimpleTx -> CommitInfo
forall tx. CommitInfo -> StateChanged tx -> CommitInfo
projectCommitInfo (HeadId -> CommitInfo
IncrementalCommit HeadId
testHeadId) StateChanged SimpleTx
aClosedHead CommitInfo -> CommitInfo -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` CommitInfo
CannotCommit

      -- A rotated event log replays as a single 'Checkpoint', so the head id
      -- has to be recoverable from it rather than only from 'HeadOpened'.
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"recovers the head id from a checkpoint of an open head" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        CommitInfo -> StateChanged SimpleTx -> CommitInfo
forall tx. CommitInfo -> StateChanged tx -> CommitInfo
projectCommitInfo CommitInfo
CannotCommit (NodeState SimpleTx -> StateChanged SimpleTx
forall tx. NodeState tx -> StateChanged tx
Outcome.Checkpoint (NodeState SimpleTx -> StateChanged SimpleTx)
-> NodeState SimpleTx -> StateChanged SimpleTx
forall a b. (a -> b) -> a -> b
$ [Party] -> NodeState SimpleTx
inOpenState [Party
alice])
          CommitInfo -> CommitInfo -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` HeadId -> CommitInfo
IncrementalCommit HeadId
testHeadId

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not allow commits from a checkpoint of a head that is not open" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        CommitInfo -> StateChanged SimpleTx -> CommitInfo
forall tx. CommitInfo -> StateChanged tx -> CommitInfo
projectCommitInfo (HeadId -> CommitInfo
IncrementalCommit HeadId
testHeadId) (NodeState SimpleTx -> StateChanged SimpleTx
forall tx. NodeState tx -> StateChanged tx
Outcome.Checkpoint NodeState SimpleTx
inIdleState)
          CommitInfo -> CommitInfo -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` CommitInfo
CannotCommit

      -- Seeded from both verdicts: an arm that sets the value it already
      -- holds is invisible from one side only.
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"leaves the decision untouched for every unrelated state change" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        [(String, StateChanged SimpleTx)]
others <- [String] -> IO [(String, StateChanged SimpleTx)]
stateChangesOtherThan [String
"Checkpoint", String
"HeadOpened", String
"HeadClosed"]
        [(String, StateChanged SimpleTx)]
-> ((String, StateChanged SimpleTx) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, StateChanged SimpleTx)]
others (((String, StateChanged SimpleTx) -> IO ()) -> IO ())
-> ((String, StateChanged SimpleTx) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
name, StateChanged SimpleTx
stateChanged) ->
          [CommitInfo] -> (CommitInfo -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [CommitInfo
CannotCommit, HeadId -> CommitInfo
IncrementalCommit HeadId
testHeadId] ((CommitInfo -> IO ()) -> IO ()) -> (CommitInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CommitInfo
priorValue ->
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CommitInfo -> StateChanged SimpleTx -> CommitInfo
forall tx. CommitInfo -> StateChanged tx -> CommitInfo
projectCommitInfo CommitInfo
priorValue StateChanged SimpleTx
stateChanged CommitInfo -> CommitInfo -> Bool
forall a. Eq a => a -> a -> Bool
== CommitInfo
priorValue) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" changed the commit info from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CommitInfo -> String
forall b a. (Show a, IsString b) => a -> b
show CommitInfo
priorValue

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"projectNetworkInfo" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"records the network as connected and disconnected" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        NetworkInfo -> Bool
networkConnected (NetworkInfo -> StateChanged Any -> NetworkInfo
forall tx. NetworkInfo -> StateChanged tx -> NetworkInfo
projectNetworkInfo NetworkInfo
disconnected StateChanged Any
forall tx. StateChanged tx
Outcome.NetworkConnected) Bool -> Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Bool
True
        NetworkInfo -> Bool
networkConnected (NetworkInfo -> StateChanged Any -> NetworkInfo
forall tx. NetworkInfo -> StateChanged tx -> NetworkInfo
projectNetworkInfo NetworkInfo
connected StateChanged Any
forall tx. StateChanged tx
Outcome.NetworkDisconnected) Bool -> Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Bool
False

      -- Peers are only known through the network, so a disconnect has to clear
      -- them rather than leave stale ones behind.
      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"forgets all peers when the network disconnects" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        NetworkInfo -> Map Host Bool
peersInfo (NetworkInfo -> StateChanged Any -> NetworkInfo
forall tx. NetworkInfo -> StateChanged tx -> NetworkInfo
projectNetworkInfo NetworkInfo
connectedTo StateChanged Any
forall tx. StateChanged tx
Outcome.NetworkDisconnected) Map Host Bool -> Map Host Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Map Host Bool
forall a. Monoid a => a
mempty

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tracks each peer separately" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let afterBoth :: NetworkInfo
afterBoth =
              NetworkInfo -> StateChanged Any -> NetworkInfo
forall tx. NetworkInfo -> StateChanged tx -> NetworkInfo
projectNetworkInfo NetworkInfo
connected Outcome.PeerConnected{$sel:peer:NetworkConnected :: Host
peer = Host
peerA}
                NetworkInfo -> (NetworkInfo -> NetworkInfo) -> NetworkInfo
forall a b. a -> (a -> b) -> b
& (NetworkInfo -> StateChanged Any -> NetworkInfo)
-> StateChanged Any -> NetworkInfo -> NetworkInfo
forall a b c. (a -> b -> c) -> b -> a -> c
flip NetworkInfo -> StateChanged Any -> NetworkInfo
forall tx. NetworkInfo -> StateChanged tx -> NetworkInfo
projectNetworkInfo Outcome.PeerConnected{$sel:peer:NetworkConnected :: Host
peer = Host
peerB}
                NetworkInfo -> (NetworkInfo -> NetworkInfo) -> NetworkInfo
forall a b. a -> (a -> b) -> b
& (NetworkInfo -> StateChanged Any -> NetworkInfo)
-> StateChanged Any -> NetworkInfo -> NetworkInfo
forall a b c. (a -> b -> c) -> b -> a -> c
flip NetworkInfo -> StateChanged Any -> NetworkInfo
forall tx. NetworkInfo -> StateChanged tx -> NetworkInfo
projectNetworkInfo Outcome.PeerDisconnected{$sel:peer:NetworkConnected :: Host
peer = Host
peerB}
        NetworkInfo -> Map Host Bool
peersInfo NetworkInfo
afterBoth Map Host Bool -> Map Host Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [(Host, Bool)] -> Map Host Bool
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Host
peerA, Bool
True), (Host
peerB, Bool
False)]

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"leaves the info untouched for every unrelated state change" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        [(String, StateChanged SimpleTx)]
others <-
          [String] -> IO [(String, StateChanged SimpleTx)]
stateChangesOtherThan
            [String
"NetworkConnected", String
"NetworkDisconnected", String
"PeerConnected", String
"PeerDisconnected"]
        [(String, StateChanged SimpleTx)]
-> ((String, StateChanged SimpleTx) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, StateChanged SimpleTx)]
others (((String, StateChanged SimpleTx) -> IO ()) -> IO ())
-> ((String, StateChanged SimpleTx) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
name, StateChanged SimpleTx
stateChanged) ->
          [NetworkInfo] -> (NetworkInfo -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [NetworkInfo
connectedTo, NetworkInfo
disconnected] ((NetworkInfo -> IO ()) -> IO ())
-> (NetworkInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NetworkInfo
priorValue ->
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (NetworkInfo -> StateChanged SimpleTx -> NetworkInfo
forall tx. NetworkInfo -> StateChanged tx -> NetworkInfo
projectNetworkInfo NetworkInfo
priorValue StateChanged SimpleTx
stateChanged NetworkInfo -> NetworkInfo -> Bool
forall a. Eq a => a -> a -> Bool
== NetworkInfo
priorValue) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" changed the network info from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NetworkInfo -> String
forall b a. (Show a, IsString b) => a -> b
show NetworkInfo
priorValue

-- * State change translation fixtures

-- | Which client output each 'StateChanged' is surfaced as, by constructor
-- name; 'Nothing' for the ones deliberately kept internal. Adding a state
-- change without classifying it here fails
-- "classifies exactly the state changes that exist".
surfacedOutputs :: [(String, Maybe Text)]
surfacedOutputs :: [(String, Maybe Text)]
surfacedOutputs =
  [ (String
"HeadOpened", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"HeadIsOpen")
  , (String
"HeadClosed", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"HeadIsClosed")
  , (String
"HeadContested", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"HeadIsContested")
  , (String
"HeadIsReadyToFanout", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"ReadyToFanout")
  , (String
"HeadFannedOut", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"HeadIsFinalized")
  , (String
"HeadPartialFannedOut", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"HeadPartiallyFannedOut")
  , (String
"HeadFanoutInitiated", Maybe Text
forall a. Maybe a
Nothing)
  , (String
"HeadPartialFanoutSelected", Maybe Text
forall a. Maybe a
Nothing)
  , (String
"HeadFanoutReverted", Maybe Text
forall a. Maybe a
Nothing)
  , (String
"TransactionAppliedToLocalUTxO", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"TxValid")
  , (String
"TxInvalid", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"TxInvalid")
  , (String
"SnapshotConfirmed", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"SnapshotConfirmed")
  , (String
"IgnoredHeadInitializing", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"IgnoredHeadInitializing")
  , (String
"DecommitRecorded", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"DecommitRequested")
  , (String
"DecommitInvalid", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"DecommitInvalid")
  , (String
"DecommitApproved", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"DecommitApproved")
  , (String
"DecommitFinalized", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"DecommitFinalized")
  , (String
"DepositRecorded", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"CommitRecorded")
  , (String
"DepositActivated", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"DepositActivated")
  , (String
"DepositExpired", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"DepositExpired")
  , (String
"DepositRecovered", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"CommitRecovered")
  , (String
"CommitApproved", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"CommitApproved")
  , (String
"CommitFinalized", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"CommitFinalized")
  , (String
"NetworkConnected", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"NetworkConnected")
  , (String
"NetworkDisconnected", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"NetworkDisconnected")
  , (String
"NetworkVersionMismatch", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"NetworkVersionMismatch")
  , (String
"NetworkClusterIDMismatch", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"NetworkClusterIDMismatch")
  , (String
"NetworkBroadcastStalled", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"NetworkBroadcastStalled")
  , (String
"NetworkBroadcastResumed", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"NetworkBroadcastResumed")
  , (String
"PeerConnected", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"PeerConnected")
  , (String
"PeerDisconnected", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"PeerDisconnected")
  , (String
"TransactionReceived", Maybe Text
forall a. Maybe a
Nothing)
  , (String
"SnapshotRequested", Maybe Text
forall a. Maybe a
Nothing)
  , (String
"SnapshotRequestDecided", Maybe Text
forall a. Maybe a
Nothing)
  , (String
"PartySignedSnapshot", Maybe Text
forall a. Maybe a
Nothing)
  , (String
"ChainRolledBack", Maybe Text
forall a. Maybe a
Nothing)
  , (String
"TickObserved", Maybe Text
forall a. Maybe a
Nothing)
  , (String
"LocalStateCleared", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"SnapshotSideLoaded")
  , (String
"Checkpoint", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"EventLogRotated")
  , (String
"NodeUnsynced", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"NodeUnsynced")
  , (String
"NodeSynced", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"NodeSynced")
  ]

-- | One sample value per 'StateChanged' constructor, paired with its name.
sampleStateChanges :: IO [(String, Outcome.StateChanged SimpleTx)]
sampleStateChanges :: IO [(String, StateChanged SimpleTx)]
sampleStateChanges = do
  ADTArbitrary{[ConstructorArbitraryPair (StateChanged SimpleTx)]
adtCAPs :: [ConstructorArbitraryPair (StateChanged SimpleTx)]
adtCAPs :: forall a. ADTArbitrary a -> [ConstructorArbitraryPair a]
adtCAPs} <- Gen (ADTArbitrary (StateChanged SimpleTx))
-> IO (ADTArbitrary (StateChanged SimpleTx))
forall a. Gen a -> IO a
generate (Gen (ADTArbitrary (StateChanged SimpleTx))
 -> IO (ADTArbitrary (StateChanged SimpleTx)))
-> Gen (ADTArbitrary (StateChanged SimpleTx))
-> IO (ADTArbitrary (StateChanged SimpleTx))
forall a b. (a -> b) -> a -> b
$ Proxy (StateChanged SimpleTx)
-> Gen (ADTArbitrary (StateChanged SimpleTx))
forall a. ToADTArbitrary a => Proxy a -> Gen (ADTArbitrary a)
toADTArbitrary (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Outcome.StateChanged SimpleTx))
  [(String, StateChanged SimpleTx)]
-> IO [(String, StateChanged SimpleTx)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(String
capConstructor, StateChanged SimpleTx
capArbitrary) | ConstructorArbitraryPair{String
capConstructor :: String
capConstructor :: forall a. ConstructorArbitraryPair a -> String
capConstructor, StateChanged SimpleTx
capArbitrary :: StateChanged SimpleTx
capArbitrary :: forall a. ConstructorArbitraryPair a -> a
capArbitrary} <- [ConstructorArbitraryPair (StateChanged SimpleTx)]
adtCAPs]

stateChangeConstructors :: IO [String]
stateChangeConstructors :: IO [String]
stateChangeConstructors = ((String, StateChanged SimpleTx) -> String)
-> [(String, StateChanged SimpleTx)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, StateChanged SimpleTx) -> String
forall a b. (a, b) -> a
fst ([(String, StateChanged SimpleTx)] -> [String])
-> IO [(String, StateChanged SimpleTx)] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, StateChanged SimpleTx)]
sampleStateChanges

-- | Samples for every constructor except the named ones.
stateChangesOtherThan :: [String] -> IO [(String, Outcome.StateChanged SimpleTx)]
stateChangesOtherThan :: [String] -> IO [(String, StateChanged SimpleTx)]
stateChangesOtherThan [String]
handled =
  ((String, StateChanged SimpleTx) -> Bool)
-> [(String, StateChanged SimpleTx)]
-> [(String, StateChanged SimpleTx)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> [String] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [String]
handled) (String -> Bool)
-> ((String, StateChanged SimpleTx) -> String)
-> (String, StateChanged SimpleTx)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, StateChanged SimpleTx) -> String
forall a b. (a, b) -> a
fst) ([(String, StateChanged SimpleTx)]
 -> [(String, StateChanged SimpleTx)])
-> IO [(String, StateChanged SimpleTx)]
-> IO [(String, StateChanged SimpleTx)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, StateChanged SimpleTx)]
sampleStateChanges

outputTagOf :: TimedServerOutput SimpleTx -> Text
outputTagOf :: TimedServerOutput SimpleTx -> Text
outputTagOf TimedServerOutput SimpleTx
output =
  Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"<untagged>" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ TimedServerOutput SimpleTx -> Value
forall a. ToJSON a => a -> Value
toJSON TimedServerOutput SimpleTx
output Value -> Getting (First Text) Value Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"tag" ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Text) Value Text
forall t. AsValue t => Prism' t Text
Prism' Value Text
_String

aSeenSnapshot :: Snapshot SimpleTx
aSeenSnapshot :: Snapshot SimpleTx
aSeenSnapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
0 [] Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty

anOpenedHead :: Outcome.StateChanged SimpleTx
anOpenedHead :: StateChanged SimpleTx
anOpenedHead =
  Outcome.HeadOpened
    { $sel:parameters:NetworkConnected :: HeadParameters
parameters = Gen HeadParameters -> Int -> HeadParameters
forall a. Gen a -> Int -> a
generateWith Gen HeadParameters
forall a. Arbitrary a => Gen a
arbitrary Int
42
    , $sel:chainState:NetworkConnected :: ChainStateType SimpleTx
chainState = ChainStateType SimpleTx
SimpleChainState
0
    , $sel:headId:NetworkConnected :: HeadId
headId = HeadId
testHeadId
    , $sel:headSeed:NetworkConnected :: HeadSeed
headSeed = Gen HeadSeed -> Int -> HeadSeed
forall a. Gen a -> Int -> a
generateWith Gen HeadSeed
forall a. Arbitrary a => Gen a
arbitrary Int
42
    , $sel:parties:NetworkConnected :: [Party]
parties = [Party
alice]
    }

aClosedHead :: Outcome.StateChanged SimpleTx
aClosedHead :: StateChanged SimpleTx
aClosedHead =
  Outcome.HeadClosed
    { $sel:headId:NetworkConnected :: HeadId
headId = HeadId
testHeadId
    , $sel:snapshotNumber:NetworkConnected :: SnapshotNumber
snapshotNumber = SnapshotNumber
1
    , $sel:chainState:NetworkConnected :: ChainStateType SimpleTx
chainState = ChainStateType SimpleTx
SimpleChainState
0
    , $sel:contestationDeadline:NetworkConnected :: UTCTime
contestationDeadline = Gen UTCTime -> Int -> UTCTime
forall a. Gen a -> Int -> a
generateWith Gen UTCTime
forall a. Arbitrary a => Gen a
arbitrary Int
42
    }

peerA, peerB :: Host
peerA :: Host
peerA = Text -> PortNumber -> Host
Host Text
"10.0.0.1" PortNumber
5001
peerB :: Host
peerB = Text -> PortNumber -> Host
Host Text
"10.0.0.2" PortNumber
5002

connected, disconnected, connectedTo :: NetworkInfo
connected :: NetworkInfo
connected = NetworkInfo{$sel:networkConnected:NetworkInfo :: Bool
networkConnected = Bool
True, $sel:broadcastStall:NetworkInfo :: Maybe StallReason
broadcastStall = Maybe StallReason
forall a. Maybe a
Nothing, $sel:peersInfo:NetworkInfo :: Map Host Bool
peersInfo = Map Host Bool
forall a. Monoid a => a
mempty}
disconnected :: NetworkInfo
disconnected = NetworkInfo{$sel:networkConnected:NetworkInfo :: Bool
networkConnected = Bool
False, $sel:broadcastStall:NetworkInfo :: Maybe StallReason
broadcastStall = Maybe StallReason
forall a. Maybe a
Nothing, $sel:peersInfo:NetworkInfo :: Map Host Bool
peersInfo = Map Host Bool
forall a. Monoid a => a
mempty}
connectedTo :: NetworkInfo
connectedTo = NetworkInfo
connected{peersInfo = Map.fromList [(peerA, True)]}

sendsAnErrorWhenInputCannotBeDecoded :: Socket -> PortNumber -> Expectation
sendsAnErrorWhenInputCannotBeDecoded :: Socket -> PortNumber -> IO ()
sendsAnErrorWhenInputCannotBeDecoded Socket
sock PortNumber
port = do
  Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
"ServerSpec" ((Tracer IO APIServerLog -> IO ()) -> IO ())
-> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO APIServerLog
tracer ->
    Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) Tracer IO APIServerLog
tracer (((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
  -> IO ())
 -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
_ -> do
      PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
con -> do
        ByteString
_greeting :: ByteString <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
con
        Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendBinaryData Connection
con Text
invalidInput
        ByteString
msg <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
con
        case forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode @InvalidInput ByteString
msg of
          Left{} -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to decode output " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall b a. (Show a, IsString b) => a -> b
show ByteString
msg
          Right InvalidInput
resp ->
            InvalidInput
resp InvalidInput -> (InvalidInput -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
              InvalidInput{Text
$sel:input:InvalidInput :: InvalidInput -> Text
input :: Text
input} -> Text
input Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
invalidInput
 where
  invalidInput :: Text
invalidInput = Text
"not a valid message"

matchGreetings :: Aeson.Value -> Bool
matchGreetings :: Value -> Bool
matchGreetings Value
v =
  Maybe Value -> Bool
forall a. Maybe a -> Bool
isJust (Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"headStatus")
    Bool -> Bool -> Bool
&& Maybe Value -> Bool
forall a. Maybe a -> Bool
isJust (Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"hydraNodeVersion")
    Bool -> Bool -> Bool
&& Maybe Value -> Bool
forall a. Maybe a -> Bool
isJust (Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"me")

waitForClients :: (MonadSTM m, Ord a, Num a) => TVar m a -> m ()
waitForClients :: forall (m :: * -> *) a.
(MonadSTM m, Ord a, Num a) =>
TVar m a -> m ()
waitForClients TVar m a
semaphore = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar m a -> STM m a
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m a
semaphore STM m a -> (a -> STM m ()) -> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
n -> Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
2)

-- NOTE: this client runs indefinitely so it should be run within a context that won't
-- leak runaway threads
testClient :: TQueue IO Value -> TVar IO Int -> Connection -> IO ()
testClient :: TQueue IO Value -> TVar IO Int -> Connection -> IO ()
testClient TQueue IO Value
queue TVar IO Int
semaphore Connection
cnx = do
  STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar IO Int -> (Int -> Int) -> STM IO ()
forall a. TVar IO a -> (a -> a) -> STM IO ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar' TVar IO Int
semaphore (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ByteString
msg <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
cnx
  case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode ByteString
msg of
    Left{} -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to decode message " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall b a. (Show a, IsString b) => a -> b
show ByteString
msg
    Right Value
value -> do
      STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TQueue IO Value -> Value -> STM IO ()
forall a. TQueue IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> a -> STM m ()
writeTQueue TQueue IO Value
queue Value
value)
      TQueue IO Value -> TVar IO Int -> Connection -> IO ()
testClient TQueue IO Value
queue TVar IO Int
semaphore Connection
cnx

dummyChainHandle :: Chain tx IO
dummyChainHandle :: forall tx. Chain tx IO
dummyChainHandle =
  Chain
    { $sel:postTx:Chain :: MonadThrow IO => PostChainTx tx -> IO ()
postTx = \PostChainTx tx
_ -> Text -> IO ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected call to postTx"
    , $sel:draftDepositTx:Chain :: MonadThrow IO =>
HeadId
-> PParams LedgerEra
-> ConfirmedSnapshot tx
-> CommitBlueprintTx tx
-> UTCTime
-> Maybe AddressInEra
-> IO (Either (PostTxError tx) tx)
draftDepositTx = \HeadId
_ -> Text
-> PParams ConwayEra
-> ConfirmedSnapshot tx
-> CommitBlueprintTx tx
-> UTCTime
-> Maybe AddressInEra
-> IO (Either (PostTxError tx) tx)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected call to draftDepositTx"
    , $sel:submitTx:Chain :: MonadThrow IO => tx -> IO ()
submitTx = \tx
_ -> Text -> IO ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected call to submitTx"
    , $sel:checkNonADAAssets:Chain :: ConfirmedSnapshot tx -> Either Value ()
checkNonADAAssets = \ConfirmedSnapshot tx
_ -> Text -> Either Value ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected call to checkNonADAAssets"
    }

allowEverythingServerOutputFilter :: ServerOutputFilter tx
allowEverythingServerOutputFilter :: forall tx. ServerOutputFilter tx
allowEverythingServerOutputFilter =
  ServerOutputFilter
    { $sel:txContainsAddr:ServerOutputFilter :: TimedServerOutput tx -> Text -> Bool
txContainsAddr = \TimedServerOutput tx
_ Text
_ -> Bool
True
    }

-- | Rejects every output, so anything a client still receives reached it
-- without passing the filter.
rejectEverything :: ServerOutputFilter tx
rejectEverything :: forall tx. ServerOutputFilter tx
rejectEverything =
  ServerOutputFilter
    { $sel:txContainsAddr:ServerOutputFilter :: TimedServerOutput tx -> Text -> Bool
txContainsAddr = \TimedServerOutput tx
_ Text
_ -> Bool
False
    }

-- | Accepts outputs only for one address, so which address the server asked
-- about is observable from which client receives the output.
onlyAddress :: Text -> ServerOutputFilter tx
onlyAddress :: forall tx. Text -> ServerOutputFilter tx
onlyAddress Text
wanted =
  ServerOutputFilter
    { $sel:txContainsAddr:ServerOutputFilter :: TimedServerOutput tx -> Text -> Bool
txContainsAddr = \TimedServerOutput tx
_ Text
addr -> Text
addr Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
wanted
    }

-- | The 'TimedServerOutput' a client is expected to receive for an event.
timedOutputOf :: StateEvent SimpleTx -> TimedServerOutput SimpleTx
timedOutputOf :: StateEvent SimpleTx -> TimedServerOutput SimpleTx
timedOutputOf StateEvent SimpleTx
event =
  TimedServerOutput SimpleTx
-> Maybe (TimedServerOutput SimpleTx) -> TimedServerOutput SimpleTx
forall a. a -> Maybe a -> a
fromMaybe (Text -> TimedServerOutput SimpleTx
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"event does not map to a server output") (Maybe (TimedServerOutput SimpleTx) -> TimedServerOutput SimpleTx)
-> Maybe (TimedServerOutput SimpleTx) -> TimedServerOutput SimpleTx
forall a b. (a -> b) -> a -> b
$
    Maybe (Snapshot SimpleTx)
-> StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent Maybe (Snapshot SimpleTx)
forall a. Maybe a
Nothing StateEvent SimpleTx
event

-- | The next frame on a connection, without skipping over any.
nextFrame :: HasCallStack => Connection -> IO Aeson.Value
nextFrame :: HasCallStack => Connection -> IO Value
nextFrame Connection
con = do
  ByteString
bytes <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
con
  case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode' ByteString
bytes of
    Left String
err -> String -> IO Value
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO Value) -> String -> IO Value
forall a b. (a -> b) -> a -> b
$ String
"nextFrame failed to decode: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
    Right Value
value -> Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
value

-- | Assert that nothing more arrives on a connection. Used where the
-- expectation is an absence, so it has to wait out a full second rather than
-- return on a match.
receivesNothing :: HasCallStack => Connection -> Expectation
receivesNothing :: HasCallStack => Connection -> IO ()
receivesNothing Connection
con =
  DiffTime -> IO ByteString -> IO (Maybe ByteString)
forall a. DiffTime -> IO a -> IO (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
1 (Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
con) IO (Maybe ByteString) -> (Maybe ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe ByteString
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just (ByteString
msg :: LByteString) ->
      String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"expected no further message, but received: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall b a. (Show a, IsString b) => a -> b
show ByteString
msg

noop :: Applicative m => a -> m ()
noop :: forall (m :: * -> *) a. Applicative m => a -> m ()
noop = m () -> a -> m ()
forall a b. a -> b -> a
const (m () -> a -> m ()) -> m () -> a -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Allocate a listening socket on a free port and hand both it and its port
-- to the action. The server is then given the very socket it serves on, so the
-- port cannot be taken in the gap between choosing it and binding it. That gap
-- used to surface as a flaky 'RunServerException' carrying
-- "Address already in use".
withFreeServerSocket :: (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket :: forall a. (Socket -> PortNumber -> IO a) -> IO a
withFreeServerSocket Socket -> PortNumber -> IO a
action =
  IO (Int, Socket)
-> ((Int, Socket) -> IO ()) -> ((Int, Socket) -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket IO (Int, Socket)
Warp.openFreePort (Socket -> IO ()
close (Socket -> IO ())
-> ((Int, Socket) -> Socket) -> (Int, Socket) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Socket) -> Socket
forall a b. (a, b) -> b
snd) (((Int, Socket) -> IO a) -> IO a)
-> ((Int, Socket) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \(Int
p, Socket
sock) ->
    Socket -> PortNumber -> IO a
action Socket
sock (Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p)

withTestAPIServer ::
  Socket ->
  PortNumber ->
  Party ->
  EventSource (StateEvent SimpleTx) IO ->
  Tracer IO APIServerLog ->
  ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO) -> IO ()) ->
  IO ()
withTestAPIServer :: Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer Socket
sock PortNumber
port Party
actor EventSource (StateEvent SimpleTx) IO
eventSource Tracer IO APIServerLog
tracer =
  Maybe Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> (ClientInput SimpleTx -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerWithCallback (Socket -> Maybe Socket
forall a. a -> Maybe a
Just Socket
sock) PortNumber
port Party
actor EventSource (StateEvent SimpleTx) IO
eventSource Tracer IO APIServerLog
tracer ClientInput SimpleTx -> IO ()
forall (m :: * -> *) a. Applicative m => a -> m ()
noop

-- | Like 'withTestAPIServer' but lets the server bind @port@ itself. Only for
-- the test that asserts a second server on the same port is refused: handing
-- both servers one socket would let them both succeed.
withTestAPIServerBindingPort ::
  PortNumber ->
  Party ->
  EventSource (StateEvent SimpleTx) IO ->
  Tracer IO APIServerLog ->
  ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO) -> IO ()) ->
  IO ()
withTestAPIServerBindingPort :: PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerBindingPort PortNumber
port Party
actor EventSource (StateEvent SimpleTx) IO
eventSource Tracer IO APIServerLog
tracer =
  Maybe Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> (ClientInput SimpleTx -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerWithCallback Maybe Socket
forall a. Maybe a
Nothing PortNumber
port Party
actor EventSource (StateEvent SimpleTx) IO
eventSource Tracer IO APIServerLog
tracer ClientInput SimpleTx -> IO ()
forall (m :: * -> *) a. Applicative m => a -> m ()
noop

-- | Like 'withTestAPIServer', but with the live broadcast status the server
-- greets clients with under the test's control.
withTestAPIServerStalledWhen ::
  Socket ->
  IO (Maybe StallReason) ->
  PortNumber ->
  Party ->
  EventSource (StateEvent SimpleTx) IO ->
  Tracer IO APIServerLog ->
  ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO) -> IO ()) ->
  IO ()
withTestAPIServerStalledWhen :: Socket
-> IO (Maybe StallReason)
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerStalledWhen Socket
sock IO (Maybe StallReason)
queryBroadcastStall PortNumber
port Party
actor EventSource (StateEvent SimpleTx) IO
eventSource Tracer IO APIServerLog
tracer =
  forall tx.
IsChainState tx =>
APIServerConfig
-> RunOptions
-> Environment
-> Party
-> EventSource (StateEvent tx) IO
-> Tracer IO APIServerLog
-> ChainStateType tx
-> Chain tx IO
-> PParams LedgerEra
-> ServerOutputFilter tx
-> IO (Maybe StallReason)
-> (ClientInput tx -> IO ())
-> ((EventSink (StateEvent tx) IO, Server tx IO) -> IO ())
-> IO ()
withAPIServer @SimpleTx APIServerConfig
config RunOptions
defaultRunOptions Environment
testEnvironment Party
actor EventSource (StateEvent SimpleTx) IO
eventSource Tracer IO APIServerLog
tracer ChainStateType SimpleTx
SimpleChainState
0 Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle PParams LedgerEra
defaultPParams ServerOutputFilter SimpleTx
forall tx. ServerOutputFilter tx
allowEverythingServerOutputFilter IO (Maybe StallReason)
queryBroadcastStall ClientInput SimpleTx -> IO ()
forall (m :: * -> *) a. Applicative m => a -> m ()
noop
 where
  config :: APIServerConfig
config = APIServerConfig{$sel:host:APIServerConfig :: IP
host = IP
"127.0.0.1", PortNumber
$sel:port:APIServerConfig :: PortNumber
port :: PortNumber
port, $sel:tlsCertPath:APIServerConfig :: Maybe String
tlsCertPath = Maybe String
forall a. Maybe a
Nothing, $sel:tlsKeyPath:APIServerConfig :: Maybe String
tlsKeyPath = Maybe String
forall a. Maybe a
Nothing, $sel:apiTransactionTimeout:APIServerConfig :: ApiTransactionTimeout
apiTransactionTimeout = ApiTransactionTimeout
1000000, $sel:listenSocket:APIServerConfig :: Maybe Socket
listenSocket = Socket -> Maybe Socket
forall a. a -> Maybe a
Just Socket
sock}

-- | Like 'withTestAPIServer', but with an explicit callback invoked for every
-- 'ClientInput' received by the server.
withTestAPIServerWithCallback ::
  Maybe Socket ->
  PortNumber ->
  Party ->
  EventSource (StateEvent SimpleTx) IO ->
  Tracer IO APIServerLog ->
  (ClientInput SimpleTx -> IO ()) ->
  ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO) -> IO ()) ->
  IO ()
withTestAPIServerWithCallback :: Maybe Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> (ClientInput SimpleTx -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerWithCallback Maybe Socket
listenSocket PortNumber
port Party
actor EventSource (StateEvent SimpleTx) IO
eventSource =
  Maybe Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> ServerOutputFilter SimpleTx
-> Tracer IO APIServerLog
-> (ClientInput SimpleTx -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer' Maybe Socket
listenSocket PortNumber
port Party
actor EventSource (StateEvent SimpleTx) IO
eventSource ServerOutputFilter SimpleTx
forall tx. ServerOutputFilter tx
allowEverythingServerOutputFilter

-- | Like 'withTestAPIServer', but with an explicit 'ServerOutputFilter'.
withTestAPIServerWithFilter ::
  Socket ->
  PortNumber ->
  Party ->
  EventSource (StateEvent SimpleTx) IO ->
  ServerOutputFilter SimpleTx ->
  Tracer IO APIServerLog ->
  ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO) -> IO ()) ->
  IO ()
withTestAPIServerWithFilter :: Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> ServerOutputFilter SimpleTx
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerWithFilter Socket
sock PortNumber
port Party
actor EventSource (StateEvent SimpleTx) IO
eventSource ServerOutputFilter SimpleTx
outputFilter Tracer IO APIServerLog
tracer =
  Maybe Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> ServerOutputFilter SimpleTx
-> Tracer IO APIServerLog
-> (ClientInput SimpleTx -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer' (Socket -> Maybe Socket
forall a. a -> Maybe a
Just Socket
sock) PortNumber
port Party
actor EventSource (StateEvent SimpleTx) IO
eventSource ServerOutputFilter SimpleTx
outputFilter Tracer IO APIServerLog
tracer ClientInput SimpleTx -> IO ()
forall (m :: * -> *) a. Applicative m => a -> m ()
noop

withTestAPIServer' ::
  Maybe Socket ->
  PortNumber ->
  Party ->
  EventSource (StateEvent SimpleTx) IO ->
  ServerOutputFilter SimpleTx ->
  Tracer IO APIServerLog ->
  (ClientInput SimpleTx -> IO ()) ->
  ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO) -> IO ()) ->
  IO ()
withTestAPIServer' :: Maybe Socket
-> PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> ServerOutputFilter SimpleTx
-> Tracer IO APIServerLog
-> (ClientInput SimpleTx -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer' Maybe Socket
listenSocket PortNumber
port Party
actor EventSource (StateEvent SimpleTx) IO
eventSource ServerOutputFilter SimpleTx
outputFilter Tracer IO APIServerLog
tracer =
  forall tx.
IsChainState tx =>
APIServerConfig
-> RunOptions
-> Environment
-> Party
-> EventSource (StateEvent tx) IO
-> Tracer IO APIServerLog
-> ChainStateType tx
-> Chain tx IO
-> PParams LedgerEra
-> ServerOutputFilter tx
-> IO (Maybe StallReason)
-> (ClientInput tx -> IO ())
-> ((EventSink (StateEvent tx) IO, Server tx IO) -> IO ())
-> IO ()
withAPIServer @SimpleTx APIServerConfig
config RunOptions
defaultRunOptions Environment
testEnvironment Party
actor EventSource (StateEvent SimpleTx) IO
eventSource Tracer IO APIServerLog
tracer ChainStateType SimpleTx
SimpleChainState
0 Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle PParams LedgerEra
defaultPParams ServerOutputFilter SimpleTx
outputFilter (Maybe StallReason -> IO (Maybe StallReason)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe StallReason
forall a. Maybe a
Nothing)
 where
  config :: APIServerConfig
config = APIServerConfig{$sel:host:APIServerConfig :: IP
host = IP
"127.0.0.1", PortNumber
$sel:port:APIServerConfig :: PortNumber
port :: PortNumber
port, $sel:tlsCertPath:APIServerConfig :: Maybe String
tlsCertPath = Maybe String
forall a. Maybe a
Nothing, $sel:tlsKeyPath:APIServerConfig :: Maybe String
tlsKeyPath = Maybe String
forall a. Maybe a
Nothing, $sel:apiTransactionTimeout:APIServerConfig :: ApiTransactionTimeout
apiTransactionTimeout = ApiTransactionTimeout
1000000, Maybe Socket
$sel:listenSocket:APIServerConfig :: Maybe Socket
listenSocket :: Maybe Socket
listenSocket}

-- | Connect to a websocket server running at given path. Fails if not connected
-- within 2 seconds.
withClient :: PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient :: PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
path Connection -> IO ()
action =
  Int -> IO ()
connect (Int
20 :: Int)
 where
  connect :: Int -> IO ()
connect !Int
n
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"withClient could not connect"
    | Bool
otherwise =
        String -> Int -> String -> (Connection -> IO ()) -> IO ()
forall a. String -> Int -> String -> ClientApp a -> IO a
runClient String
"127.0.0.1" (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port) String
path Connection -> IO ()
action
          IO () -> (ConnectionException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(ConnectionException
e :: ConnectionException) -> do
            Handle -> Text -> IO ()
hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"withClient failed to connect: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConnectionException -> Text
forall b a. (Show a, IsString b) => a -> b
show ConnectionException
e
            DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.1
            Int -> IO ()
connect (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

mockSource :: Monad m => [a] -> EventSource a m
mockSource :: forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource [a]
events =
  EventSource
    { sourceEvents :: HasEventId a => ConduitT () a (ResourceT m) ()
sourceEvents = [a] -> ConduitT () (Element [a]) (ResourceT m) ()
forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany [a]
events
    }

waitForValue :: HasCallStack => PortNumber -> (Aeson.Value -> Maybe ()) -> IO ()
waitForValue :: HasCallStack => PortNumber -> (Value -> Maybe ()) -> IO ()
waitForValue PortNumber
port Value -> Maybe ()
f =
  PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?history=no" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
    Natural -> Connection -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
Natural -> Connection -> (Value -> Maybe a) -> IO a
waitMatch Natural
5 Connection
conn Value -> Maybe ()
f

-- | Wait up to some time for an API server output to match the given predicate.
waitMatch :: HasCallStack => Natural -> Connection -> (Aeson.Value -> Maybe a) -> IO a
waitMatch :: forall a.
HasCallStack =>
Natural -> Connection -> (Value -> Maybe a) -> IO a
waitMatch Natural
delay Connection
con Value -> Maybe a
match = do
  TVar [Value]
seenMsgs <- String -> [Value] -> IO (TVar IO [Value])
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"wait-match-seen-msgs" []
  DiffTime -> IO a -> IO (Maybe a)
forall a. DiffTime -> IO a -> IO (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout (Natural -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
delay) (TVar [Value] -> IO a
go TVar [Value]
seenMsgs) IO (Maybe a) -> (Maybe a -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just a
x -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    Maybe a
Nothing -> do
      [Value]
msgs <- TVar IO [Value] -> IO [Value]
forall a. TVar IO a -> IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar [Value]
TVar IO [Value]
seenMsgs
      String -> IO a
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$
        Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
          [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines
            [ Text
"waitMatch did not match a message within " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Natural -> Text
forall b a. (Show a, IsString b) => a -> b
show Natural
delay Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"s"
            , Char -> Int -> Text -> Text
padRight Char
' ' Int
20 Text
"  seen messages:"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines (Int -> [Text] -> [Text]
align Int
20 (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
forall l s. LazyStrict l s => l -> s
toStrict (ByteString -> ByteString)
-> (Value -> ByteString) -> Value -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> Text) -> [Value] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value]
msgs))
            ]
 where
  go :: TVar [Value] -> IO a
go TVar [Value]
seenMsgs = do
    Value
msg <- Connection -> IO Value
waitNext Connection
con
    STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TVar IO [Value] -> ([Value] -> [Value]) -> STM IO ()
forall a. TVar IO a -> (a -> a) -> STM IO ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar' TVar [Value]
TVar IO [Value]
seenMsgs (Value
msg :))
    IO a -> (a -> IO a) -> Maybe a -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TVar [Value] -> IO a
go TVar [Value]
seenMsgs) a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Maybe a
match Value
msg)

  align :: Int -> [Text] -> [Text]
align Int
_ [] = []
  align Int
n (Text
h : [Text]
q) = Text
h Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Text -> Text
T.replicate Int
n Text
" " <>) [Text]
q

  waitNext :: Connection -> IO Value
  waitNext :: Connection -> IO Value
waitNext Connection
connection = do
    ByteString
bytes <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
connection
    case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode' ByteString
bytes of
      Left String
err -> String -> IO Value
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO Value) -> String -> IO Value
forall a b. (a -> b) -> a -> b
$ String
"WaitNext failed to decode msg: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
      Right Value
value -> Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
value

shouldSatisfyAll :: forall a. HasCallStack => Show a => [a] -> [a -> Bool] -> Expectation
shouldSatisfyAll :: forall a. (HasCallStack, Show a) => [a] -> [a -> Bool] -> IO ()
shouldSatisfyAll = [a] -> [a -> Bool] -> IO ()
go
 where
  go :: [a] -> [a -> Bool] -> IO ()
  go :: [a] -> [a -> Bool] -> IO ()
go [] [] = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  go [] [a -> Bool]
_ = String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"shouldSatisfyAll: ran out of values"
  go [a]
_ [] = String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"shouldSatisfyAll: ran out of predicates"
  go (a
v : [a]
vs) (a -> Bool
p : [a -> Bool]
ps) = do
    a
v a -> (a -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` a -> Bool
p
    [a] -> [a -> Bool] -> IO ()
go [a]
vs [a -> Bool]
ps

genStateEventForApi :: Gen (StateEvent SimpleTx)
genStateEventForApi :: Gen (StateEvent SimpleTx)
genStateEventForApi =
  Gen (StateEvent SimpleTx)
forall a. Arbitrary a => Gen a
arbitrary Gen (StateEvent SimpleTx)
-> (StateEvent SimpleTx -> Bool) -> Gen (StateEvent SimpleTx)
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Maybe (TimedServerOutput SimpleTx) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (TimedServerOutput SimpleTx) -> Bool)
-> (StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx))
-> StateEvent SimpleTx
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Snapshot SimpleTx)
-> StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent Maybe (Snapshot SimpleTx)
forall a. Maybe a
Nothing)