{-# LANGUAGE DuplicateRecordFields #-}

module Hydra.API.ServerSpec where

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

import Control.Concurrent.Class.MonadSTM (
  check,
  modifyTVar',
  newTQueue,
  newTVarIO,
  readTQueue,
  readTVarIO,
  tryReadTQueue,
  writeTQueue,
 )
import Control.Lens ((^?))
import Data.Aeson qualified as Aeson
import Data.Aeson.Lens (key)
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 (Server, sendOutput), withAPIServer)
import Hydra.API.ServerOutput (ServerOutput (..), TimedServerOutput (..), genTimedServerOutput, input)
import Hydra.Chain (
  Chain (Chain),
  draftCommitTx,
  draftDepositTx,
  postTx,
  submitTx,
 )
import Hydra.Ledger.Simple (SimpleTx (..))
import Hydra.Logging (Tracer, showLogsOnFailure)
import Hydra.Network (PortNumber)
import Hydra.Options qualified as Options
import Hydra.Persistence (PersistenceIncremental (..), createPersistenceIncremental)
import Hydra.Tx.Party (Party)
import Hydra.Tx.Snapshot (Snapshot (Snapshot, utxo))
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, generate)
import Test.QuickCheck.Monadic (monadicIO, monitor, pick, run)
import Test.Util (isContinuous)

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 -> (Server SimpleTx IO -> IO ()) -> IO ()
withServerOnPort PortNumber
p = PortNumber
-> Party
-> PersistenceIncremental (TimedServerOutput SimpleTx) IO
-> Tracer IO APIServerLog
-> (Server SimpleTx IO -> IO ())
-> IO ()
withTestAPIServer PortNumber
p Party
alice PersistenceIncremental (TimedServerOutput SimpleTx) IO
forall (m :: * -> *) a. Applicative m => PersistenceIncremental a m
mockPersistence 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 -> (Server SimpleTx IO -> IO ()) -> IO ()
withServerOnPort PortNumber
port ((Server SimpleTx IO -> IO ()) -> IO ())
-> (Server SimpleTx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Server SimpleTx IO
_ ->
            PortNumber -> (Server SimpleTx IO -> IO ()) -> IO ()
withServerOnPort PortNumber
port (\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
-> PersistenceIncremental (TimedServerOutput SimpleTx) IO
-> Tracer IO APIServerLog
-> (Server SimpleTx IO -> IO ())
-> IO ()
withTestAPIServer PortNumber
port Party
alice PersistenceIncremental (TimedServerOutput SimpleTx) IO
forall (m :: * -> *) a. Applicative m => PersistenceIncremental a m
mockPersistence Tracer IO APIServerLog
tracer ((Server SimpleTx IO -> IO ()) -> IO ())
-> (Server SimpleTx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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
-> PersistenceIncremental (TimedServerOutput SimpleTx) IO
-> Tracer IO APIServerLog
-> (Server SimpleTx IO -> IO ())
-> IO ()
withTestAPIServer PortNumber
port Party
alice PersistenceIncremental (TimedServerOutput SimpleTx) IO
forall (m :: * -> *) a. Applicative m => PersistenceIncremental a m
mockPersistence Tracer IO APIServerLog
tracer ((Server SimpleTx IO -> IO ()) -> IO ())
-> (Server SimpleTx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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 sendOutput to all connected clients" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      TQueue IO (ServerOutput SimpleTx)
queue <- STM IO (TQueue IO (ServerOutput SimpleTx))
-> IO (TQueue IO (ServerOutput SimpleTx))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM IO (TQueue IO (ServerOutput SimpleTx))
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
-> PersistenceIncremental (TimedServerOutput SimpleTx) IO
-> Tracer IO APIServerLog
-> (Server SimpleTx IO -> IO ())
-> IO ()
withTestAPIServer PortNumber
port Party
alice PersistenceIncremental (TimedServerOutput SimpleTx) IO
forall (m :: * -> *) a. Applicative m => PersistenceIncremental a m
mockPersistence Tracer IO APIServerLog
tracer ((Server SimpleTx IO -> IO ()) -> IO ())
-> (Server SimpleTx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Server{ServerOutput SimpleTx -> IO ()
$sel:sendOutput:Server :: forall tx (m :: * -> *). Server tx m -> ServerOutput tx -> m ()
sendOutput :: ServerOutput SimpleTx -> IO ()
sendOutput} -> 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 (ServerOutput SimpleTx)
-> TVar IO Int -> Connection -> IO ()
testClient TQueue IO (ServerOutput SimpleTx)
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 (ServerOutput SimpleTx)
-> TVar IO Int -> Connection -> IO ()
testClient TQueue IO (ServerOutput SimpleTx)
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 [ServerOutput SimpleTx] -> IO [ServerOutput SimpleTx]
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Int -> STM (ServerOutput SimpleTx) -> STM [ServerOutput SimpleTx]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (TQueue IO (ServerOutput SimpleTx) -> STM IO (ServerOutput SimpleTx)
forall a. TQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue IO (ServerOutput SimpleTx)
queue))
                    IO [ServerOutput SimpleTx]
-> ([ServerOutput SimpleTx] -> 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
>>= ([ServerOutput SimpleTx] -> [ServerOutput SimpleTx -> Bool] -> IO ()
forall a. Show a => [a] -> [a -> Bool] -> IO ()
`shouldSatisfyAll` [ServerOutput SimpleTx -> Bool
forall tx. ServerOutput tx -> Bool
isGreetings, ServerOutput SimpleTx -> Bool
forall tx. ServerOutput tx -> Bool
isGreetings])

                ServerOutput SimpleTx
arbitraryMsg <- Gen (ServerOutput SimpleTx) -> IO (ServerOutput SimpleTx)
forall a. Gen a -> IO a
generate Gen (ServerOutput SimpleTx)
forall a. Arbitrary a => Gen a
arbitrary
                ServerOutput SimpleTx -> IO ()
sendOutput ServerOutput SimpleTx
arbitraryMsg
                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 [ServerOutput SimpleTx] -> IO [ServerOutput SimpleTx]
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Int -> STM (ServerOutput SimpleTx) -> STM [ServerOutput SimpleTx]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (TQueue IO (ServerOutput SimpleTx) -> STM IO (ServerOutput SimpleTx)
forall a. TQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue IO (ServerOutput SimpleTx)
queue)) IO [ServerOutput SimpleTx] -> [ServerOutput SimpleTx] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [ServerOutput SimpleTx
arbitraryMsg, ServerOutput SimpleTx
arbitraryMsg]
                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 (ServerOutput SimpleTx))
-> IO (Maybe (ServerOutput SimpleTx))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TQueue IO (ServerOutput SimpleTx)
-> STM IO (Maybe (ServerOutput SimpleTx))
forall a. TQueue IO a -> STM IO (Maybe a)
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m (Maybe a)
tryReadTQueue TQueue IO (ServerOutput SimpleTx)
queue) IO (Maybe (ServerOutput SimpleTx))
-> Maybe (ServerOutput SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Maybe (ServerOutput SimpleTx)
forall a. Maybe a
Nothing

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"sends all sendOutput history to all connected clients after a restart" (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
$
        String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) r.
MonadIO m =>
String -> (String -> m r) -> m r
withTempDir String
"ServerSpec" ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
tmpDir -> do
          let persistentFile :: String
persistentFile = String
tmpDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/history"
          ServerOutput SimpleTx
arbitraryMsg <- Gen (ServerOutput SimpleTx) -> IO (ServerOutput SimpleTx)
forall a. Gen a -> IO a
generate Gen (ServerOutput SimpleTx)
forall a. Arbitrary a => Gen a
arbitrary

          PersistenceIncremental (TimedServerOutput SimpleTx) IO
persistence <- String
-> IO (PersistenceIncremental (TimedServerOutput SimpleTx) IO)
forall a (m :: * -> *).
(MonadIO m, MonadThrow m, MonadSTM m, MonadThread m,
 MonadThrow (STM m)) =>
String -> m (PersistenceIncremental a m)
createPersistenceIncremental String
persistentFile
          (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
-> PersistenceIncremental (TimedServerOutput SimpleTx) IO
-> Tracer IO APIServerLog
-> (Server SimpleTx IO -> IO ())
-> IO ()
withTestAPIServer PortNumber
port Party
alice PersistenceIncremental (TimedServerOutput SimpleTx) IO
persistence Tracer IO APIServerLog
tracer ((Server SimpleTx IO -> IO ()) -> IO ())
-> (Server SimpleTx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Server{ServerOutput SimpleTx -> IO ()
$sel:sendOutput:Server :: forall tx (m :: * -> *). Server tx m -> ServerOutput tx -> m ()
sendOutput :: ServerOutput SimpleTx -> IO ()
sendOutput} -> do
              ServerOutput SimpleTx -> IO ()
sendOutput ServerOutput SimpleTx
arbitraryMsg

          TQueue IO (ServerOutput SimpleTx)
queue1 <- STM IO (TQueue IO (ServerOutput SimpleTx))
-> IO (TQueue IO (ServerOutput SimpleTx))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM IO (TQueue IO (ServerOutput SimpleTx))
forall a. STM IO (TQueue IO a)
forall (m :: * -> *) a. MonadSTM m => STM m (TQueue m a)
newTQueue
          TQueue IO (ServerOutput SimpleTx)
queue2 <- STM IO (TQueue IO (ServerOutput SimpleTx))
-> IO (TQueue IO (ServerOutput SimpleTx))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM IO (TQueue IO (ServerOutput SimpleTx))
forall a. STM IO (TQueue IO a)
forall (m :: * -> *) a. MonadSTM m => STM m (TQueue m a)
newTQueue
          PersistenceIncremental (TimedServerOutput SimpleTx) IO
persistence' <- String
-> IO (PersistenceIncremental (TimedServerOutput SimpleTx) IO)
forall a (m :: * -> *).
(MonadIO m, MonadThrow m, MonadSTM m, MonadThread m,
 MonadThrow (STM m)) =>
String -> m (PersistenceIncremental a m)
createPersistenceIncremental String
persistentFile
          (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
-> PersistenceIncremental (TimedServerOutput SimpleTx) IO
-> Tracer IO APIServerLog
-> (Server SimpleTx IO -> IO ())
-> IO ()
withTestAPIServer PortNumber
port Party
alice PersistenceIncremental (TimedServerOutput SimpleTx) IO
persistence' Tracer IO APIServerLog
tracer ((Server SimpleTx IO -> IO ()) -> IO ())
-> (Server SimpleTx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Server{ServerOutput SimpleTx -> IO ()
$sel:sendOutput:Server :: forall tx (m :: * -> *). Server tx m -> ServerOutput tx -> m ()
sendOutput :: ServerOutput SimpleTx -> IO ()
sendOutput} -> 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 (ServerOutput SimpleTx)
-> TVar IO Int -> Connection -> IO ()
testClient TQueue IO (ServerOutput SimpleTx)
queue1 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 (ServerOutput SimpleTx)
-> TVar IO Int -> Connection -> IO ()
testClient TQueue IO (ServerOutput SimpleTx)
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
$
                    STM IO [ServerOutput SimpleTx] -> IO [ServerOutput SimpleTx]
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Int -> STM (ServerOutput SimpleTx) -> STM [ServerOutput SimpleTx]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (TQueue IO (ServerOutput SimpleTx) -> STM IO (ServerOutput SimpleTx)
forall a. TQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue IO (ServerOutput SimpleTx)
queue1))
                      IO [ServerOutput SimpleTx]
-> ([ServerOutput SimpleTx] -> 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
>>= ([ServerOutput SimpleTx]
 -> [ServerOutput SimpleTx -> Bool] -> IO ())
-> [ServerOutput SimpleTx -> Bool]
-> [ServerOutput SimpleTx]
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip [ServerOutput SimpleTx] -> [ServerOutput SimpleTx -> Bool] -> IO ()
forall a. Show a => [a] -> [a -> Bool] -> IO ()
shouldSatisfyAll [ServerOutput SimpleTx -> ServerOutput SimpleTx -> Bool
forall a. Eq a => a -> a -> Bool
(==) ServerOutput SimpleTx
arbitraryMsg, ServerOutput SimpleTx -> Bool
forall tx. ServerOutput tx -> Bool
isGreetings]
                  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 [ServerOutput SimpleTx] -> IO [ServerOutput SimpleTx]
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Int -> STM (ServerOutput SimpleTx) -> STM [ServerOutput SimpleTx]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (TQueue IO (ServerOutput SimpleTx) -> STM IO (ServerOutput SimpleTx)
forall a. TQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue IO (ServerOutput SimpleTx)
queue2))
                      IO [ServerOutput SimpleTx]
-> ([ServerOutput SimpleTx] -> 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
>>= ([ServerOutput SimpleTx]
 -> [ServerOutput SimpleTx -> Bool] -> IO ())
-> [ServerOutput SimpleTx -> Bool]
-> [ServerOutput SimpleTx]
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip [ServerOutput SimpleTx] -> [ServerOutput SimpleTx -> Bool] -> IO ()
forall a. Show a => [a] -> [a -> Bool] -> IO ()
shouldSatisfyAll [ServerOutput SimpleTx -> ServerOutput SimpleTx -> Bool
forall a. Eq a => a -> a -> Bool
(==) ServerOutput SimpleTx
arbitraryMsg, ServerOutput SimpleTx -> Bool
forall tx. ServerOutput tx -> Bool
isGreetings]

                  ServerOutput SimpleTx -> IO ()
sendOutput ServerOutput SimpleTx
arbitraryMsg
                  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 [ServerOutput SimpleTx] -> IO [ServerOutput SimpleTx]
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Int -> STM (ServerOutput SimpleTx) -> STM [ServerOutput SimpleTx]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
1 (TQueue IO (ServerOutput SimpleTx) -> STM IO (ServerOutput SimpleTx)
forall a. TQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue IO (ServerOutput SimpleTx)
queue1))
                      IO [ServerOutput SimpleTx] -> [ServerOutput SimpleTx] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [ServerOutput SimpleTx
arbitraryMsg]
                  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 [ServerOutput SimpleTx] -> IO [ServerOutput SimpleTx]
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Int -> STM (ServerOutput SimpleTx) -> STM [ServerOutput SimpleTx]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
1 (TQueue IO (ServerOutput SimpleTx) -> STM IO (ServerOutput SimpleTx)
forall a. TQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue IO (ServerOutput SimpleTx)
queue2))
                      IO [ServerOutput SimpleTx] -> [ServerOutput SimpleTx] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [ServerOutput SimpleTx
arbitraryMsg]
                  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 (ServerOutput SimpleTx))
-> IO (Maybe (ServerOutput SimpleTx))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TQueue IO (ServerOutput SimpleTx)
-> STM IO (Maybe (ServerOutput SimpleTx))
forall a. TQueue IO a -> STM IO (Maybe a)
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m (Maybe a)
tryReadTQueue TQueue IO (ServerOutput SimpleTx)
queue1)
                      IO (Maybe (ServerOutput SimpleTx))
-> Maybe (ServerOutput SimpleTx) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Maybe (ServerOutput SimpleTx)
forall a. Maybe a
Nothing

    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
$
      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
        [ServerOutput SimpleTx]
outputs <- Gen [ServerOutput SimpleTx] -> PropertyM IO [ServerOutput SimpleTx]
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick Gen [ServerOutput SimpleTx]
forall a. Arbitrary a => Gen a
arbitrary
        (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 ([ServerOutput SimpleTx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ServerOutput SimpleTx]
outputs) 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 ([ServerOutput SimpleTx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ServerOutput SimpleTx]
outputs 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 ([ServerOutput SimpleTx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ServerOutput SimpleTx]
outputs 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
-> PersistenceIncremental (TimedServerOutput SimpleTx) IO
-> Tracer IO APIServerLog
-> (Server SimpleTx IO -> IO ())
-> IO ()
withTestAPIServer PortNumber
port Party
alice PersistenceIncremental (TimedServerOutput SimpleTx) IO
forall (m :: * -> *) a. Applicative m => PersistenceIncremental a m
mockPersistence Tracer IO APIServerLog
tracer ((Server SimpleTx IO -> IO ()) -> IO ())
-> (Server SimpleTx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Server{ServerOutput SimpleTx -> IO ()
$sel:sendOutput:Server :: forall tx (m :: * -> *). Server tx m -> ServerOutput tx -> m ()
sendOutput :: ServerOutput SimpleTx -> IO ()
sendOutput} -> do
                (ServerOutput SimpleTx -> IO ())
-> [ServerOutput SimpleTx] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ServerOutput SimpleTx -> IO ()
sendOutput [ServerOutput SimpleTx]
outputs
                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
                  [ByteString]
received <- NominalDiffTime -> IO [ByteString] -> IO [ByteString]
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
10 (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 ([ServerOutput SimpleTx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ServerOutput SimpleTx]
outputs 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 (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
                      let actualOutputs :: [ServerOutput SimpleTx]
actualOutputs = TimedServerOutput SimpleTx -> ServerOutput SimpleTx
forall tx. TimedServerOutput tx -> ServerOutput tx
output (TimedServerOutput SimpleTx -> ServerOutput SimpleTx)
-> [TimedServerOutput SimpleTx] -> [ServerOutput SimpleTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TimedServerOutput SimpleTx]
timedOutputs
                      [ServerOutput SimpleTx] -> [ServerOutput SimpleTx]
forall a. HasCallStack => [a] -> [a]
List.init [ServerOutput SimpleTx]
actualOutputs [ServerOutput SimpleTx] -> [ServerOutput SimpleTx] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [ServerOutput SimpleTx]
outputs
                      [ServerOutput SimpleTx] -> ServerOutput SimpleTx
forall a. HasCallStack => [a] -> a
List.last [ServerOutput SimpleTx]
actualOutputs ServerOutput SimpleTx -> (ServerOutput SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` ServerOutput SimpleTx -> Bool
forall tx. ServerOutput tx -> Bool
isGreetings

    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
        [ServerOutput SimpleTx]
history :: [ServerOutput SimpleTx] <- Gen [ServerOutput SimpleTx] -> PropertyM IO [ServerOutput SimpleTx]
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick Gen [ServerOutput SimpleTx]
forall a. Arbitrary a => Gen a
arbitrary
        (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 ([ServerOutput SimpleTx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ServerOutput 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 ([ServerOutput SimpleTx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ServerOutput 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 ([ServerOutput SimpleTx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ServerOutput 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
-> PersistenceIncremental (TimedServerOutput SimpleTx) IO
-> Tracer IO APIServerLog
-> (Server SimpleTx IO -> IO ())
-> IO ()
withTestAPIServer PortNumber
port Party
alice PersistenceIncremental (TimedServerOutput SimpleTx) IO
forall (m :: * -> *) a. Applicative m => PersistenceIncremental a m
mockPersistence Tracer IO APIServerLog
tracer ((Server SimpleTx IO -> IO ()) -> IO ())
-> (Server SimpleTx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Server{ServerOutput SimpleTx -> IO ()
$sel:sendOutput:Server :: forall tx (m :: * -> *). Server tx m -> ServerOutput tx -> m ()
sendOutput :: ServerOutput SimpleTx -> IO ()
sendOutput} -> do
                let sendFromApiServer :: ServerOutput SimpleTx -> IO ()
sendFromApiServer = ServerOutput SimpleTx -> IO ()
sendOutput
                (ServerOutput SimpleTx -> IO ())
-> [ServerOutput SimpleTx] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ServerOutput SimpleTx -> IO ()
sendFromApiServer [ServerOutput SimpleTx]
history
                -- start client that doesn't want to see the history
                PortNumber -> String -> (Connection -> IO ()) -> IO ()
withClient PortNumber
port String
"/?history=no" ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
                  -- 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

                  ServerOutput SimpleTx
notHistoryMessage :: ServerOutput SimpleTx <- Gen (ServerOutput SimpleTx) -> IO (ServerOutput SimpleTx)
forall a. Gen a -> IO a
generate Gen (ServerOutput SimpleTx)
forall a. Arbitrary a => Gen a
arbitrary
                  ServerOutput SimpleTx -> IO ()
sendFromApiServer ServerOutput 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 -> ServerOutput SimpleTx
forall tx. TimedServerOutput tx -> ServerOutput tx
output (TimedServerOutput SimpleTx -> ServerOutput SimpleTx)
-> [TimedServerOutput SimpleTx] -> [ServerOutput SimpleTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TimedServerOutput SimpleTx]
timedOutputs') [ServerOutput SimpleTx] -> [ServerOutput SimpleTx] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [ServerOutput 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
-> PersistenceIncremental (TimedServerOutput SimpleTx) IO
-> Tracer IO APIServerLog
-> (Server SimpleTx IO -> IO ())
-> IO ()
withTestAPIServer PortNumber
port Party
alice PersistenceIncremental (TimedServerOutput SimpleTx) IO
forall (m :: * -> *) a. Applicative m => PersistenceIncremental a m
mockPersistence Tracer IO APIServerLog
tracer ((Server SimpleTx IO -> IO ()) -> IO ())
-> (Server SimpleTx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Server{ServerOutput SimpleTx -> IO ()
$sel:sendOutput:Server :: forall tx (m :: * -> *). Server tx m -> ServerOutput tx -> m ()
sendOutput :: ServerOutput SimpleTx -> IO ()
sendOutput} -> 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
            let snapshotConfirmedMessage :: ServerOutput SimpleTx
snapshotConfirmedMessage =
                  SnapshotConfirmed
                    { $sel:headId:PeerConnected :: HeadId
headId = HeadId
testHeadId
                    , Snapshot SimpleTx
snapshot :: Snapshot SimpleTx
$sel:snapshot:PeerConnected :: Snapshot SimpleTx
Hydra.API.ServerOutput.snapshot
                    , $sel:signatures:PeerConnected :: MultiSignature (Snapshot SimpleTx)
Hydra.API.ServerOutput.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
              ServerOutput SimpleTx -> IO ()
sendOutput ServerOutput 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 are continuous" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$
      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
        [ServerOutput SimpleTx]
outputs :: [ServerOutput SimpleTx] <- Gen [ServerOutput SimpleTx] -> PropertyM IO [ServerOutput SimpleTx]
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick Gen [ServerOutput SimpleTx]
forall a. Arbitrary a => Gen a
arbitrary
        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
-> PersistenceIncremental (TimedServerOutput SimpleTx) IO
-> Tracer IO APIServerLog
-> (Server SimpleTx IO -> IO ())
-> IO ()
withTestAPIServer PortNumber
port Party
alice PersistenceIncremental (TimedServerOutput SimpleTx) IO
forall (m :: * -> *) a. Applicative m => PersistenceIncremental a m
mockPersistence Tracer IO APIServerLog
tracer ((Server SimpleTx IO -> IO ()) -> IO ())
-> (Server SimpleTx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Server{ServerOutput SimpleTx -> IO ()
$sel:sendOutput:Server :: forall tx (m :: * -> *). Server tx m -> ServerOutput tx -> m ()
sendOutput :: ServerOutput SimpleTx -> IO ()
sendOutput} -> do
                (ServerOutput SimpleTx -> IO ())
-> [ServerOutput SimpleTx] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ServerOutput SimpleTx -> IO ()
sendOutput [ServerOutput SimpleTx]
outputs
                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
                  [ByteString]
received <- Int -> IO ByteString -> IO [ByteString]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([ServerOutput SimpleTx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ServerOutput SimpleTx]
outputs 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 (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 :: [TimedServerOutput SimpleTx]) ->
                      TimedServerOutput SimpleTx -> Natural
forall tx. TimedServerOutput tx -> Natural
seq (TimedServerOutput SimpleTx -> Natural)
-> [TimedServerOutput SimpleTx] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TimedServerOutput SimpleTx]
timedOutputs [Natural] -> ([Natural] -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` [Natural] -> Bool
forall a. (Eq a, Enum a) => [a] -> Bool
isContinuous

    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 persistence to
          -- check whether the latest headStatus is loaded correctly.
          [TimedServerOutput SimpleTx]
existingServerOutputs <-
            Gen [TimedServerOutput SimpleTx] -> IO [TimedServerOutput SimpleTx]
forall a. Gen a -> IO a
generate (Gen [TimedServerOutput SimpleTx]
 -> IO [TimedServerOutput SimpleTx])
-> Gen [TimedServerOutput SimpleTx]
-> IO [TimedServerOutput SimpleTx]
forall a b. (a -> b) -> a -> b
$
              (Gen (ServerOutput SimpleTx) -> Gen (TimedServerOutput SimpleTx))
-> [Gen (ServerOutput SimpleTx)]
-> Gen [TimedServerOutput 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 (ServerOutput SimpleTx)
-> (ServerOutput SimpleTx -> Gen (TimedServerOutput SimpleTx))
-> Gen (TimedServerOutput SimpleTx)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ServerOutput SimpleTx -> Gen (TimedServerOutput SimpleTx)
forall tx. ServerOutput tx -> Gen (TimedServerOutput tx)
genTimedServerOutput)
                [ HeadId -> [Party] -> ServerOutput SimpleTx
forall tx. HeadId -> [Party] -> ServerOutput tx
HeadIsInitializing (HeadId -> [Party] -> ServerOutput SimpleTx)
-> Gen HeadId -> Gen ([Party] -> ServerOutput SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary Gen ([Party] -> ServerOutput SimpleTx)
-> Gen [Party] -> Gen (ServerOutput 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 -> ServerOutput SimpleTx
HeadId -> UTxOType SimpleTx -> ServerOutput SimpleTx
forall tx. HeadId -> UTxOType tx -> ServerOutput tx
HeadIsAborted (HeadId -> Set SimpleTxOut -> ServerOutput SimpleTx)
-> Gen HeadId -> Gen (Set SimpleTxOut -> ServerOutput 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 -> ServerOutput SimpleTx)
-> Gen (Set SimpleTxOut) -> Gen (ServerOutput 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 -> Set SimpleTxOut -> ServerOutput SimpleTx
HeadId -> UTxOType SimpleTx -> ServerOutput SimpleTx
forall tx. HeadId -> UTxOType tx -> ServerOutput tx
HeadIsFinalized (HeadId -> Set SimpleTxOut -> ServerOutput SimpleTx)
-> Gen HeadId -> Gen (Set SimpleTxOut -> ServerOutput 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 -> ServerOutput SimpleTx)
-> Gen (Set SimpleTxOut) -> Gen (ServerOutput 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
                ]
          let persistence :: PersistenceIncremental (TimedServerOutput SimpleTx) IO
persistence = [TimedServerOutput SimpleTx]
-> PersistenceIncremental (TimedServerOutput SimpleTx) IO
forall (m :: * -> *) a.
Applicative m =>
[a] -> PersistenceIncremental a m
mockPersistence' [TimedServerOutput SimpleTx]
existingServerOutputs

          PortNumber
-> Party
-> PersistenceIncremental (TimedServerOutput SimpleTx) IO
-> Tracer IO APIServerLog
-> (Server SimpleTx IO -> IO ())
-> IO ()
withTestAPIServer PortNumber
port Party
alice PersistenceIncremental (TimedServerOutput SimpleTx) IO
persistence Tracer IO APIServerLog
tracer ((Server SimpleTx IO -> IO ()) -> IO ())
-> (Server SimpleTx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Server{ServerOutput SimpleTx -> IO ()
$sel:sendOutput:Server :: forall tx (m :: * -> *). Server tx m -> ServerOutput tx -> m ()
sendOutput :: ServerOutput SimpleTx -> IO ()
sendOutput} -> do
            let generateSnapshot :: IO (ServerOutput SimpleTx)
generateSnapshot =
                  Gen (ServerOutput SimpleTx) -> IO (ServerOutput SimpleTx)
forall a. Gen a -> IO a
generate (Gen (ServerOutput SimpleTx) -> IO (ServerOutput SimpleTx))
-> Gen (ServerOutput SimpleTx) -> IO (ServerOutput SimpleTx)
forall a b. (a -> b) -> a -> b
$
                    HeadId
-> Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx)
-> ServerOutput SimpleTx
forall tx.
HeadId
-> Snapshot tx -> MultiSignature (Snapshot tx) -> ServerOutput tx
SnapshotConfirmed (HeadId
 -> Snapshot SimpleTx
 -> MultiSignature (Snapshot SimpleTx)
 -> ServerOutput SimpleTx)
-> Gen HeadId
-> Gen
     (Snapshot SimpleTx
      -> MultiSignature (Snapshot SimpleTx) -> ServerOutput 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) -> ServerOutput SimpleTx)
-> Gen (Snapshot SimpleTx)
-> Gen
     (MultiSignature (Snapshot SimpleTx) -> ServerOutput 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) -> ServerOutput SimpleTx)
-> Gen (MultiSignature (Snapshot SimpleTx))
-> Gen (ServerOutput 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, ServerOutput SimpleTx
headIsOpenMsg) <- Gen (HeadId, ServerOutput SimpleTx)
-> IO (HeadId, ServerOutput SimpleTx)
forall a. Gen a -> IO a
generate (Gen (HeadId, ServerOutput SimpleTx)
 -> IO (HeadId, ServerOutput SimpleTx))
-> Gen (HeadId, ServerOutput SimpleTx)
-> IO (HeadId, ServerOutput SimpleTx)
forall a b. (a -> b) -> a -> b
$ do
              HeadId
headId <- Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary
              ServerOutput SimpleTx
output <- HeadId -> UTxOType SimpleTx -> ServerOutput SimpleTx
forall tx. HeadId -> UTxOType tx -> ServerOutput tx
HeadIsOpen HeadId
headId (Set SimpleTxOut -> ServerOutput SimpleTx)
-> Gen (Set SimpleTxOut) -> Gen (ServerOutput SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Set SimpleTxOut)
forall a. Arbitrary a => Gen a
arbitrary
              (HeadId, ServerOutput SimpleTx)
-> Gen (HeadId, ServerOutput SimpleTx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HeadId
headId, ServerOutput SimpleTx
output)
            snapShotConfirmedMsg :: ServerOutput SimpleTx
snapShotConfirmedMsg@SnapshotConfirmed{$sel:snapshot:PeerConnected :: forall tx. ServerOutput tx -> Snapshot tx
snapshot = Snapshot{UTxOType SimpleTx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo :: UTxOType SimpleTx
utxo}} <-
              IO (ServerOutput SimpleTx)
generateSnapshot

            (ServerOutput SimpleTx -> IO ())
-> [ServerOutput SimpleTx] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ServerOutput SimpleTx -> IO ()
sendOutput [ServerOutput SimpleTx
headIsOpenMsg, ServerOutput 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
UTxOType SimpleTx
utxo)

            snapShotConfirmedMsg' :: ServerOutput SimpleTx
snapShotConfirmedMsg'@SnapshotConfirmed{$sel:snapshot:PeerConnected :: forall tx. ServerOutput tx -> Snapshot tx
snapshot = Snapshot{$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo = UTxOType SimpleTx
utxo'}} <-
              IO (ServerOutput SimpleTx)
generateSnapshot
            let readyToFanoutMsg :: ServerOutput SimpleTx
readyToFanoutMsg = ReadyToFanout{HeadId
$sel:headId:PeerConnected :: HeadId
headId :: HeadId
headId}

            (ServerOutput SimpleTx -> IO ())
-> [ServerOutput SimpleTx] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ServerOutput SimpleTx -> IO ()
sendOutput [ServerOutput SimpleTx
readyToFanoutMsg, ServerOutput 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
UTxOType SimpleTx
utxo')

    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 ->
        String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) r.
MonadIO m =>
String -> (String -> m r) -> m r
withTempDir String
"api-server-head-status" ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
persistenceDir ->
          (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 (ServerOutput SimpleTx)
generateSnapshot =
                  Gen (ServerOutput SimpleTx) -> IO (ServerOutput SimpleTx)
forall a. Gen a -> IO a
generate (Gen (ServerOutput SimpleTx) -> IO (ServerOutput SimpleTx))
-> Gen (ServerOutput SimpleTx) -> IO (ServerOutput SimpleTx)
forall a b. (a -> b) -> a -> b
$
                    HeadId
-> Snapshot SimpleTx
-> MultiSignature (Snapshot SimpleTx)
-> ServerOutput SimpleTx
forall tx.
HeadId
-> Snapshot tx -> MultiSignature (Snapshot tx) -> ServerOutput tx
SnapshotConfirmed (HeadId
 -> Snapshot SimpleTx
 -> MultiSignature (Snapshot SimpleTx)
 -> ServerOutput SimpleTx)
-> Gen HeadId
-> Gen
     (Snapshot SimpleTx
      -> MultiSignature (Snapshot SimpleTx) -> ServerOutput 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) -> ServerOutput SimpleTx)
-> Gen (Snapshot SimpleTx)
-> Gen
     (MultiSignature (Snapshot SimpleTx) -> ServerOutput 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) -> ServerOutput SimpleTx)
-> Gen (MultiSignature (Snapshot SimpleTx))
-> Gen (ServerOutput 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
            PersistenceIncremental (TimedServerOutput SimpleTx) IO
apiPersistence <- String
-> IO (PersistenceIncremental (TimedServerOutput SimpleTx) IO)
forall a (m :: * -> *).
(MonadIO m, MonadThrow m, MonadSTM m, MonadThread m,
 MonadThrow (STM m)) =>
String -> m (PersistenceIncremental a m)
createPersistenceIncremental (String
 -> IO (PersistenceIncremental (TimedServerOutput SimpleTx) IO))
-> String
-> IO (PersistenceIncremental (TimedServerOutput SimpleTx) IO)
forall a b. (a -> b) -> a -> b
$ String
persistenceDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/server-output"
            snapShotConfirmedMsg :: ServerOutput SimpleTx
snapShotConfirmedMsg@SnapshotConfirmed{$sel:snapshot:PeerConnected :: forall tx. ServerOutput tx -> Snapshot tx
snapshot = Snapshot{UTxOType SimpleTx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo :: UTxOType SimpleTx
utxo}} <-
              IO (ServerOutput SimpleTx)
generateSnapshot
            let expectedUtxos :: Value
expectedUtxos = Set SimpleTxOut -> Value
forall a. ToJSON a => a -> Value
toJSON Set SimpleTxOut
UTxOType SimpleTx
utxo

            PortNumber
-> Party
-> PersistenceIncremental (TimedServerOutput SimpleTx) IO
-> Tracer IO APIServerLog
-> (Server SimpleTx IO -> IO ())
-> IO ()
withTestAPIServer PortNumber
port Party
alice PersistenceIncremental (TimedServerOutput SimpleTx) IO
apiPersistence Tracer IO APIServerLog
tracer ((Server SimpleTx IO -> IO ()) -> IO ())
-> (Server SimpleTx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Server{ServerOutput SimpleTx -> IO ()
$sel:sendOutput:Server :: forall tx (m :: * -> *). Server tx m -> ServerOutput tx -> m ()
sendOutput :: ServerOutput SimpleTx -> IO ()
sendOutput} -> do
              ServerOutput SimpleTx
headIsInitializing <- Gen (ServerOutput SimpleTx) -> IO (ServerOutput SimpleTx)
forall a. Gen a -> IO a
generate (Gen (ServerOutput SimpleTx) -> IO (ServerOutput SimpleTx))
-> Gen (ServerOutput SimpleTx) -> IO (ServerOutput SimpleTx)
forall a b. (a -> b) -> a -> b
$ HeadId -> [Party] -> ServerOutput SimpleTx
forall tx. HeadId -> [Party] -> ServerOutput tx
HeadIsInitializing (HeadId -> [Party] -> ServerOutput SimpleTx)
-> Gen HeadId -> Gen ([Party] -> ServerOutput SimpleTx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary Gen ([Party] -> ServerOutput SimpleTx)
-> Gen [Party] -> Gen (ServerOutput 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

              (ServerOutput SimpleTx -> IO ())
-> [ServerOutput SimpleTx] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ServerOutput SimpleTx -> IO ()
sendOutput [ServerOutput SimpleTx
headIsInitializing, ServerOutput 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
"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

            PersistenceIncremental (TimedServerOutput SimpleTx) IO
newApiPersistence <- String
-> IO (PersistenceIncremental (TimedServerOutput SimpleTx) IO)
forall a (m :: * -> *).
(MonadIO m, MonadThrow m, MonadSTM m, MonadThread m,
 MonadThrow (STM m)) =>
String -> m (PersistenceIncremental a m)
createPersistenceIncremental (String
 -> IO (PersistenceIncremental (TimedServerOutput SimpleTx) IO))
-> String
-> IO (PersistenceIncremental (TimedServerOutput SimpleTx) IO)
forall a b. (a -> b) -> a -> b
$ String
persistenceDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/server-output"
            PortNumber
-> Party
-> PersistenceIncremental (TimedServerOutput SimpleTx) IO
-> Tracer IO APIServerLog
-> (Server SimpleTx IO -> IO ())
-> IO ()
withTestAPIServer PortNumber
port Party
alice PersistenceIncremental (TimedServerOutput SimpleTx) IO
newApiPersistence Tracer IO APIServerLog
tracer ((Server SimpleTx IO -> IO ()) -> IO ())
-> (Server SimpleTx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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
-> PersistenceIncremental (TimedServerOutput tx) IO
-> Tracer IO APIServerLog
-> Chain tx IO
-> PParams LedgerEra
-> ServerComponent tx IO ()
withAPIServer @SimpleTx APIServerConfig
config Environment
testEnvironment Party
alice PersistenceIncremental (TimedServerOutput SimpleTx) IO
forall (m :: * -> *) a. Applicative m => PersistenceIncremental a m
mockPersistence Tracer IO APIServerLog
tracer Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle PParams LedgerEra
defaultPParams ClientInput SimpleTx -> IO ()
forall (m :: * -> *) a. Applicative m => a -> m ()
noop ((Server SimpleTx IO -> IO ()) -> IO ())
-> (Server SimpleTx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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
-> PersistenceIncremental (TimedServerOutput SimpleTx) IO
-> Tracer IO APIServerLog
-> (Server SimpleTx IO -> IO ())
-> IO ()
withTestAPIServer PortNumber
port Party
alice PersistenceIncremental (TimedServerOutput SimpleTx) IO
forall (m :: * -> *) a. Applicative m => PersistenceIncremental a m
mockPersistence Tracer IO APIServerLog
tracer ((Server SimpleTx IO -> IO ()) -> IO ())
-> (Server SimpleTx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Server SimpleTx IO
_server -> 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 @(TimedServerOutput SimpleTx) 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 TimedServerOutput{$sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = ServerOutput SimpleTx
resp} -> ServerOutput SimpleTx
resp ServerOutput SimpleTx -> (ServerOutput SimpleTx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` ServerOutput SimpleTx -> Bool
isInvalidInput
 where
  invalidInput :: Text
invalidInput = Text
"not a valid message"
  isInvalidInput :: ServerOutput SimpleTx -> Bool
isInvalidInput = \case
    InvalidInput{Text
$sel:input:PeerConnected :: forall tx. ServerOutput tx -> Text
input :: Text
input} -> Text
input Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
invalidInput
    ServerOutput SimpleTx
_ -> Bool
False

matchGreetings :: Aeson.Value -> Bool
matchGreetings :: 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
"tag" 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
"Greetings")

isGreetings :: ServerOutput tx -> Bool
isGreetings :: forall tx. ServerOutput tx -> Bool
isGreetings = \case
  Greetings{} -> Bool
True
  ServerOutput tx
_ -> Bool
False

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 (ServerOutput SimpleTx) -> TVar IO Int -> Connection -> IO ()
testClient :: TQueue IO (ServerOutput SimpleTx)
-> TVar IO Int -> Connection -> IO ()
testClient TQueue IO (ServerOutput SimpleTx)
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 (TimedServerOutput SimpleTx)
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 TimedServerOutput{$sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = ServerOutput SimpleTx
resp} -> 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 (ServerOutput SimpleTx)
-> ServerOutput SimpleTx -> STM IO ()
forall a. TQueue IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> a -> STM m ()
writeTQueue TQueue IO (ServerOutput SimpleTx)
queue ServerOutput SimpleTx
resp)
      TQueue IO (ServerOutput SimpleTx)
-> TVar IO Int -> Connection -> IO ()
testClient TQueue IO (ServerOutput SimpleTx)
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"
    }

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 ->
  PersistenceIncremental (TimedServerOutput SimpleTx) IO ->
  Tracer IO APIServerLog ->
  (Server SimpleTx IO -> IO ()) ->
  IO ()
withTestAPIServer :: PortNumber
-> Party
-> PersistenceIncremental (TimedServerOutput SimpleTx) IO
-> Tracer IO APIServerLog
-> (Server SimpleTx IO -> IO ())
-> IO ()
withTestAPIServer PortNumber
port Party
actor PersistenceIncremental (TimedServerOutput SimpleTx) IO
persistence Tracer IO APIServerLog
tracer Server SimpleTx IO -> IO ()
action = do
  forall tx.
IsChainState tx =>
APIServerConfig
-> Environment
-> Party
-> PersistenceIncremental (TimedServerOutput tx) IO
-> Tracer IO APIServerLog
-> Chain tx IO
-> PParams LedgerEra
-> ServerComponent tx IO ()
withAPIServer @SimpleTx APIServerConfig
config Environment
testEnvironment Party
actor PersistenceIncremental (TimedServerOutput SimpleTx) IO
persistence Tracer IO APIServerLog
tracer Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle PParams LedgerEra
defaultPParams ClientInput SimpleTx -> IO ()
forall (m :: * -> *) a. Applicative m => a -> m ()
noop 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)

-- | Mocked persistence handle which just does nothing.
mockPersistence :: Applicative m => PersistenceIncremental a m
mockPersistence :: forall (m :: * -> *) a. Applicative m => PersistenceIncremental a m
mockPersistence =
  [a] -> PersistenceIncremental a m
forall (m :: * -> *) a.
Applicative m =>
[a] -> PersistenceIncremental a m
mockPersistence' []

-- | Mocked persistence which does not contain some constant elements.
mockPersistence' :: Applicative m => [a] -> PersistenceIncremental a m
mockPersistence' :: forall (m :: * -> *) a.
Applicative m =>
[a] -> PersistenceIncremental a m
mockPersistence' [a]
xs =
  PersistenceIncremental
    { $sel:append:PersistenceIncremental :: ToJSON a => a -> m ()
append = \a
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , $sel:loadAll:PersistenceIncremental :: FromJSON a => m [a]
loadAll = [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
xs
    }

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 :: Show a => [a] -> [a -> Bool] -> Expectation
shouldSatisfyAll :: forall a. 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