module Hydra.API.HTTPServerSpec where

import Hydra.Prelude hiding (delete, get)
import Test.Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Binary (decodeFull', serialize')
import Control.Concurrent.STM (newTChanIO, writeTChan)
import Control.Lens ((^?))
import Data.Aeson (Result (Error, Success), eitherDecode, encode, fromJSON, object, (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Lens (key, nth)
import Data.ByteString.Lazy qualified as LBS
import Data.Text qualified as Text
import Hydra.API.ClientInput (ClientInput (..))
import Hydra.API.HTTPServer (
  DraftCommitTxRequest (..),
  DraftCommitTxResponse (..),
  OperationTimedOut,
  SideLoadSnapshotRequest (..),
  SubmitL2TxRequest (..),
  SubmitL2TxResponse (..),
  SubmitTxRequest (..),
  TransactionSubmitted (..),
  httpApp,
 )
import Hydra.API.ServerOutput (ClientMessage (..), CommitInfo (..), DecommitInvalidReason (..), ServerOutput (..), TimedServerOutput (..), getConfirmedSnapshot, getSeenSnapshot, getSnapshotUtxo)
import Hydra.API.ServerSpec (dummyChainHandle)
import Hydra.Cardano.Api (
  UTxO,
  mkTxOutDatumInline,
  modifyTxOutDatum,
  renderTxIn,
  serialiseToTextEnvelope,
 )
import Hydra.Chain (Chain, PostTxError (..), draftDepositTx, submitTx)
import Hydra.Chain.Direct.Handlers (rejectLowDeposits)
import Hydra.HeadLogic.Error (SideLoadRequirementFailure (..))
import Hydra.HeadLogic.State (ClosedState (..), HeadState (..), SeenSnapshot (..))
import Hydra.HeadLogicSpec (inIdleState, inUnsyncedIdleState, zeroChainPointTime)
import Hydra.JSONSchema (SchemaSelector, prop_validateJSONSchema, validateJSON, withJsonSpecifications)
import Hydra.Ledger (ValidationError (..))
import Hydra.Ledger.Cardano (Tx)
import Hydra.Ledger.Simple (SimpleTx (..))
import Hydra.Logging (nullTracer)
import Hydra.Node.State (NodeState (..))
import Hydra.Tx (ConfirmedSnapshot (..))
import Hydra.Tx.Accumulator qualified as Accumulator
import Hydra.Tx.IsTx (UTxOType, txId)
import Hydra.Tx.Snapshot (Snapshot (..))
import System.FilePath ((</>))
import System.IO.Unsafe (unsafePerformIO)
import Test.Aeson.GenericSpecs (roundtripAndGoldenSpecs)
import Test.Hspec.Wai (MatchBody (..), ResponseMatcher (matchBody, matchHeaders), delete, get, post, shouldRespondWith, with, (<:>))
import Test.Hspec.Wai qualified as Wai
import Test.Hspec.Wai.Internal (withApplication)
import Test.Hydra.API.HTTPServer ()
import Test.Hydra.Chain.Direct.State ()
import Test.Hydra.Node.Fixture (testEnvironment)
import Test.Hydra.Tx.Fixture (defaultPParams, pparams)
import Test.Hydra.Tx.Gen (genTxOut, genUTxOAdaOnlyOfSize)
import Test.QuickCheck (
  choose,
  counterexample,
  cover,
  forAll,
  generate,
  property,
  withMaxSuccess,
  (===),
 )

spec :: Spec
spec :: Spec
spec = do
  Spec -> Spec
forall a. SpecWith a -> SpecWith a
parallel (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    Proxy (ReasonablySized (DraftCommitTxResponse Tx)) -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a, Typeable a) =>
Proxy a -> Spec
roundtripAndGoldenSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ReasonablySized (DraftCommitTxResponse Tx)))
    Proxy (ReasonablySized (DraftCommitTxRequest Tx)) -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a, Typeable a) =>
Proxy a -> Spec
roundtripAndGoldenSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ReasonablySized (DraftCommitTxRequest Tx)))
    Proxy (ReasonablySized (SubmitTxRequest Tx)) -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a, Typeable a) =>
Proxy a -> Spec
roundtripAndGoldenSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ReasonablySized (SubmitTxRequest Tx)))
    Proxy (ReasonablySized TransactionSubmitted) -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a, Typeable a) =>
Proxy a -> Spec
roundtripAndGoldenSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ReasonablySized TransactionSubmitted))
    Proxy (ReasonablySized (SideLoadSnapshotRequest Tx)) -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a, Typeable a) =>
Proxy a -> Spec
roundtripAndGoldenSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ReasonablySized (SideLoadSnapshotRequest Tx)))
    Proxy (ReasonablySized (HeadState Tx)) -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a, Typeable a) =>
Proxy a -> Spec
roundtripAndGoldenSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ReasonablySized (HeadState Tx)))
    Proxy (ReasonablySized (NodeState Tx)) -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a, Typeable a) =>
Proxy a -> Spec
roundtripAndGoldenSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ReasonablySized (NodeState Tx)))
    Proxy (ReasonablySized SubmitL2TxResponse) -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a, Typeable a) =>
Proxy a -> Spec
roundtripAndGoldenSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ReasonablySized SubmitL2TxResponse))
    Proxy (ReasonablySized (SubmitL2TxRequest Tx)) -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a, Typeable a) =>
Proxy a -> Spec
roundtripAndGoldenSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ReasonablySized (SubmitL2TxRequest Tx)))
    Proxy (ReasonablySized OperationTimedOut) -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a, Typeable a) =>
Proxy a -> Spec
roundtripAndGoldenSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ReasonablySized OperationTimedOut))

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /commit publish api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @(DraftCommitTxRequest Tx) String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"components" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"messages" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"DraftCommitTxRequest" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"payload"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /commit subscribe api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @(DraftCommitTxResponse Tx) String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"components" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"messages" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"DraftCommitTxResponse" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"payload"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /cardano-transaction publish api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @(SubmitTxRequest Tx) String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"channels"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"/cardano-transaction"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"publish"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"message"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"payload"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /cardano-transaction subscribe api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @TransactionSubmitted String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"channels"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"/cardano-transaction"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"subscribe"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"message"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"oneOf"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SchemaSelector
forall t. AsValue t => Int -> Traversal' t Value
nth Int
0
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"payload"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /decommit publish api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @Tx String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"channels"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"/decommit"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"publish"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"message"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /decommit subscribe api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @Text String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"channels"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"/decommit"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"subscribe"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"message"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /commit publish api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @Text String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"channels"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"/commit"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"publish"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"message"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /commit subscribe api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @Text String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"channels"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"/commit"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"subscribe"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"message"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /commits publish api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @Text String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"channels"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"/commits"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"publish"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"message"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /commits subscribe api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @Text String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"channels"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"/commits"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"subscribe"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"message"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /commits/tx-id publish api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @Text String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"channels"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"/commits/tx-id"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"publish"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"message"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /commits/tx-id subscribe api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @Text String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"channels"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"/commits/tx-id"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"subscribe"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"message"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /snapshot publish api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @(SideLoadSnapshotRequest Tx) String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"components" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"messages" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"SideLoadSnapshotRequest" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"payload"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /snapshot subscribe api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @(ConfirmedSnapshot Tx) String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"components" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"schemas" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"ConfirmedSnapshot"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /head publish api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @Text String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"channels"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"/head"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"publish"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"message"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /head subscribe api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @(HeadState Tx) String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"channels"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"/head"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"subscribe"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"message"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /transaction publish api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @(SubmitL2TxRequest Tx) String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"channels"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"/transaction"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"publish"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"message"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"payload"

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Validate /transaction subscribe api schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @SubmitL2TxResponse String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
        Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"components"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"schemas"
          ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"SubmitL2TxResponse"

    Spec
apiServerSpec
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SubmitTxRequest accepted tx formats" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"accepts json encoded transaction" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        Gen Tx -> (Tx -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (forall a. Arbitrary a => Gen a
arbitrary @Tx) ((Tx -> Property) -> Property) -> (Tx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Tx
tx ->
          let json :: Value
json = Tx -> Value
forall a. ToJSON a => a -> Value
toJSON Tx
tx
           in case forall a. FromJSON a => Value -> Result a
fromJSON @(SubmitTxRequest Tx) Value
json of
                Success{} -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
                Error String
e -> String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
e) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"accepts transaction encoded as TextEnvelope" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        Gen Tx -> (Tx -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (forall a. Arbitrary a => Gen a
arbitrary @Tx) ((Tx -> Property) -> Property) -> (Tx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Tx
tx ->
          let json :: Value
json = TextEnvelope -> Value
forall a. ToJSON a => a -> Value
toJSON (TextEnvelope -> Value) -> TextEnvelope -> Value
forall a b. (a -> b) -> a -> b
$ Maybe TextEnvelopeDescr -> Tx -> TextEnvelope
forall a.
HasTextEnvelope a =>
Maybe TextEnvelopeDescr -> a -> TextEnvelope
serialiseToTextEnvelope Maybe TextEnvelopeDescr
forall a. Maybe a
Nothing Tx
tx
           in case forall a. FromJSON a => Value -> Result a
fromJSON @(SubmitTxRequest Tx) Value
json of
                Success{} -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
                Error String
e -> String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
e) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False

apiServerSpec :: Spec
apiServerSpec :: Spec
apiServerSpec = do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"API should respond correctly" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    let cantCommit :: IO CommitInfo
cantCommit = CommitInfo -> IO CommitInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommitInfo
CannotCommit
        getPendingDeposits :: IO [tx]
        getPendingDeposits :: forall tx. IO [tx]
getPendingDeposits = [tx] -> IO [tx]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

        putClientInput :: ClientInput tx -> IO ()
        putClientInput :: forall tx. ClientInput tx -> IO ()
putClientInput = IO () -> ClientInput tx -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        getNodeState :: IO (NodeState SimpleTx)
getNodeState = NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inIdleState
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"GET /protocol-parameters" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
-> SpecM
     ()
     (TChan
        (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall r a. IO r -> SpecM a r
runIO IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
      IO Application -> SpecWith ((), Application) -> Spec
with
        ( Application -> IO Application
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$
            forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              IO (NodeState SimpleTx)
getNodeState
              IO CommitInfo
cantCommit
              IO [Integer]
IO [TxIdType SimpleTx]
forall tx. IO [tx]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
        )
        (SpecWith ((), Application) -> Spec)
-> SpecWith ((), Application) -> Spec
forall a b. (a -> b) -> a -> b
$ do
          String -> WaiSession () () -> SpecWith (Arg (WaiSession () ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"matches schema" (WaiSession () () -> SpecWith (Arg (WaiSession () ())))
-> WaiSession () () -> SpecWith (Arg (WaiSession () ()))
forall a b. (a -> b) -> a -> b
$
            (String -> WaiSession () ()) -> WaiSession () ()
forall (m :: * -> *) r. MonadIO m => (String -> m r) -> m r
withJsonSpecifications ((String -> WaiSession () ()) -> WaiSession () ())
-> (String -> WaiSession () ()) -> WaiSession () ()
forall a b. (a -> b) -> a -> b
$ \String
schemaDir -> do
              ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/protocol-parameters"
                WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200
                  { matchBody =
                      matchValidJSON
                        (schemaDir </> "api.json")
                        (key "components" . key "messages" . key "ProtocolParameters" . key "payload")
                  }
          String -> WaiSession () () -> SpecWith (Arg (WaiSession () ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"responds given parameters" (WaiSession () () -> SpecWith (Arg (WaiSession () ())))
-> WaiSession () () -> SpecWith (Arg (WaiSession () ()))
forall a b. (a -> b) -> a -> b
$
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/protocol-parameters"
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200
                { matchBody = matchJSON defaultPParams
                }

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"GET /config" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      let configDoc :: Value
configDoc = [Pair] -> Value
object [Key
"node-id" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"test-node" :: Text)]
      TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
-> SpecM
     ()
     (TChan
        (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall r a. IO r -> SpecM a r
runIO IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
      IO Application -> SpecWith ((), Application) -> Spec
with
        ( Application -> IO Application
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$
            forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
configDoc
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              IO (NodeState SimpleTx)
getNodeState
              IO CommitInfo
cantCommit
              IO [Integer]
IO [TxIdType SimpleTx]
forall tx. IO [tx]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
        )
        (SpecWith ((), Application) -> Spec)
-> SpecWith ((), Application) -> Spec
forall a b. (a -> b) -> a -> b
$ do
          String -> WaiSession () () -> SpecWith (Arg (WaiSession () ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"returns the config doc verbatim" (WaiSession () () -> SpecWith (Arg (WaiSession () ())))
-> WaiSession () () -> SpecWith (Arg (WaiSession () ()))
forall a b. (a -> b) -> a -> b
$
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/config"
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200
                { matchBody = matchJSON configDoc
                }

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"GET /head" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
-> SpecM
     ()
     (TChan
        (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall r a. IO r -> SpecM a r
runIO IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
      String -> (NodeState SimpleTx -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds correctly" ((NodeState SimpleTx -> IO ()) -> Spec)
-> (NodeState SimpleTx -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \NodeState SimpleTx
nodeState -> do
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
nodeState)
              IO CommitInfo
cantCommit
              IO [Integer]
IO [TxIdType SimpleTx]
forall tx. IO [tx]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/head"
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200{matchBody = matchJSON (headState nodeState)}
      TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannelSimpleTx <- IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
-> SpecM
     () (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall r a. IO r -> SpecM a r
runIO IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall a. IO (TChan a)
newTChanIO
      String -> (NodeState Tx -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ok response matches schema" ((NodeState Tx -> Property) -> Spec)
-> (NodeState Tx -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \NodeState Tx
nodeState -> do
        let isIdle :: Bool
isIdle = case NodeState Tx -> HeadState Tx
forall tx. NodeState tx -> HeadState tx
headState NodeState Tx
nodeState of
              Idle{} -> Bool
True
              HeadState Tx
_ -> Bool
False
        let isOpen :: Bool
isOpen = case NodeState Tx -> HeadState Tx
forall tx. NodeState tx -> HeadState tx
headState NodeState Tx
nodeState of
              Open{} -> Bool
True
              HeadState Tx
_ -> Bool
False
        let isClosed :: Bool
isClosed = case NodeState Tx -> HeadState Tx
forall tx. NodeState tx -> HeadState tx
headState NodeState Tx
nodeState of
              Closed{} -> Bool
True
              HeadState Tx
_ -> Bool
False
        Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
20
          (Property -> Property)
-> ((String -> IO ()) -> Property) -> (String -> IO ()) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 Bool
isIdle String
"IdleState"
          (Property -> Property)
-> ((String -> IO ()) -> Property) -> (String -> IO ()) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 Bool
isOpen String
"OpenState"
          (Property -> Property)
-> ((String -> IO ()) -> Property) -> (String -> IO ()) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool -> String -> IO () -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 Bool
isClosed String
"ClosedState"
          (IO () -> Property)
-> ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO ()) -> IO ()
forall (m :: * -> *) r. MonadIO m => (String -> m r) -> m r
withJsonSpecifications
          ((String -> IO ()) -> Property) -> (String -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$ \String
schemaDir -> do
            Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
              ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @Tx
                  Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                  Value
Aeson.Null
                  Chain Tx IO
forall tx. Chain tx IO
dummyChainHandle
                  Environment
testEnvironment
                  PParams LedgerEra
defaultPParams
                  (NodeState Tx -> IO (NodeState Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState Tx
nodeState)
                  IO CommitInfo
cantCommit
                  IO [TxIdType Tx]
IO [TxId]
forall tx. IO [tx]
getPendingDeposits
                  ClientInput Tx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
                  ApiTransactionTimeout
300
                  TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannelSimpleTx
              )
              (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/head"
                  WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200
                    { matchBody =
                        matchValidJSON
                          (schemaDir </> "api.json")
                          (key "channels" . key "/head" . key "subscribe" . key "message")
                    }
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"GET /snapshot/last-seen" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
-> SpecM
     ()
     (TChan
        (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall r a. IO r -> SpecM a r
runIO IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
      String -> (NodeState SimpleTx -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds correctly" ((NodeState SimpleTx -> IO ()) -> Spec)
-> (NodeState SimpleTx -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \NodeState SimpleTx
nodeState -> do
        let SeenSnapshot SimpleTx
seenSnapshot :: SeenSnapshot SimpleTx = HeadState SimpleTx -> SeenSnapshot SimpleTx
forall tx. IsTx tx => HeadState tx -> SeenSnapshot tx
getSeenSnapshot (NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
nodeState)
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
nodeState)
              IO CommitInfo
cantCommit
              IO [Integer]
IO [TxIdType SimpleTx]
forall tx. IO [tx]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/snapshot/last-seen"
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200{matchBody = matchJSON seenSnapshot}
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"GET /snapshot" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
-> SpecM
     ()
     (TChan
        (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall r a. IO r -> SpecM a r
runIO IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
      String -> (NodeState SimpleTx -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds correctly" ((NodeState SimpleTx -> IO ()) -> Spec)
-> (NodeState SimpleTx -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \NodeState SimpleTx
nodeState -> do
        let Maybe (ConfirmedSnapshot SimpleTx)
confirmedSnapshot :: Maybe (ConfirmedSnapshot SimpleTx) = HeadState SimpleTx -> Maybe (ConfirmedSnapshot SimpleTx)
forall tx. HeadState tx -> Maybe (ConfirmedSnapshot tx)
getConfirmedSnapshot (NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
nodeState)
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
nodeState)
              IO CommitInfo
cantCommit
              IO [Integer]
IO [TxIdType SimpleTx]
forall tx. IO [tx]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/snapshot"
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` case Maybe (ConfirmedSnapshot SimpleTx)
confirmedSnapshot of
                Maybe (ConfirmedSnapshot SimpleTx)
Nothing -> ResponseMatcher
404
                Just ConfirmedSnapshot SimpleTx
confirmedSn -> ResponseMatcher
200{matchBody = matchJSON confirmedSn}
      TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannelSimpleTx <- IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
-> SpecM
     () (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall r a. IO r -> SpecM a r
runIO IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall a. IO (TChan a)
newTChanIO
      String -> (ClosedState Tx -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ok response matches schema" ((ClosedState Tx -> Property) -> Spec)
-> (ClosedState Tx -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \(ClosedState Tx
closedState :: ClosedState tx) -> do
        Int -> IO () -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
4
          (IO () -> Property)
-> ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO ()) -> IO ()
forall (m :: * -> *) r. MonadIO m => (String -> m r) -> m r
withJsonSpecifications
          ((String -> IO ()) -> Property) -> (String -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$ \String
schemaDir -> do
            Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
              ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @Tx
                  Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                  Value
Aeson.Null
                  Chain Tx IO
forall tx. Chain tx IO
dummyChainHandle
                  Environment
testEnvironment
                  PParams LedgerEra
defaultPParams
                  (NodeState Tx -> IO (NodeState Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeInSync{$sel:headState:NodeInSync :: HeadState Tx
headState = ClosedState Tx -> HeadState Tx
forall tx. ClosedState tx -> HeadState tx
Closed ClosedState Tx
closedState, $sel:pendingDeposits:NodeInSync :: PendingDeposits Tx
pendingDeposits = PendingDeposits Tx
Map TxId (Deposit Tx)
forall a. Monoid a => a
mempty, $sel:chainPointTime:NodeInSync :: ChainPointTime
chainPointTime = ChainPointTime
zeroChainPointTime})
                  IO CommitInfo
cantCommit
                  IO [TxIdType Tx]
IO [TxId]
forall tx. IO [tx]
getPendingDeposits
                  ClientInput Tx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
                  ApiTransactionTimeout
300
                  TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannelSimpleTx
              )
              (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/snapshot"
                  WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200
                    { matchBody =
                        matchValidJSON
                          (schemaDir </> "api.json")
                          (key "channels" . key "/snapshot" . key "subscribe" . key "message" . key "payload")
                    }

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"POST /snapshot" (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
"returns 202 on timeout" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
        let reqGen :: IO (SideLoadSnapshotRequest SimpleTx)
reqGen = Gen (SideLoadSnapshotRequest SimpleTx)
-> IO (SideLoadSnapshotRequest SimpleTx)
forall a. Gen a -> IO a
generate (forall a. Arbitrary a => Gen a
arbitrary @(SideLoadSnapshotRequest SimpleTx))
        SideLoadSnapshotRequest SimpleTx
request <- IO (SideLoadSnapshotRequest SimpleTx)
reqGen
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inIdleState)
              IO CommitInfo
cantCommit
              IO [Integer]
IO [TxIdType SimpleTx]
forall tx. IO [tx]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
0
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/snapshot" (SideLoadSnapshotRequest SimpleTx -> Body
forall a. ToJSON a => a -> Body
Aeson.encode SideLoadSnapshotRequest SimpleTx
request) WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
202

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"returns 200 on SnapshotSideLoaded" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
        let reqGen :: IO (SideLoadSnapshotRequest SimpleTx)
reqGen = Gen (SideLoadSnapshotRequest SimpleTx)
-> IO (SideLoadSnapshotRequest SimpleTx)
forall a. Gen a -> IO a
generate (forall a. Arbitrary a => Gen a
arbitrary @(SideLoadSnapshotRequest SimpleTx))
        SideLoadSnapshotRequest SimpleTx
request <- IO (SideLoadSnapshotRequest SimpleTx)
reqGen
        UTCTime
now' <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
        let event :: TimedServerOutput SimpleTx
event =
              TimedServerOutput
                { $sel:output:TimedServerOutput :: ServerOutput SimpleTx
output = SnapshotSideLoaded{$sel:headId:NetworkConnected :: HeadId
headId = Gen HeadId -> Int -> HeadId
forall a. Gen a -> Int -> a
generateWith Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary Int
42, $sel:snapshotNumber:NetworkConnected :: SnapshotNumber
snapshotNumber = SnapshotNumber
7}
                , $sel:seq:TimedServerOutput :: Natural
seq = Natural
0
                , $sel:time:TimedServerOutput :: UTCTime
time = UTCTime
now'
                }
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inIdleState)
              IO CommitInfo
cantCommit
              IO [Integer]
IO [TxIdType SimpleTx]
forall tx. IO [tx]
getPendingDeposits
              (IO () -> ClientInput SimpleTx -> IO ()
forall a b. a -> b -> a
const (IO () -> ClientInput SimpleTx -> IO ())
-> IO () -> ClientInput SimpleTx -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
$ TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
-> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel (TimedServerOutput SimpleTx
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
forall a b. a -> Either a b
Left TimedServerOutput SimpleTx
event))
              ApiTransactionTimeout
10
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/snapshot" (SideLoadSnapshotRequest SimpleTx -> Body
forall a. ToJSON a => a -> Body
Aeson.encode SideLoadSnapshotRequest SimpleTx
request) WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"returns 400 on CommandFailed" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
        let reqGen :: IO (SideLoadSnapshotRequest SimpleTx)
reqGen = Gen (SideLoadSnapshotRequest SimpleTx)
-> IO (SideLoadSnapshotRequest SimpleTx)
forall a. Gen a -> IO a
generate (forall a. Arbitrary a => Gen a
arbitrary @(SideLoadSnapshotRequest SimpleTx))
        SideLoadSnapshotRequest ConfirmedSnapshot SimpleTx
snapshot <- IO (SideLoadSnapshotRequest SimpleTx)
reqGen
        let clientFailed :: Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
clientFailed = ClientMessage SimpleTx
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
forall a b. b -> Either a b
Right (CommandFailed{$sel:clientInput:CommandFailed :: ClientInput SimpleTx
clientInput = ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot ConfirmedSnapshot SimpleTx
snapshot, $sel:state:CommandFailed :: HeadState SimpleTx
state = NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
inIdleState})
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inIdleState)
              IO CommitInfo
cantCommit
              IO [Integer]
IO [TxIdType SimpleTx]
forall tx. IO [tx]
getPendingDeposits
              (IO () -> ClientInput SimpleTx -> IO ()
forall a b. a -> b -> a
const (IO () -> ClientInput SimpleTx -> IO ())
-> IO () -> ClientInput SimpleTx -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
$ TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
-> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
clientFailed)
              ApiTransactionTimeout
10
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/snapshot" (SideLoadSnapshotRequest SimpleTx -> Body
forall a. ToJSON a => a -> Body
Aeson.encode (ConfirmedSnapshot SimpleTx -> SideLoadSnapshotRequest SimpleTx
forall tx. ConfirmedSnapshot tx -> SideLoadSnapshotRequest tx
SideLoadSnapshotRequest ConfirmedSnapshot SimpleTx
snapshot)) WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
400

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"returns 400 with side-load failure details" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
        let reqGen :: IO (SideLoadSnapshotRequest SimpleTx)
reqGen = Gen (SideLoadSnapshotRequest SimpleTx)
-> IO (SideLoadSnapshotRequest SimpleTx)
forall a. Gen a -> IO a
generate (forall a. Arbitrary a => Gen a
arbitrary @(SideLoadSnapshotRequest SimpleTx))
        SideLoadSnapshotRequest ConfirmedSnapshot SimpleTx
snapshot <- IO (SideLoadSnapshotRequest SimpleTx)
reqGen
        let SideLoadRequirementFailure SimpleTx
requirementFailure :: SideLoadRequirementFailure SimpleTx = SideLoadSnNumberInvalid{$sel:requestedSn:SideLoadInitialSnapshotMismatch :: SnapshotNumber
requestedSn = SnapshotNumber
7, $sel:lastSeenSn:SideLoadInitialSnapshotMismatch :: SnapshotNumber
lastSeenSn = SnapshotNumber
760}
        let clientFailed :: ClientMessage SimpleTx
clientFailed = SideLoadSnapshotRejected{$sel:clientInput:CommandFailed :: ClientInput SimpleTx
clientInput = ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot ConfirmedSnapshot SimpleTx
snapshot, SideLoadRequirementFailure SimpleTx
requirementFailure :: SideLoadRequirementFailure SimpleTx
$sel:requirementFailure:CommandFailed :: SideLoadRequirementFailure SimpleTx
requirementFailure}
        let expectedBody :: Value
expectedBody =
              [Pair] -> Value
object
                [ Key
"tag" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String Text
"SideLoadSnNumberInvalid"
                , Key
"requestedSn" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int
7 :: Int)
                , Key
"lastSeenSn" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int
760 :: Int)
                ]
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inIdleState)
              IO CommitInfo
cantCommit
              IO [Integer]
IO [TxIdType SimpleTx]
forall tx. IO [tx]
getPendingDeposits
              (IO () -> ClientInput SimpleTx -> IO ()
forall a b. a -> b -> a
const (IO () -> ClientInput SimpleTx -> IO ())
-> IO () -> ClientInput SimpleTx -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
$ TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
-> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel (ClientMessage SimpleTx
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
forall a b. b -> Either a b
Right ClientMessage SimpleTx
clientFailed))
              ApiTransactionTimeout
10
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/snapshot" (SideLoadSnapshotRequest SimpleTx -> Body
forall a. ToJSON a => a -> Body
Aeson.encode (ConfirmedSnapshot SimpleTx -> SideLoadSnapshotRequest SimpleTx
forall tx. ConfirmedSnapshot tx -> SideLoadSnapshotRequest tx
SideLoadSnapshotRequest ConfirmedSnapshot SimpleTx
snapshot))
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
400{matchBody = matchJSON expectedBody}

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"returns 503 on RejectedInputBecauseUnsynced" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
        let reqGen :: IO (SideLoadSnapshotRequest SimpleTx)
reqGen = Gen (SideLoadSnapshotRequest SimpleTx)
-> IO (SideLoadSnapshotRequest SimpleTx)
forall a. Gen a -> IO a
generate (forall a. Arbitrary a => Gen a
arbitrary @(SideLoadSnapshotRequest SimpleTx))
        SideLoadSnapshotRequest ConfirmedSnapshot SimpleTx
snapshot <- IO (SideLoadSnapshotRequest SimpleTx)
reqGen
        let clientFailed :: ClientMessage SimpleTx
clientFailed = RejectedInputBecauseUnsynced{$sel:clientInput:CommandFailed :: ClientInput SimpleTx
clientInput = ConfirmedSnapshot SimpleTx -> ClientInput SimpleTx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot ConfirmedSnapshot SimpleTx
snapshot, $sel:drift:CommandFailed :: NominalDiffTime
drift = NominalDiffTime
10}
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inUnsyncedIdleState)
              IO CommitInfo
cantCommit
              IO [Integer]
IO [TxIdType SimpleTx]
forall tx. IO [tx]
getPendingDeposits
              (IO () -> ClientInput SimpleTx -> IO ()
forall a b. a -> b -> a
const (IO () -> ClientInput SimpleTx -> IO ())
-> IO () -> ClientInput SimpleTx -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
$ TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
-> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel (ClientMessage SimpleTx
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
forall a b. b -> Either a b
Right ClientMessage SimpleTx
clientFailed))
              ApiTransactionTimeout
10
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/snapshot" (SideLoadSnapshotRequest SimpleTx -> Body
forall a. ToJSON a => a -> Body
Aeson.encode (ConfirmedSnapshot SimpleTx -> SideLoadSnapshotRequest SimpleTx
forall tx. ConfirmedSnapshot tx -> SideLoadSnapshotRequest tx
SideLoadSnapshotRequest ConfirmedSnapshot SimpleTx
snapshot)) WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
503

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"GET /snapshot/utxo" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
-> SpecM
     ()
     (TChan
        (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall r a. IO r -> SpecM a r
runIO IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
      String -> (NodeState SimpleTx -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds correctly" ((NodeState SimpleTx -> IO ()) -> Spec)
-> (NodeState SimpleTx -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \NodeState SimpleTx
nodeState -> do
        let Maybe (UTxOType SimpleTx)
utxo :: Maybe (UTxOType SimpleTx) = HeadState SimpleTx -> Maybe (UTxOType SimpleTx)
forall tx. IsTx tx => HeadState tx -> Maybe (UTxOType tx)
getSnapshotUtxo (NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
nodeState)
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
nodeState)
              IO CommitInfo
cantCommit
              IO [Integer]
IO [TxIdType SimpleTx]
forall tx. IO [tx]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/snapshot/utxo"
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` case Maybe (UTxOType SimpleTx)
utxo of
                Maybe (UTxOType SimpleTx)
Nothing -> ResponseMatcher
404
                Just UTxOType SimpleTx
u -> ResponseMatcher
200{matchBody = matchJSON u}
      TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannelSimpleTx <- IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
-> SpecM
     () (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall r a. IO r -> SpecM a r
runIO IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall a. IO (TChan a)
newTChanIO
      String -> (NodeState Tx -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ok response matches schema" ((NodeState Tx -> Property) -> Spec)
-> (NodeState Tx -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \NodeState Tx
nodeState -> do
        let mUTxO :: Maybe (UTxOType Tx)
mUTxO = HeadState Tx -> Maybe (UTxOType Tx)
forall tx. IsTx tx => HeadState tx -> Maybe (UTxOType tx)
getSnapshotUtxo (NodeState Tx -> HeadState Tx
forall tx. NodeState tx -> HeadState tx
headState NodeState Tx
nodeState)
            UTxOType Tx
utxo :: UTxOType Tx = UTxO -> Maybe UTxO -> UTxO
forall a. a -> Maybe a -> a
fromMaybe UTxO
forall a. Monoid a => a
mempty Maybe (UTxOType Tx)
Maybe UTxO
mUTxO
        Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
4
          (Property -> Property)
-> ((String -> IO ()) -> Property) -> (String -> IO ()) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 (UTxO -> Bool
forall era. UTxO era -> Bool
UTxO.null UTxOType Tx
UTxO
utxo) String
"empty"
          (Property -> Property)
-> ((String -> IO ()) -> Property) -> (String -> IO ()) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool -> String -> IO () -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ UTxO -> Bool
forall era. UTxO era -> Bool
UTxO.null UTxOType Tx
UTxO
utxo) String
"non empty"
          (IO () -> Property)
-> ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO ()) -> IO ()
forall (m :: * -> *) r. MonadIO m => (String -> m r) -> m r
withJsonSpecifications
          ((String -> IO ()) -> Property) -> (String -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$ \String
schemaDir -> do
            Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
              ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @Tx
                  Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                  Value
Aeson.Null
                  Chain Tx IO
forall tx. Chain tx IO
dummyChainHandle
                  Environment
testEnvironment
                  PParams LedgerEra
defaultPParams
                  (NodeState Tx -> IO (NodeState Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState Tx
nodeState)
                  IO CommitInfo
cantCommit
                  IO [TxIdType Tx]
IO [TxId]
forall tx. IO [tx]
getPendingDeposits
                  ClientInput Tx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
                  ApiTransactionTimeout
300
                  TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannelSimpleTx
              )
              (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/snapshot/utxo"
                  WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` case Maybe (UTxOType Tx)
mUTxO of
                    Maybe (UTxOType Tx)
Nothing -> ResponseMatcher
404
                    Just UTxOType Tx
_ ->
                      ResponseMatcher
200
                        { matchBody =
                            matchValidJSON
                              (schemaDir </> "api.json")
                              (key "channels" . key "/snapshot/utxo" . key "subscribe" . key "message" . key "payload")
                        }

      String -> ((TxIn, ClosedState Tx) -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"has inlineDatumRaw" (((TxIn, ClosedState Tx) -> Property) -> Spec)
-> ((TxIn, ClosedState Tx) -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \(TxIn
i, ClosedState Tx
closedState) ->
        Gen (TxOut Any) -> (TxOut Any -> IO ()) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (TxOut Any)
forall ctx. Gen (TxOut ctx)
genTxOut ((TxOut Any -> IO ()) -> Property)
-> (TxOut Any -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$ \TxOut Any
o -> do
          let o' :: TxOut CtxUTxO
o' = (TxOutDatum Any Era -> TxOutDatum CtxUTxO Era)
-> TxOut Any -> TxOut CtxUTxO
forall ctx0 era ctx1.
(TxOutDatum ctx0 era -> TxOutDatum ctx1 era)
-> TxOut ctx0 era -> TxOut ctx1 era
modifyTxOutDatum (TxOutDatum CtxUTxO Era
-> TxOutDatum Any Era -> TxOutDatum CtxUTxO Era
forall a b. a -> b -> a
const (TxOutDatum CtxUTxO Era
 -> TxOutDatum Any Era -> TxOutDatum CtxUTxO Era)
-> TxOutDatum CtxUTxO Era
-> TxOutDatum Any Era
-> TxOutDatum CtxUTxO Era
forall a b. (a -> b) -> a -> b
$ Integer -> TxOutDatum CtxUTxO Era
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (Integer
123 :: Integer)) TxOut Any
o
          let UTxOType Tx
utxo' :: UTxOType Tx = [(TxIn, TxOut CtxUTxO)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList [(TxIn
i, TxOut CtxUTxO
o')]
              ClosedState{ConfirmedSnapshot Tx
confirmedSnapshot :: ConfirmedSnapshot Tx
$sel:confirmedSnapshot:ClosedState :: forall tx. ClosedState tx -> ConfirmedSnapshot tx
confirmedSnapshot} = ClosedState Tx
closedState
              confirmedSnapshot' :: ConfirmedSnapshot Tx
confirmedSnapshot' =
                case ConfirmedSnapshot Tx
confirmedSnapshot of
                  InitialSnapshot{HeadId
headId :: HeadId
$sel:headId:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> HeadId
headId} -> InitialSnapshot{HeadId
headId :: HeadId
$sel:headId:InitialSnapshot :: HeadId
headId}
                  ConfirmedSnapshot{Snapshot Tx
snapshot :: Snapshot Tx
$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot, MultiSignature (Snapshot Tx)
signatures :: MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> MultiSignature (Snapshot tx)
signatures} ->
                    let Snapshot{HeadId
headId :: HeadId
$sel:headId:Snapshot :: forall tx. Snapshot tx -> HeadId
headId, SnapshotVersion
version :: SnapshotVersion
$sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version, SnapshotNumber
number :: SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number, [Tx]
confirmed :: [Tx]
$sel:confirmed:Snapshot :: forall tx. Snapshot tx -> [tx]
confirmed, Maybe (UTxOType Tx)
utxoToCommit :: Maybe (UTxOType Tx)
$sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit, Maybe (UTxOType Tx)
utxoToDecommit :: Maybe (UTxOType Tx)
$sel:utxoToDecommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit, Maybe (TxIdType Tx)
depositTxId :: Maybe (TxIdType Tx)
$sel:depositTxId:Snapshot :: forall tx. Snapshot tx -> Maybe (TxIdType tx)
depositTxId, HydraAccumulator
accumulator :: HydraAccumulator
$sel:accumulator:Snapshot :: forall tx. Snapshot tx -> HydraAccumulator
accumulator} = Snapshot Tx
snapshot
                        snapshot' :: Snapshot Tx
snapshot' = Snapshot{HeadId
headId :: HeadId
$sel:headId:Snapshot :: HeadId
headId, SnapshotVersion
version :: SnapshotVersion
$sel:version:Snapshot :: SnapshotVersion
version, SnapshotNumber
number :: SnapshotNumber
$sel:number:Snapshot :: SnapshotNumber
number, [Tx]
confirmed :: [Tx]
$sel:confirmed:Snapshot :: [Tx]
confirmed, $sel:utxo:Snapshot :: UTxOType Tx
utxo = UTxOType Tx
utxo', Maybe (UTxOType Tx)
utxoToCommit :: Maybe (UTxOType Tx)
$sel:utxoToCommit:Snapshot :: Maybe (UTxOType Tx)
utxoToCommit, Maybe (UTxOType Tx)
utxoToDecommit :: Maybe (UTxOType Tx)
$sel:utxoToDecommit:Snapshot :: Maybe (UTxOType Tx)
utxoToDecommit, Maybe (TxIdType Tx)
depositTxId :: Maybe (TxIdType Tx)
$sel:depositTxId:Snapshot :: Maybe (TxIdType Tx)
depositTxId, HydraAccumulator
accumulator :: HydraAccumulator
$sel:accumulator:Snapshot :: HydraAccumulator
accumulator}
                     in ConfirmedSnapshot{$sel:snapshot:InitialSnapshot :: Snapshot Tx
snapshot = Snapshot Tx
snapshot', MultiSignature (Snapshot Tx)
signatures :: MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: MultiSignature (Snapshot Tx)
signatures}
              closedState' :: ClosedState Tx
closedState' = ClosedState Tx
closedState{confirmedSnapshot = confirmedSnapshot'}
          Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
            ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @Tx
                Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                Value
Aeson.Null
                Chain Tx IO
forall tx. Chain tx IO
dummyChainHandle
                Environment
testEnvironment
                PParams LedgerEra
defaultPParams
                (NodeState Tx -> IO (NodeState Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeInSync{$sel:headState:NodeInSync :: HeadState Tx
headState = ClosedState Tx -> HeadState Tx
forall tx. ClosedState tx -> HeadState tx
Closed ClosedState Tx
closedState', $sel:pendingDeposits:NodeInSync :: PendingDeposits Tx
pendingDeposits = PendingDeposits Tx
Map TxId (Deposit Tx)
forall a. Monoid a => a
mempty, $sel:chainPointTime:NodeInSync :: ChainPointTime
chainPointTime = ChainPointTime
zeroChainPointTime})
                IO CommitInfo
cantCommit
                IO [TxIdType Tx]
IO [TxId]
forall tx. IO [tx]
getPendingDeposits
                ClientInput Tx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
                ApiTransactionTimeout
300
                TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannelSimpleTx
            )
            (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/snapshot/utxo"
                WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200
                  { matchBody = MatchBody $ \[Header]
_ Body
body ->
                      let hasInlineDatum :: Bool
hasInlineDatum = Maybe Value -> Bool
forall a. Maybe a -> Bool
isJust (Body
body Body -> Getting (First Value) Body Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Body Value
forall t. AsValue t => Key -> Traversal' t Value
key (String -> Key
forall a. IsString a => String -> a
fromString (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TxIn -> Text
renderTxIn TxIn
i) Getting (First Value) Body Value
-> ((Value -> Const (First Value) Value)
    -> Value -> Const (First Value) Value)
-> Getting (First Value) Body Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"inlineDatumRaw")
                       in if Body
body Body -> Body -> Bool
forall a. Eq a => a -> a -> Bool
== Body
"{}" Bool -> Bool -> Bool
|| Bool
hasInlineDatum
                            then Maybe String
forall a. Maybe a
Nothing
                            else String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"\ninlineDatumRaw not found in body:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Body -> String
forall b a. (Show a, IsString b) => a -> b
show Body
body
                  }

    -- TODO: change API to POST /deposits
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"POST /commit" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      let getHeadId :: IO CommitInfo
getHeadId = CommitInfo -> IO CommitInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommitInfo -> IO CommitInfo) -> CommitInfo -> IO CommitInfo
forall a b. (a -> b) -> a -> b
$ HeadId -> CommitInfo
IncrementalCommit (Gen HeadId -> Int -> HeadId
forall a. Gen a -> Int -> a
generateWith Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary Int
42)
      let openHeadState :: HeadState Tx
openHeadState = OpenState Tx -> HeadState Tx
forall tx. OpenState tx -> HeadState tx
Open (Gen (OpenState Tx) -> Int -> OpenState Tx
forall a. Gen a -> Int -> a
generateWith Gen (OpenState Tx)
forall a. Arbitrary a => Gen a
arbitrary Int
42)
      TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannel <- IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
-> SpecM
     () (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall r a. IO r -> SpecM a r
runIO IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall a. IO (TChan a)
newTChanIO
      let workingChainHandle :: Chain Tx IO
workingChainHandle =
            Chain Tx IO
forall tx. Chain tx IO
dummyChainHandle
              { draftDepositTx = \HeadId
_ PParams LedgerEra
_ ConfirmedSnapshot Tx
_ CommitBlueprintTx Tx
_ UTCTime
_ Maybe AddressInEra
_ -> do
                  Tx
tx <- Gen Tx -> IO Tx
forall a. Gen a -> IO a
generate (Gen Tx -> IO Tx) -> Gen Tx -> IO Tx
forall a b. (a -> b) -> a -> b
$ forall a. Arbitrary a => Gen a
arbitrary @Tx
                  Either (PostTxError Tx) Tx -> IO (Either (PostTxError Tx) Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (PostTxError Tx) Tx -> IO (Either (PostTxError Tx) Tx))
-> Either (PostTxError Tx) Tx -> IO (Either (PostTxError Tx) Tx)
forall a b. (a -> b) -> a -> b
$ Tx -> Either (PostTxError Tx) Tx
forall a b. b -> Either a b
Right Tx
tx
              }
      String -> (DraftCommitTxRequest Tx -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds on valid requests" ((DraftCommitTxRequest Tx -> IO ()) -> Spec)
-> (DraftCommitTxRequest Tx -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \(DraftCommitTxRequest Tx
request :: DraftCommitTxRequest Tx) ->
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( Tracer IO APIServerLog
-> Value
-> Chain Tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState Tx)
-> IO CommitInfo
-> IO [TxIdType Tx]
-> (ClientInput Tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
-> Application
forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain Tx IO
workingChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState Tx -> IO (NodeState Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeInSync{$sel:headState:NodeInSync :: HeadState Tx
headState = HeadState Tx
openHeadState, $sel:pendingDeposits:NodeInSync :: PendingDeposits Tx
pendingDeposits = PendingDeposits Tx
Map TxId (Deposit Tx)
forall a. Monoid a => a
mempty, $sel:chainPointTime:NodeInSync :: ChainPointTime
chainPointTime = ChainPointTime
zeroChainPointTime})
              IO CommitInfo
getHeadId
              IO [TxIdType Tx]
IO [TxId]
forall tx. IO [tx]
getPendingDeposits
              ClientInput Tx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/commit" (DraftCommitTxRequest Tx -> Body
forall a. ToJSON a => a -> Body
Aeson.encode DraftCommitTxRequest Tx
request)
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200

      String -> (DraftCommitTxRequest Tx -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds 400 when deposit is too large to increment" ((DraftCommitTxRequest Tx -> IO ()) -> Spec)
-> (DraftCommitTxRequest Tx -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \(DraftCommitTxRequest Tx
request :: DraftCommitTxRequest Tx) ->
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( Tracer IO APIServerLog
-> Value
-> Chain Tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState Tx)
-> IO CommitInfo
-> IO [TxIdType Tx]
-> (ClientInput Tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
-> Application
forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              ( Chain Tx IO
forall tx. Chain tx IO
dummyChainHandle
                  { draftDepositTx = \HeadId
_ PParams LedgerEra
_ ConfirmedSnapshot Tx
_ CommitBlueprintTx Tx
_ UTCTime
_ Maybe AddressInEra
_ ->
                      Either (PostTxError Tx) Tx -> IO (Either (PostTxError Tx) Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (PostTxError Tx) Tx -> IO (Either (PostTxError Tx) Tx))
-> Either (PostTxError Tx) Tx -> IO (Either (PostTxError Tx) Tx)
forall a b. (a -> b) -> a -> b
$
                        PostTxError Tx -> Either (PostTxError Tx) Tx
forall a b. a -> Either a b
Left
                          DepositTooLarge
                            { $sel:estimatedTxSize:NoSeedInput :: Natural
estimatedTxSize = Natural
20000
                            , $sel:maximumTxSize:NoSeedInput :: Natural
maximumTxSize = Natural
16384
                            , $sel:estimatedValueSize:NoSeedInput :: Natural
estimatedValueSize = Natural
6000
                            , $sel:maximumValueSize:NoSeedInput :: Natural
maximumValueSize = Natural
5000
                            }
                  }
              )
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState Tx -> IO (NodeState Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeInSync{$sel:headState:NodeInSync :: HeadState Tx
headState = HeadState Tx
openHeadState, $sel:pendingDeposits:NodeInSync :: PendingDeposits Tx
pendingDeposits = PendingDeposits Tx
Map TxId (Deposit Tx)
forall a. Monoid a => a
mempty, $sel:chainPointTime:NodeInSync :: ChainPointTime
chainPointTime = ChainPointTime
zeroChainPointTime})
              IO CommitInfo
getHeadId
              IO [TxIdType Tx]
IO [TxId]
forall tx. IO [tx]
getPendingDeposits
              ClientInput Tx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/commit" (DraftCommitTxRequest Tx -> Body
forall a. ToJSON a => a -> Body
Aeson.encode DraftCommitTxRequest Tx
request)
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
400

      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"reject deposits with less than min ADA" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$ do
        Gen UTxO -> (UTxO -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen UTxO
genUTxOAdaOnlyOfSize Int
1) ((UTxO -> Property) -> Property) -> (UTxO -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(UTxO
utxo :: UTxO) -> do
          let result :: Either (PostTxError Tx) ()
result = PParams LedgerEra -> UTxO -> Either (PostTxError Tx) ()
rejectLowDeposits PParams LedgerEra
pparams UTxO
utxo
          case Either (PostTxError Tx) ()
result of
            Left DepositTooLow{Coin
providedValue :: Coin
$sel:providedValue:NoSeedInput :: forall tx. PostTxError tx -> Coin
providedValue, Coin
minimumValue :: Coin
$sel:minimumValue:NoSeedInput :: forall tx. PostTxError tx -> Coin
minimumValue} ->
              Property -> Property
forall prop. Testable prop => prop -> Property
property (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                Coin
minimumValue Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
providedValue
                  Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Minimum value: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show Coin
minimumValue String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Provided value: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show Coin
providedValue)
            Either (PostTxError Tx) ()
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True

      -- A deposit is fine exactly when each of its outputs is fine on its own.
      -- Check the whole-UTxO verdict against checking every output individually:
      -- if the walk ever compared one output's ada to another output's minimum,
      -- the two would disagree. Uses several outputs so such a mix-up can show.
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"rejects a multi-output deposit exactly when some output alone is rejected" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        Gen UTxO -> (UTxO -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
20) Gen Int -> (Int -> Gen UTxO) -> Gen UTxO
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Gen UTxO
genUTxOAdaOnlyOfSize) ((UTxO -> Property) -> Property) -> (UTxO -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(UTxO
utxo :: UTxO) ->
          let outputs :: [(TxIn, TxOut CtxUTxO)]
outputs = UTxO -> [(TxIn, TxOut CtxUTxO)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
utxo
              eachOutputOk :: Bool
eachOutputOk =
                ((TxIn, TxOut CtxUTxO) -> Bool) -> [(TxIn, TxOut CtxUTxO)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(TxIn
i, TxOut CtxUTxO
o) -> Either (PostTxError Tx) () -> Bool
forall a b. Either a b -> Bool
isRight (PParams LedgerEra -> UTxO -> Either (PostTxError Tx) ()
rejectLowDeposits PParams LedgerEra
pparams (TxIn -> TxOut CtxUTxO -> UTxO
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton TxIn
i TxOut CtxUTxO
o))) [(TxIn, TxOut CtxUTxO)]
outputs
           in Either (PostTxError Tx) () -> Bool
forall a b. Either a b -> Bool
isRight (PParams LedgerEra -> UTxO -> Either (PostTxError Tx) ()
rejectLowDeposits PParams LedgerEra
pparams UTxO
utxo) Bool -> Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Bool
eachOutputOk
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"UTxO size: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show ([(TxIn, TxOut CtxUTxO)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TxIn, TxOut CtxUTxO)]
outputs))

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"POST /transaction" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      let mkReq :: SimpleTx -> LBS.ByteString
          mkReq :: SimpleTx -> Body
mkReq SimpleTx
tx = SubmitL2TxRequest SimpleTx -> Body
forall a. ToJSON a => a -> Body
encode (SubmitL2TxRequest SimpleTx -> Body)
-> SubmitL2TxRequest SimpleTx -> Body
forall a b. (a -> b) -> a -> b
$ SimpleTx -> SubmitL2TxRequest SimpleTx
forall tx. tx -> SubmitL2TxRequest tx
SubmitL2TxRequest SimpleTx
tx
          testTx :: SimpleTx
testTx = Integer -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx Integer
42 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
          testHeadId :: HeadId
testHeadId = Gen HeadId -> Int -> HeadId
forall a. Gen a -> Int -> a
generateWith Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary Int
42
      UTCTime
now <- IO UTCTime -> SpecM () UTCTime
forall r a. IO r -> SpecM a r
runIO IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime

      String -> IO () -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"returns 202 Accepted on timeout" (IO () -> Spec) -> IO () -> Spec
forall a b. (a -> b) -> a -> b
$ do
        TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inIdleState)
              (CommitInfo -> IO CommitInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommitInfo
CannotCommit)
              ([Integer] -> IO [Integer]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
              (IO () -> ClientInput SimpleTx -> IO ()
forall a b. a -> b -> a
const (IO () -> ClientInput SimpleTx -> IO ())
-> IO () -> ClientInput SimpleTx -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              ApiTransactionTimeout
0
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/transaction" (SimpleTx -> Body
mkReq SimpleTx
testTx) WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
202

      String -> IO () -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"returns 200 OK on confirmed snapshot" (IO () -> Spec) -> IO () -> Spec
forall a b. (a -> b) -> a -> b
$ do
        TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
        let utxo' :: UTxOType SimpleTx
utxo' = UTxOType SimpleTx
forall a. Monoid a => a
mempty
            accumulator :: HydraAccumulator
accumulator = UTxOType SimpleTx -> HydraAccumulator
forall tx. IsTx tx => UTxOType tx -> HydraAccumulator
Accumulator.buildFromUTxO UTxOType SimpleTx
utxo'
            snapshot :: Snapshot SimpleTx
snapshot =
              Snapshot
                { $sel:headId:Snapshot :: HeadId
headId = HeadId
testHeadId
                , $sel:version:Snapshot :: SnapshotVersion
version = SnapshotVersion
1
                , $sel:number:Snapshot :: SnapshotNumber
number = SnapshotNumber
7
                , $sel:confirmed:Snapshot :: [SimpleTx]
confirmed = [SimpleTx
testTx]
                , $sel:utxo:Snapshot :: UTxOType SimpleTx
utxo = UTxOType SimpleTx
utxo'
                , $sel:utxoToCommit:Snapshot :: Maybe (UTxOType SimpleTx)
utxoToCommit = Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Monoid a => a
mempty
                , $sel:utxoToDecommit:Snapshot :: Maybe (UTxOType SimpleTx)
utxoToDecommit = Maybe (Set SimpleTxOut)
Maybe (UTxOType SimpleTx)
forall a. Monoid a => a
mempty
                , $sel:depositTxId:Snapshot :: Maybe (TxIdType SimpleTx)
depositTxId = Maybe Integer
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing
                , HydraAccumulator
$sel:accumulator:Snapshot :: HydraAccumulator
accumulator :: HydraAccumulator
accumulator
                }
            event :: TimedServerOutput SimpleTx
event =
              TimedServerOutput
                { $sel:output:TimedServerOutput :: ServerOutput SimpleTx
output = SnapshotConfirmed{$sel:snapshot:NetworkConnected :: Snapshot SimpleTx
snapshot = Snapshot SimpleTx
snapshot, $sel:signatures:NetworkConnected :: MultiSignature (Snapshot SimpleTx)
signatures = MultiSignature (Snapshot SimpleTx)
forall a. Monoid a => a
mempty, $sel:headId:NetworkConnected :: HeadId
headId = HeadId
testHeadId}
                , $sel:seq:TimedServerOutput :: Natural
seq = Natural
0
                , $sel:time:TimedServerOutput :: UTCTime
time = UTCTime
now
                }
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inIdleState)
              (CommitInfo -> IO CommitInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommitInfo
CannotCommit)
              ([Integer] -> IO [Integer]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
              (IO () -> ClientInput SimpleTx -> IO ()
forall a b. a -> b -> a
const (IO () -> ClientInput SimpleTx -> IO ())
-> IO () -> ClientInput SimpleTx -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
$ TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
-> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel (TimedServerOutput SimpleTx
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
forall a b. a -> Either a b
Left TimedServerOutput SimpleTx
event))
              ApiTransactionTimeout
10
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/transaction" (SimpleTx -> Body
mkReq SimpleTx
testTx) WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200

      String -> IO () -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"returns 400 Bad Request on invalid tx" (IO () -> Spec) -> IO () -> Spec
forall a b. (a -> b) -> a -> b
$ do
        TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
        let validationError :: ValidationError
validationError = Text -> ValidationError
ValidationError Text
"some error"
            event :: TimedServerOutput SimpleTx
event =
              TimedServerOutput
                { $sel:output:TimedServerOutput :: ServerOutput SimpleTx
output =
                    TxInvalid
                      { $sel:headId:NetworkConnected :: HeadId
headId = HeadId
testHeadId
                      , $sel:utxo:NetworkConnected :: UTxOType SimpleTx
utxo = Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
                      , $sel:transaction:NetworkConnected :: SimpleTx
transaction = SimpleTx
testTx
                      , $sel:validationError:NetworkConnected :: ValidationError
validationError = ValidationError
validationError
                      }
                , $sel:seq:TimedServerOutput :: Natural
seq = Natural
0
                , $sel:time:TimedServerOutput :: UTCTime
time = UTCTime
now
                }
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inIdleState)
              (CommitInfo -> IO CommitInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommitInfo
CannotCommit)
              ([Integer] -> IO [Integer]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
              (IO () -> ClientInput SimpleTx -> IO ()
forall a b. a -> b -> a
const (IO () -> ClientInput SimpleTx -> IO ())
-> IO () -> ClientInput SimpleTx -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
$ TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
-> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel (TimedServerOutput SimpleTx
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
forall a b. a -> Either a b
Left TimedServerOutput SimpleTx
event))
              ApiTransactionTimeout
10
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/transaction" (SimpleTx -> Body
mkReq SimpleTx
testTx) WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
400

      String -> IO () -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"returns 503 on RejectedInputBecauseUnsynced" (IO () -> Spec) -> IO () -> Spec
forall a b. (a -> b) -> a -> b
$ do
        TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
        let clientFailed :: ClientMessage SimpleTx
clientFailed = RejectedInputBecauseUnsynced{$sel:clientInput:CommandFailed :: ClientInput SimpleTx
clientInput = SimpleTx -> ClientInput SimpleTx
forall tx. tx -> ClientInput tx
NewTx SimpleTx
testTx, $sel:drift:CommandFailed :: NominalDiffTime
drift = NominalDiffTime
10}
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inUnsyncedIdleState)
              (CommitInfo -> IO CommitInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommitInfo
CannotCommit)
              ([Integer] -> IO [Integer]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
              (IO () -> ClientInput SimpleTx -> IO ()
forall a b. a -> b -> a
const (IO () -> ClientInput SimpleTx -> IO ())
-> IO () -> ClientInput SimpleTx -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
$ TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
-> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel (ClientMessage SimpleTx
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
forall a b. b -> Either a b
Right ClientMessage SimpleTx
clientFailed))
              ApiTransactionTimeout
10
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/transaction" (SimpleTx -> Body
mkReq SimpleTx
testTx) WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
503

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"POST /decommit" (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
"returns 202 on timeout" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
        let tx :: SimpleTx
tx = Integer -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx Integer
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inIdleState)
              (CommitInfo -> IO CommitInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommitInfo
CannotCommit)
              ([Integer] -> IO [Integer]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
              (IO () -> ClientInput SimpleTx -> IO ()
forall a b. a -> b -> a
const (IO () -> ClientInput SimpleTx -> IO ())
-> IO () -> ClientInput SimpleTx -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              ApiTransactionTimeout
0
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/decommit" (SimpleTx -> Body
forall a. ToJSON a => a -> Body
encode SimpleTx
tx) WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
202

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"returns 200 on DecommitFinalized" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
        let tx :: SimpleTx
tx = Integer -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx Integer
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
        UTCTime
now' <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
        let event :: TimedServerOutput SimpleTx
event =
              TimedServerOutput
                { $sel:output:TimedServerOutput :: ServerOutput SimpleTx
output = DecommitFinalized{$sel:headId:NetworkConnected :: HeadId
headId = Gen HeadId -> Int -> HeadId
forall a. Gen a -> Int -> a
generateWith Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary Int
42, $sel:distributedUTxO:NetworkConnected :: UTxOType SimpleTx
distributedUTxO = Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty}
                , $sel:seq:TimedServerOutput :: Natural
seq = Natural
0
                , $sel:time:TimedServerOutput :: UTCTime
time = UTCTime
now'
                }
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inIdleState)
              (CommitInfo -> IO CommitInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommitInfo
CannotCommit)
              ([Integer] -> IO [Integer]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
              (IO () -> ClientInput SimpleTx -> IO ()
forall a b. a -> b -> a
const (IO () -> ClientInput SimpleTx -> IO ())
-> IO () -> ClientInput SimpleTx -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
$ TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
-> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel (TimedServerOutput SimpleTx
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
forall a b. a -> Either a b
Left TimedServerOutput SimpleTx
event))
              ApiTransactionTimeout
10
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/decommit" (SimpleTx -> Body
forall a. ToJSON a => a -> Body
encode SimpleTx
tx) WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"returns 400 on DecommitInvalid or CommandFailed" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
        let tx :: SimpleTx
tx = Integer -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx Integer
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
        UTCTime
now' <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
        let invalid :: TimedServerOutput SimpleTx
invalid =
              TimedServerOutput
                { $sel:output:TimedServerOutput :: ServerOutput SimpleTx
output = DecommitInvalid{$sel:headId:NetworkConnected :: HeadId
headId = Gen HeadId -> Int -> HeadId
forall a. Gen a -> Int -> a
generateWith Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary Int
42, $sel:decommitTx:NetworkConnected :: SimpleTx
decommitTx = SimpleTx
tx, $sel:decommitInvalidReason:NetworkConnected :: DecommitInvalidReason SimpleTx
decommitInvalidReason = TxIdType SimpleTx -> DecommitInvalidReason SimpleTx
forall tx. TxIdType tx -> DecommitInvalidReason tx
DecommitAlreadyInFlight (SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId SimpleTx
tx)}
                , $sel:seq:TimedServerOutput :: Natural
seq = Natural
0
                , $sel:time:TimedServerOutput :: UTCTime
time = UTCTime
now'
                }
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inIdleState)
              (CommitInfo -> IO CommitInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommitInfo
CannotCommit)
              ([Integer] -> IO [Integer]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
              (IO () -> ClientInput SimpleTx -> IO ()
forall a b. a -> b -> a
const (IO () -> ClientInput SimpleTx -> IO ())
-> IO () -> ClientInput SimpleTx -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
$ TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
-> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel (TimedServerOutput SimpleTx
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
forall a b. a -> Either a b
Left TimedServerOutput SimpleTx
invalid))
              ApiTransactionTimeout
10
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/decommit" (SimpleTx -> Body
forall a. ToJSON a => a -> Body
encode SimpleTx
tx) WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
400

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"returns 503 on RejectedInputBecauseUnsynced" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
        let tx :: SimpleTx
tx = Integer -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx Integer
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
        let clientFailed :: ClientMessage SimpleTx
clientFailed = RejectedInputBecauseUnsynced{$sel:clientInput:CommandFailed :: ClientInput SimpleTx
clientInput = SimpleTx -> ClientInput SimpleTx
forall tx. tx -> ClientInput tx
Decommit SimpleTx
tx, $sel:drift:CommandFailed :: NominalDiffTime
drift = NominalDiffTime
10}
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inUnsyncedIdleState)
              (CommitInfo -> IO CommitInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommitInfo
CannotCommit)
              ([Integer] -> IO [Integer]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
              (IO () -> ClientInput SimpleTx -> IO ()
forall a b. a -> b -> a
const (IO () -> ClientInput SimpleTx -> IO ())
-> IO () -> ClientInput SimpleTx -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
$ TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
-> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel (ClientMessage SimpleTx
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
forall a b. b -> Either a b
Right ClientMessage SimpleTx
clientFailed))
              ApiTransactionTimeout
10
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/decommit" (SimpleTx -> Body
forall a. ToJSON a => a -> Body
encode SimpleTx
tx) WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
503

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"DELETE /commits/:txid full unencoded TxId" (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
"returns 202 on timeout" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannel <- IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall a. IO (TChan a)
newTChanIO
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @Tx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain Tx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState Tx -> IO (NodeState Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeState Tx -> IO (NodeState Tx))
-> NodeState Tx -> IO (NodeState Tx)
forall a b. (a -> b) -> a -> b
$ Text -> NodeState Tx
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Not called")
              (CommitInfo -> IO CommitInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommitInfo
CannotCommit)
              ([TxId] -> IO [TxId]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
              (IO () -> ClientInput Tx -> IO ()
forall a b. a -> b -> a
const (IO () -> ClientInput Tx -> IO ())
-> IO () -> ClientInput Tx -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              ApiTransactionTimeout
0
              TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            -- endpoint path formats the txid as JSON in the path; spec helper keeps the path
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
delete ByteString
"/commits/d2c03a20bce36bf86888827f642e69d259ed12c8322a71a9089b057ea81a25ac" WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
202

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"DELETE /commits/:txid" (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
"returns 202 on timeout" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
        let txidJson :: ByteString
txidJson = Body -> ByteString
LBS.toStrict (Integer -> Body
forall a. ToJSON a => a -> Body
encode (SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId (Integer -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx Integer
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty)))
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inIdleState)
              (CommitInfo -> IO CommitInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommitInfo
CannotCommit)
              ([Integer] -> IO [Integer]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
              (IO () -> ClientInput SimpleTx -> IO ()
forall a b. a -> b -> a
const (IO () -> ClientInput SimpleTx -> IO ())
-> IO () -> ClientInput SimpleTx -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              ApiTransactionTimeout
0
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            -- endpoint path formats the txid as JSON in the path; spec helper keeps the path
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
delete (ByteString
"/commits/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
txidJson) WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
202

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"returns 200 on CommitRecovered" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
        UTCTime
now' <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
        let event :: TimedServerOutput SimpleTx
event =
              TimedServerOutput
                { $sel:output:TimedServerOutput :: ServerOutput SimpleTx
output = CommitRecovered{$sel:headId:NetworkConnected :: HeadId
headId = Gen HeadId -> Int -> HeadId
forall a. Gen a -> Int -> a
generateWith Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary Int
42, $sel:recoveredUTxO:NetworkConnected :: UTxOType SimpleTx
recoveredUTxO = Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty, $sel:recoveredTxId:NetworkConnected :: TxIdType SimpleTx
recoveredTxId = SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId (Integer -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx Integer
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty)}
                , $sel:seq:TimedServerOutput :: Natural
seq = Natural
0
                , $sel:time:TimedServerOutput :: UTCTime
time = UTCTime
now'
                }
        let txidText :: ByteString
txidText = Body -> ByteString
LBS.toStrict (Integer -> Body
forall a. ToJSON a => a -> Body
encode (SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId (Integer -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx Integer
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty)))
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inIdleState)
              (CommitInfo -> IO CommitInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommitInfo
CannotCommit)
              ([Integer] -> IO [Integer]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
              (IO () -> ClientInput SimpleTx -> IO ()
forall a b. a -> b -> a
const (IO () -> ClientInput SimpleTx -> IO ())
-> IO () -> ClientInput SimpleTx -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
$ TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
-> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel (TimedServerOutput SimpleTx
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
forall a b. a -> Either a b
Left TimedServerOutput SimpleTx
event))
              ApiTransactionTimeout
10
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
delete (ByteString
"/commits/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
txidText) WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"returns 503 on RejectedInputBecauseUnsynced" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
        let tx :: SimpleTx
tx = Integer -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx Integer
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
        let txidText :: ByteString
txidText = Body -> ByteString
LBS.toStrict (Integer -> Body
forall a. ToJSON a => a -> Body
encode (SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId SimpleTx
tx))
        let clientFailed :: ClientMessage SimpleTx
clientFailed = RejectedInputBecauseUnsynced{$sel:clientInput:CommandFailed :: ClientInput SimpleTx
clientInput = TxIdType SimpleTx -> ClientInput SimpleTx
forall tx. TxIdType tx -> ClientInput tx
Recover (SimpleTx -> TxIdType SimpleTx
forall tx. IsTx tx => tx -> TxIdType tx
txId SimpleTx
tx), $sel:drift:CommandFailed :: NominalDiffTime
drift = NominalDiffTime
10}
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
inUnsyncedIdleState)
              (CommitInfo -> IO CommitInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommitInfo
CannotCommit)
              ([Integer] -> IO [Integer]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
              (IO () -> ClientInput SimpleTx -> IO ()
forall a b. a -> b -> a
const (IO () -> ClientInput SimpleTx -> IO ())
-> IO () -> ClientInput SimpleTx -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
$ TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
-> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel (ClientMessage SimpleTx
-> Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)
forall a b. b -> Either a b
Right ClientMessage SimpleTx
clientFailed))
              ApiTransactionTimeout
10
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
delete (ByteString
"/commits/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
txidText) WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
503

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"CBOR negotiation" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
-> SpecM
     ()
     (TChan
        (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall r a. IO r -> SpecM a r
runIO IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO

      String -> (NodeState SimpleTx -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"GET /snapshot/last-seen responds CBOR given Accept: application/cbor" ((NodeState SimpleTx -> IO ()) -> Spec)
-> (NodeState SimpleTx -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \NodeState SimpleTx
nodeState -> do
        let SeenSnapshot SimpleTx
seenSnapshot :: SeenSnapshot SimpleTx = HeadState SimpleTx -> SeenSnapshot SimpleTx
forall tx. IsTx tx => HeadState tx -> SeenSnapshot tx
getSeenSnapshot (NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
nodeState)
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
nodeState)
              IO CommitInfo
cantCommit
              IO [Integer]
IO [TxIdType SimpleTx]
forall tx. IO [tx]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString
-> ByteString -> [Header] -> Body -> WaiSession () SResponse
forall st.
ByteString
-> ByteString -> [Header] -> Body -> WaiSession st SResponse
Wai.request ByteString
"GET" ByteString
"/snapshot/last-seen" [(HeaderName
"Accept", ByteString
"application/cbor")] Body
forall a. Monoid a => a
mempty
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200
                { matchHeaders = ["Content-Type" <:> "application/cbor"]
                , matchBody = matchCBOR seenSnapshot
                }

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"POST /cardano-transaction accepts a CBOR-encoded transaction" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        let tx :: SimpleTx
tx = Integer -> UTxOType SimpleTx -> UTxOType SimpleTx -> SimpleTx
SimpleTx Integer
1 Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty Set SimpleTxOut
UTxOType SimpleTx
forall a. Monoid a => a
mempty
            submittingChainHandle :: Chain SimpleTx IO
            submittingChainHandle :: Chain SimpleTx IO
submittingChainHandle = Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle{submitTx = const (pure ())}
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
submittingChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              IO (NodeState SimpleTx)
getNodeState
              IO CommitInfo
cantCommit
              IO [Integer]
IO [TxIdType SimpleTx]
forall tx. IO [tx]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString
-> ByteString -> [Header] -> Body -> WaiSession () SResponse
forall st.
ByteString
-> ByteString -> [Header] -> Body -> WaiSession st SResponse
Wai.request
              ByteString
"POST"
              ByteString
"/cardano-transaction"
              [(HeaderName
"Content-Type", ByteString
"application/cbor"), (HeaderName
"Accept", ByteString
"application/cbor")]
              (ByteString -> Body
LBS.fromStrict (ByteString -> Body) -> ByteString -> Body
forall a b. (a -> b) -> a -> b
$ SimpleTx -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' SimpleTx
tx)
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200
                { matchHeaders = ["Content-Type" <:> "application/cbor"]
                , matchBody = matchCBOR TransactionSubmitted
                }

      String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"responds 400 given a malformed CBOR body with Content-Type: application/cbor" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              IO (NodeState SimpleTx)
getNodeState
              IO CommitInfo
cantCommit
              IO [Integer]
IO [TxIdType SimpleTx]
forall tx. IO [tx]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString
-> ByteString -> [Header] -> Body -> WaiSession () SResponse
forall st.
ByteString
-> ByteString -> [Header] -> Body -> WaiSession st SResponse
Wai.request
              ByteString
"POST"
              ByteString
"/cardano-transaction"
              [(HeaderName
"Content-Type", ByteString
"application/cbor")]
              Body
"not a valid CBOR transaction"
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
400

      String -> (NodeState SimpleTx -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"GET /snapshot/last-seen still responds JSON without CBOR headers" ((NodeState SimpleTx -> IO ()) -> Spec)
-> (NodeState SimpleTx -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \NodeState SimpleTx
nodeState -> do
        let SeenSnapshot SimpleTx
seenSnapshot :: SeenSnapshot SimpleTx = HeadState SimpleTx -> SeenSnapshot SimpleTx
forall tx. IsTx tx => HeadState tx -> SeenSnapshot tx
getSeenSnapshot (NodeState SimpleTx -> HeadState SimpleTx
forall tx. NodeState tx -> HeadState tx
headState NodeState SimpleTx
nodeState)
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Value
Aeson.Null
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              (NodeState SimpleTx -> IO (NodeState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeState SimpleTx
nodeState)
              IO CommitInfo
cantCommit
              IO [Integer]
IO [TxIdType SimpleTx]
forall tx. IO [tx]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/snapshot/last-seen"
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200
                { matchHeaders = ["Content-Type" <:> "application/json"]
                , matchBody = matchJSON seenSnapshot
                }

-- * Helpers

-- | Create a 'ResponseMatcher' or 'MatchBody' from a JSON serializable value
-- (using their 'IsString' instances).
matchJSON :: (IsString s, ToJSON a) => a -> s
matchJSON :: forall s a. (IsString s, ToJSON a) => a -> s
matchJSON = String -> s
forall a. IsString a => String -> a
fromString (String -> s) -> (a -> String) -> a -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Body -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Body -> String) -> (a -> Body) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Body
forall a. ToJSON a => a -> Body
encode

-- | Create a 'MatchBody' that CBOR-decodes the response body and compares it
-- to an expected value.
matchCBOR :: (Eq a, Show a, FromCBOR a) => a -> MatchBody
matchCBOR :: forall a. (Eq a, Show a, FromCBOR a) => a -> MatchBody
matchCBOR a
expected =
  ([Header] -> Body -> Maybe String) -> MatchBody
MatchBody (([Header] -> Body -> Maybe String) -> MatchBody)
-> ([Header] -> Body -> Maybe String) -> MatchBody
forall a b. (a -> b) -> a -> b
$ \[Header]
_headers Body
body ->
    case ByteString -> Either DecoderError a
forall a. FromCBOR a => ByteString -> Either DecoderError a
decodeFull' (Body -> ByteString
forall l s. LazyStrict l s => l -> s
toStrict Body
body) of
      Left DecoderError
err -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"failed to decode CBOR body: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DecoderError -> String
forall b a. (Show a, IsString b) => a -> b
show DecoderError
err
      Right a
actual
        | a
actual a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
expected -> Maybe String
forall a. Maybe a
Nothing
        | Bool
otherwise ->
            String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"decoded CBOR body: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall b a. (Show a, IsString b) => a -> b
show a
actual String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\ndoes not match expected: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall b a. (Show a, IsString b) => a -> b
show a
expected

-- | Create a 'MatchBody' that validates the returned JSON response against a
-- schema. NOTE: This raises impure exceptions, so only use it in this test
-- suite.
matchValidJSON :: FilePath -> SchemaSelector -> MatchBody
matchValidJSON :: String -> SchemaSelector -> MatchBody
matchValidJSON String
schemaFile SchemaSelector
selector =
  ([Header] -> Body -> Maybe String) -> MatchBody
MatchBody (([Header] -> Body -> Maybe String) -> MatchBody)
-> ([Header] -> Body -> Maybe String) -> MatchBody
forall a b. (a -> b) -> a -> b
$ \[Header]
_headers Body
body ->
    case Body -> Either String Value
forall a. FromJSON a => Body -> Either String a
eitherDecode Body
body of
      Left String
err -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"failed to decode body: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
      Right Value
value -> Value -> Maybe String
validateJSONPure Value
value
 where
  -- NOTE: Uses unsafePerformIO to create a pure API although we are actually
  -- calling an external program to verify the schema. This is fine, because the
  -- call is referentially transparent and any given invocation of schema file,
  -- selector and value will always yield the same result and can be shared.
  validateJSONPure :: Value -> Maybe String
validateJSONPure Value
value =
    IO (Maybe String) -> Maybe String
forall a. IO a -> a
unsafePerformIO (IO (Maybe String) -> Maybe String)
-> IO (Maybe String) -> Maybe String
forall a b. (a -> b) -> a -> b
$ do
      HasCallStack => String -> SchemaSelector -> Value -> IO ()
String -> SchemaSelector -> Value -> IO ()
validateJSON String
schemaFile (Value -> f Value) -> Value -> f Value
SchemaSelector
selector Value
value
      Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing