{-# 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',
  readTQueue,
  readTVarIO,
  tryReadTQueue,
  writeTQueue,
 )
import Control.Lens ((^?))
import Data.Aeson (Value)
import Data.Aeson qualified as Aeson
import Data.Aeson.Lens (key, _Number)
import Data.List qualified as List
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, withAPIServer)
import Hydra.API.ServerOutput (ApiEncoding (..), ApiMessage (..), InvalidInput (..), ServerOutputConfig (..), 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.Events (EventSink (..), EventSource (..), HasEventId (getEventId))
import Hydra.HeadLogic.Outcome qualified as Outcome
import Hydra.HeadLogic.StateEvent (StateEvent (..))
import Hydra.Ledger.Simple (SimpleTx (..))
import Hydra.Logging (Tracer, showLogsOnFailure)
import Hydra.Network (PortNumber)
import Hydra.NetworkVersions qualified as NetworkVersions
import Hydra.Options (defaultRunOptions)
import Hydra.Tx.Party (Party)
import Hydra.Tx.Snapshot (Snapshot (Snapshot, utxo, utxoToCommit))
import Network.Simple.WSS qualified as WSS
import Network.TLS (ClientHooks (onServerCertificate), ClientParams (clientHooks), defaultParamsClient)
import Network.WebSockets (Connection, ConnectionException, receiveData, runClient, sendBinaryData)
import System.IO.Error (isAlreadyInUseError)
import Test.Hydra.HeadLogic.StateEvent (genStateEvent)
import Test.Hydra.Ledger.Simple ()
import Test.Hydra.Node.Fixture (testEnvironment)
import Test.Hydra.Tx.Fixture (alice, defaultPParams, testHeadId)
import Test.Hydra.Tx.Gen ()
import Test.Network.Ports (withFreePort)
import Test.QuickCheck (checkCoverage, cover, forAllShrink, generate, listOf, suchThat)
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
$ do
        let withServerOnPort :: PortNumber
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withServerOnPort PortNumber
p = PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer PortNumber
p Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) Tracer IO APIServerLog
tracer
        (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PortNumber
port -> do
          -- We should not be able to start the server on the same port twice
          PortNumber
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withServerOnPort PortNumber
port (((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
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withServerOnPort PortNumber
port (\(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 ->
          (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PortNumber
port ->
            PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer 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 ->
          (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PortNumber
port ->
            PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer 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
"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
$
        (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PortNumber
port -> do
          PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer 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 ()
$sel:putEvent:EventSink :: 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"
        (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PortNumber
port -> do
          PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer 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 ->
              (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PortNumber
port ->
                PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer 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 ()
$sel:putEvent:EventSink :: 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 ->
            (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PortNumber
port ->
              PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer 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 ()
$sel:putEvent:EventSink :: 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
$
        (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PortNumber
port ->
          PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer 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 ()
$sel:putEvent:EventSink :: 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
$
              (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PortNumber
port ->
                PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer 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 ->
        (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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

          PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer 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 ()
$sel:putEvent:EventSink :: 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 ->
        (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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
          PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer 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

          PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer 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
$
        (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
          \PortNumber
port -> PortNumber -> IO ()
sendsAnErrorWhenInputCannotBeDecoded PortNumber
port

    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 ->
            (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PortNumber
port ->
              PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer 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 ->
            (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PortNumber
port ->
              PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer 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 ()
$sel:putEvent:EventSink :: 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 ->
            (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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
              PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> (ClientInput SimpleTx -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerWithCallback 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 ->
            (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PortNumber
port ->
              PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer 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

    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 ->
          (PortNumber -> IO ()) -> IO ()
forall a. (PortNumber -> IO a) -> IO a
withFreePort ((PortNumber -> IO ()) -> IO ()) -> (PortNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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
                    }
                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
-> (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 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

sendsAnErrorWhenInputCannotBeDecoded :: PortNumber -> Expectation
sendsAnErrorWhenInputCannotBeDecoded :: PortNumber -> IO ()
sendsAnErrorWhenInputCannotBeDecoded 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 ->
    PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer 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
    }

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 ()

withTestAPIServer ::
  PortNumber ->
  Party ->
  EventSource (StateEvent SimpleTx) IO ->
  Tracer IO APIServerLog ->
  ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO) -> IO ()) ->
  IO ()
withTestAPIServer :: PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServer PortNumber
port Party
actor EventSource (StateEvent SimpleTx) IO
eventSource Tracer IO APIServerLog
tracer =
  PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> (ClientInput SimpleTx -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerWithCallback 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 an explicit callback invoked for every
-- 'ClientInput' received by the server.
withTestAPIServerWithCallback ::
  PortNumber ->
  Party ->
  EventSource (StateEvent SimpleTx) IO ->
  Tracer IO APIServerLog ->
  (ClientInput SimpleTx -> IO ()) ->
  ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO) -> IO ()) ->
  IO ()
withTestAPIServerWithCallback :: PortNumber
-> Party
-> EventSource (StateEvent SimpleTx) IO
-> Tracer IO APIServerLog
-> (ClientInput SimpleTx -> IO ())
-> ((EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO)
    -> IO ())
-> IO ()
withTestAPIServerWithCallback 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
-> (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
 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}

-- | 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
    { $sel:sourceEvents:EventSource :: 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)