{-# LANGUAGE DuplicateRecordFields #-}

module Hydra.API.ServerSpec where

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

import Conduit (yieldMany)
import Control.Concurrent.Class.MonadSTM (
  check,
  modifyTVar',
  newTQueue,
  newTVarIO,
  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.Server (APIServerConfig (..), RunServerException (..), Server, mkTimedServerOutputFromStateEvent, withAPIServer)
import Hydra.API.ServerOutput (InvalidInput (..), input)
import Hydra.API.ServerOutputFilter (ServerOutputFilter (..))
import Hydra.Chain (
  Chain (Chain),
  draftCommitTx,
  draftDepositTx,
  postTx,
  submitTx,
 )
import Hydra.Events (EventSink (..), EventSource (..), HasEventId (getEventId), StateEvent (..), genStateEvent)
import Hydra.HeadLogic.Outcome qualified as Outcome
import Hydra.Ledger.Simple (SimpleTx (..))
import Hydra.Logging (Tracer, showLogsOnFailure)
import Hydra.Network (PortNumber)
import Hydra.Options qualified as Options
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.Tx.Fixture (alice, defaultPParams, testEnvironment, 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 =
  Spec -> Spec
forall a. SpecWith a -> SpecWith a
parallel (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
"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.
(MonadSTM 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.
(MonadSTM 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.
(MonadSTM 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
Options.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 IO Value
queue <- STM IO (TQueue IO Value) -> IO (TQueue IO Value)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM IO (TQueue IO Value)
forall a. STM IO (TQueue IO a)
forall (m :: * -> *) a. MonadSTM m => STM m (TQueue m a)
newTQueue
      Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadSTM 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 <- Int -> IO (TVar IO Int)
forall a. a -> IO (TVar IO a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO Int
0
            IO () -> (Async IO () -> IO ()) -> IO ()
forall a b. IO a -> (Async IO a -> IO b) -> IO b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync
              ( IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m ()
concurrently_
                  (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 IO Value
queue TVar Int
TVar IO Int
semaphore)
                  (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 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
1 (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 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
$
                          StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx. IsTx tx => StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent 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
1 (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 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
1 (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 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.
(MonadSTM 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
$
                  StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx. IsTx tx => StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent 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 IO Value
queue1 <- STM IO (TQueue IO Value) -> IO (TQueue IO Value)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM IO (TQueue IO Value)
forall a. STM IO (TQueue IO a)
forall (m :: * -> *) a. MonadSTM m => STM m (TQueue m a)
newTQueue
        TQueue IO Value
queue2 <- STM IO (TQueue IO Value) -> IO (TQueue IO Value)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM IO (TQueue IO Value)
forall a. STM IO (TQueue IO a)
forall (m :: * -> *) a. MonadSTM m => STM m (TQueue m a)
newTQueue
        (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 <- Int -> IO (TVar IO Int)
forall a. a -> IO (TVar IO a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO Int
0
            IO () -> (Async IO () -> IO ()) -> IO ()
forall a b. IO a -> (Async IO a -> IO b) -> IO b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync
              ( IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m ()
concurrently_
                  (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 IO Value
queue1 TVar Int
TVar IO Int
semaphore)
                  (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 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
1 (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 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 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
1 (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 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 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 StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx. IsTx tx => StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent [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.
(MonadSTM 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.
(MonadSTM 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
                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
                  -- wait on the greeting message
                  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

                  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 <- 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
$ StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx. IsTx tx => StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent 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.
(MonadSTM 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
                    , Snapshot SimpleTx
snapshot :: Snapshot SimpleTx
$sel:snapshot:NetworkConnected :: 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
$
            Text -> (Tracer IO APIServerLog -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadSTM 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 [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.
(MonadSTM 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
          -- 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.HeadInitialized (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
                , HeadId
-> Set SimpleTxOut -> SimpleChainState -> StateChanged SimpleTx
HeadId
-> UTxOType SimpleTx
-> ChainStateType SimpleTx
-> StateChanged SimpleTx
forall tx.
HeadId -> UTxOType tx -> ChainStateType tx -> StateChanged tx
Outcome.HeadAborted (HeadId
 -> Set SimpleTxOut -> SimpleChainState -> StateChanged SimpleTx)
-> Gen HeadId
-> Gen
     (Set SimpleTxOut -> SimpleChainState -> StateChanged SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary Gen (Set SimpleTxOut -> SimpleChainState -> StateChanged SimpleTx)
-> Gen (Set SimpleTxOut)
-> Gen (SimpleChainState -> 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 (Set SimpleTxOut)
forall a. Arbitrary a => Gen a
arbitrary Gen (SimpleChainState -> StateChanged SimpleTx)
-> Gen SimpleChainState -> 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 SimpleChainState
forall a. Arbitrary a => Gen a
arbitrary
                , HeadId
-> Set SimpleTxOut -> SimpleChainState -> StateChanged SimpleTx
HeadId
-> UTxOType SimpleTx
-> ChainStateType SimpleTx
-> StateChanged SimpleTx
forall tx.
HeadId -> UTxOType tx -> ChainStateType tx -> StateChanged tx
Outcome.HeadFannedOut (HeadId
 -> Set SimpleTxOut -> SimpleChainState -> StateChanged SimpleTx)
-> Gen HeadId
-> Gen
     (Set SimpleTxOut -> SimpleChainState -> StateChanged SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary Gen (Set SimpleTxOut -> SimpleChainState -> StateChanged SimpleTx)
-> Gen (Set SimpleTxOut)
-> Gen (SimpleChainState -> 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 (Set SimpleTxOut)
forall a. Arbitrary a => Gen a
arbitrary Gen (SimpleChainState -> StateChanged SimpleTx)
-> Gen SimpleChainState -> 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 SimpleChainState
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
-> Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx)
-> StateChanged SimpleTx
forall tx.
HeadId
-> Snapshot tx -> MultiSignature (Snapshot tx) -> StateChanged tx
Outcome.SnapshotConfirmed (HeadId
 -> Snapshot SimpleTx
 -> MultiSignature (Snapshot SimpleTx)
 -> StateChanged SimpleTx)
-> Gen HeadId
-> Gen
     (Snapshot SimpleTx
      -> MultiSignature (Snapshot SimpleTx) -> StateChanged SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary Gen
  (Snapshot SimpleTx
   -> MultiSignature (Snapshot SimpleTx) -> StateChanged SimpleTx)
-> Gen (Snapshot SimpleTx)
-> Gen
     (MultiSignature (Snapshot SimpleTx) -> 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 (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
"Final")
              -- test that the 'snapshotUtxo' is excluded from json if there is no utxo
              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 (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")

            (HeadId
headId, StateEvent SimpleTx
headIsOpenMsg) <- Gen (HeadId, StateEvent SimpleTx)
-> IO (HeadId, StateEvent SimpleTx)
forall a. Gen a -> IO a
generate (Gen (HeadId, StateEvent SimpleTx)
 -> IO (HeadId, StateEvent SimpleTx))
-> Gen (HeadId, StateEvent SimpleTx)
-> IO (HeadId, StateEvent SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
              HeadId
headId <- Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary
              StateEvent SimpleTx
output <- 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
-> ChainStateType SimpleTx
-> UTxOType SimpleTx
-> StateChanged SimpleTx
forall tx.
HeadId -> ChainStateType tx -> UTxOType tx -> StateChanged tx
Outcome.HeadOpened HeadId
headId (SimpleChainState -> Set SimpleTxOut -> StateChanged SimpleTx)
-> Gen SimpleChainState
-> Gen (Set SimpleTxOut -> StateChanged SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen SimpleChainState
forall a. Arbitrary a => Gen a
arbitrary Gen (Set SimpleTxOut -> StateChanged SimpleTx)
-> Gen (Set SimpleTxOut) -> 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 (Set SimpleTxOut)
forall a. Arbitrary a => Gen a
arbitrary)
              (HeadId, StateEvent SimpleTx) -> Gen (HeadId, StateEvent SimpleTx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HeadId
headId, StateEvent SimpleTx
output)
            snapShotConfirmedMsg :: StateEvent SimpleTx
snapShotConfirmedMsg@StateEvent{$sel:stateChanged:StateEvent :: forall tx. StateEvent tx -> StateChanged tx
stateChanged = Outcome.SnapshotConfirmed{$sel:snapshot:NetworkConnected :: forall tx. StateChanged tx -> Snapshot tx
snapshot = 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 ()) -> [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
headIsOpenMsg, 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 -> Snapshot tx
snapshot = 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
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
readyToFanoutMsg, 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
"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.
(MonadSTM 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 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
-> Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx)
-> StateChanged SimpleTx
forall tx.
HeadId
-> Snapshot tx -> MultiSignature (Snapshot tx) -> StateChanged tx
Outcome.SnapshotConfirmed (HeadId
 -> Snapshot SimpleTx
 -> MultiSignature (Snapshot SimpleTx)
 -> StateChanged SimpleTx)
-> Gen HeadId
-> Gen
     (Snapshot SimpleTx
      -> MultiSignature (Snapshot SimpleTx) -> StateChanged SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary Gen
  (Snapshot SimpleTx
   -> MultiSignature (Snapshot SimpleTx) -> StateChanged SimpleTx)
-> Gen (Snapshot SimpleTx)
-> Gen
     (MultiSignature (Snapshot SimpleTx) -> 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 (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 -> Snapshot tx
snapshot = 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
          StateChanged SimpleTx
headIsInitializing :: Outcome.StateChanged SimpleTx <- 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.HeadInitialized (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 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
          [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
snapShotConfirmedMsg, StateChanged SimpleTx
headIsInitializing]
          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

          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
"Initializing")
              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
"Initializing")
              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
"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.
(MonadSTM 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"
                    }
            forall tx.
IsChainState tx =>
APIServerConfig
-> Environment
-> Party
-> EventSource (StateEvent tx) IO
-> Tracer IO APIServerLog
-> Chain tx IO
-> PParams LedgerEra
-> ServerOutputFilter tx
-> (ClientInput tx -> IO ())
-> ((EventSink (StateEvent tx) IO, Server tx IO) -> IO ())
-> IO ()
withAPIServer @SimpleTx APIServerConfig
config Environment
testEnvironment Party
alice ([StateEvent SimpleTx] -> EventSource (StateEvent SimpleTx) IO
forall (m :: * -> *) a. Monad m => [a] -> EventSource a m
mockSource []) Tracer IO APIServerLog
tracer 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.
(MonadSTM 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:draftCommitTx:Chain :: MonadThrow IO =>
HeadId -> CommitBlueprintTx tx -> IO (Either (PostTxError tx) tx)
draftCommitTx = \HeadId
_ -> Text -> CommitBlueprintTx tx -> IO (Either (PostTxError tx) tx)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected call to draftCommitTx"
    , $sel:draftDepositTx:Chain :: MonadThrow IO =>
HeadId
-> CommitBlueprintTx tx
-> UTCTime
-> IO (Either (PostTxError tx) tx)
draftDepositTx = \HeadId
_ -> Text
-> CommitBlueprintTx tx
-> UTCTime
-> 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"
    }

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 (EventSink (StateEvent SimpleTx) IO, Server SimpleTx IO) -> IO ()
action = do
  forall tx.
IsChainState tx =>
APIServerConfig
-> Environment
-> Party
-> EventSource (StateEvent tx) IO
-> Tracer IO APIServerLog
-> Chain tx IO
-> PParams LedgerEra
-> ServerOutputFilter tx
-> (ClientInput tx -> IO ())
-> ((EventSink (StateEvent tx) IO, Server tx IO) -> IO ())
-> IO ()
withAPIServer @SimpleTx APIServerConfig
config Environment
testEnvironment Party
actor EventSource (StateEvent SimpleTx) IO
eventSource Tracer IO APIServerLog
tracer 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 ()
action
 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}

-- | 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 <- [Value] -> IO (TVar IO [Value])
forall a. a -> IO (TVar IO a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO []
  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
forall {b}. FromJSON b => Connection -> IO b
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 b
waitNext Connection
connection = do
    ByteString
bytes <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
connection
    case ByteString -> Either String b
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode' ByteString
bytes of
      Left String
err -> String -> IO b
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO b) -> String -> IO b
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 b
value -> b -> IO b
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
value

shouldSatisfyAll :: HasCallStack => Show a => [a] -> [a -> Bool] -> Expectation
shouldSatisfyAll :: forall a. (HasCallStack, Show a) => [a] -> [a -> Bool] -> IO ()
shouldSatisfyAll = [a] -> [a -> Bool] -> IO ()
forall {a}. Show a => [a] -> [a -> Bool] -> IO ()
go
 where
  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
. StateEvent SimpleTx -> Maybe (TimedServerOutput SimpleTx)
forall tx. IsTx tx => StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent)