module Hydra.API.HTTPServerSpec where

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

import Cardano.Api.UTxO qualified as UTxO
import Control.Lens ((^?))
import Data.Aeson (Result (Error, Success), eitherDecode, encode, fromJSON)
import Data.Aeson qualified as Aeson
import Data.Aeson.Lens (key, nth)
import Data.Text qualified as Text
import Hydra.API.HTTPServer (
  DraftCommitTxRequest (..),
  DraftCommitTxResponse (..),
  SideLoadSnapshotRequest (..),
  SubmitTxRequest (..),
  TransactionSubmitted,
  httpApp,
 )
import Hydra.API.ServerOutput (CommitInfo (CannotCommit, NormalCommit))
import Hydra.API.ServerSpec (dummyChainHandle)
import Hydra.Cardano.Api (
  mkTxOutDatumInline,
  modifyTxOutDatum,
  renderTxIn,
  serialiseToTextEnvelope,
 )
import Hydra.Chain (Chain (draftCommitTx), PostTxError (..), draftDepositTx)
import Hydra.HeadLogic.State (SeenSnapshot (..))
import Hydra.JSONSchema (SchemaSelector, prop_validateJSONSchema, validateJSON, withJsonSpecifications)
import Hydra.Ledger.Cardano (Tx)
import Hydra.Ledger.Simple (SimpleTx)
import Hydra.Logging (nullTracer)
import Hydra.Tx (ConfirmedSnapshot (..))
import Hydra.Tx.IsTx (UTxOType)
import System.FilePath ((</>))
import System.IO.Unsafe (unsafePerformIO)
import Test.Aeson.GenericSpecs (roundtripAndGoldenSpecs)
import Test.Hspec.Wai (MatchBody (..), ResponseMatcher (matchBody), get, post, shouldRespondWith, with)
import Test.Hspec.Wai.Internal (withApplication)
import Test.Hydra.Node.Fixture (testEnvironment)
import Test.Hydra.Tx.Fixture (defaultPParams)
import Test.Hydra.Tx.Gen (genTxOut)
import Test.QuickCheck (
  checkCoverage,
  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)))

    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"

    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 getNothing :: IO (Maybe a)
getNothing = Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        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 [a]
getPendingDeposits = [a] -> IO [a]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        putClientInput :: b -> IO ()
putClientInput = IO () -> b -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        getNoSeenSnapshot :: IO (SeenSnapshot tx)
getNoSeenSnapshot = SeenSnapshot tx -> IO (SeenSnapshot tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SeenSnapshot tx
forall tx. SeenSnapshot tx
NoSeenSnapshot

    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
      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
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO (SeenSnapshot tx)
-> IO (Maybe (ConfirmedSnapshot tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              IO CommitInfo
cantCommit
              IO (Maybe (Set SimpleTxOut))
IO (Maybe (UTxOType SimpleTx))
forall {a}. IO (Maybe a)
getNothing
              IO (SeenSnapshot SimpleTx)
forall {tx}. IO (SeenSnapshot tx)
getNoSeenSnapshot
              IO (Maybe (ConfirmedSnapshot SimpleTx))
forall {a}. IO (Maybe a)
getNothing
              IO [Integer]
IO [TxIdType SimpleTx]
forall {a}. IO [a]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall {b}. b -> IO ()
putClientInput
        )
        (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 /snapshot/last-seen" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> (SeenSnapshot SimpleTx -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds correctly" ((SeenSnapshot SimpleTx -> IO ()) -> Spec)
-> (SeenSnapshot SimpleTx -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \SeenSnapshot SimpleTx
seenSnapshot -> do
        let getSeenSnapshot :: IO (SeenSnapshot SimpleTx)
getSeenSnapshot = SeenSnapshot SimpleTx -> IO (SeenSnapshot SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SeenSnapshot SimpleTx
seenSnapshot
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO (SeenSnapshot tx)
-> IO (Maybe (ConfirmedSnapshot tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              IO CommitInfo
cantCommit
              IO (Maybe (Set SimpleTxOut))
IO (Maybe (UTxOType SimpleTx))
forall {a}. IO (Maybe a)
getNothing
              IO (SeenSnapshot SimpleTx)
getSeenSnapshot
              IO (Maybe (ConfirmedSnapshot SimpleTx))
forall {a}. IO (Maybe a)
getNothing
              IO [Integer]
IO [TxIdType SimpleTx]
forall {a}. IO [a]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall {b}. b -> IO ()
putClientInput
          )
          (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
      String -> (Maybe (ConfirmedSnapshot SimpleTx) -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds correctly" ((Maybe (ConfirmedSnapshot SimpleTx) -> IO ()) -> Spec)
-> (Maybe (ConfirmedSnapshot SimpleTx) -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \Maybe (ConfirmedSnapshot SimpleTx)
confirmedSnapshot -> do
        let getConfirmedSnapshot :: IO (Maybe (ConfirmedSnapshot SimpleTx))
getConfirmedSnapshot = Maybe (ConfirmedSnapshot SimpleTx)
-> IO (Maybe (ConfirmedSnapshot SimpleTx))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ConfirmedSnapshot SimpleTx)
confirmedSnapshot
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication (forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO (SeenSnapshot tx)
-> IO (Maybe (ConfirmedSnapshot tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp @SimpleTx Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle Environment
testEnvironment PParams LedgerEra
defaultPParams IO CommitInfo
cantCommit IO (Maybe (Set SimpleTxOut))
IO (Maybe (UTxOType SimpleTx))
forall {a}. IO (Maybe a)
getNothing IO (SeenSnapshot SimpleTx)
forall {tx}. IO (SeenSnapshot tx)
getNoSeenSnapshot IO (Maybe (ConfirmedSnapshot SimpleTx))
getConfirmedSnapshot IO [Integer]
IO [TxIdType SimpleTx]
forall {a}. IO [a]
getPendingDeposits ClientInput SimpleTx -> IO ()
forall {b}. b -> IO ()
putClientInput) (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
s -> ResponseMatcher
200{matchBody = matchJSON s}

      String -> (ConfirmedSnapshot Tx -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ok response matches schema" ((ConfirmedSnapshot Tx -> Property) -> Spec)
-> (ConfirmedSnapshot Tx -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \(ConfirmedSnapshot Tx
confirmedSnapshot :: ConfirmedSnapshot Tx) ->
        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
            let getConfirmedSnapshot :: IO (Maybe (ConfirmedSnapshot Tx))
getConfirmedSnapshot = Maybe (ConfirmedSnapshot Tx) -> IO (Maybe (ConfirmedSnapshot Tx))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ConfirmedSnapshot Tx) -> IO (Maybe (ConfirmedSnapshot Tx)))
-> Maybe (ConfirmedSnapshot Tx)
-> IO (Maybe (ConfirmedSnapshot Tx))
forall a b. (a -> b) -> a -> b
$ ConfirmedSnapshot Tx -> Maybe (ConfirmedSnapshot Tx)
forall a. a -> Maybe a
Just ConfirmedSnapshot Tx
confirmedSnapshot
            Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication (forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO (SeenSnapshot tx)
-> IO (Maybe (ConfirmedSnapshot tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp @Tx Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Chain Tx IO
forall tx. Chain tx IO
dummyChainHandle Environment
testEnvironment PParams LedgerEra
defaultPParams IO CommitInfo
cantCommit IO (Maybe (UTxOType Tx))
IO (Maybe UTxO)
forall {a}. IO (Maybe a)
getNothing IO (SeenSnapshot Tx)
forall {tx}. IO (SeenSnapshot tx)
getNoSeenSnapshot IO (Maybe (ConfirmedSnapshot Tx))
getConfirmedSnapshot IO [TxIdType Tx]
IO [TxId]
forall {a}. IO [a]
getPendingDeposits ClientInput Tx -> IO ()
forall {b}. b -> IO ()
putClientInput) (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 -> (SideLoadSnapshotRequest Tx -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds on valid requests" ((SideLoadSnapshotRequest Tx -> IO ()) -> Spec)
-> (SideLoadSnapshotRequest Tx -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \(SideLoadSnapshotRequest Tx
request :: SideLoadSnapshotRequest Tx) ->
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication (forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO (SeenSnapshot tx)
-> IO (Maybe (ConfirmedSnapshot tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp @Tx Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Chain Tx IO
forall tx. Chain tx IO
dummyChainHandle Environment
testEnvironment PParams LedgerEra
defaultPParams IO CommitInfo
cantCommit IO (Maybe (UTxOType Tx))
IO (Maybe UTxO)
forall {a}. IO (Maybe a)
getNothing IO (SeenSnapshot Tx)
forall {tx}. IO (SeenSnapshot tx)
getNoSeenSnapshot IO (Maybe (ConfirmedSnapshot Tx))
forall {a}. IO (Maybe a)
getNothing IO [TxIdType Tx]
IO [TxId]
forall {a}. IO [a]
getPendingDeposits ClientInput Tx -> IO ()
forall {b}. b -> IO ()
putClientInput) (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 Tx -> Body
forall a. ToJSON a => a -> Body
Aeson.encode SideLoadSnapshotRequest Tx
request)
            WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200

    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
      String -> (Maybe (Set SimpleTxOut) -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds correctly" ((Maybe (Set SimpleTxOut) -> IO ()) -> Spec)
-> (Maybe (Set SimpleTxOut) -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \Maybe (Set SimpleTxOut)
utxo -> do
        let getUTxO :: IO (Maybe (Set SimpleTxOut))
getUTxO = Maybe (Set SimpleTxOut) -> IO (Maybe (Set SimpleTxOut))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Set SimpleTxOut)
utxo
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
          ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO (SeenSnapshot tx)
-> IO (Maybe (ConfirmedSnapshot tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp @SimpleTx
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              IO CommitInfo
cantCommit
              IO (Maybe (Set SimpleTxOut))
IO (Maybe (UTxOType SimpleTx))
getUTxO
              IO (SeenSnapshot SimpleTx)
forall {tx}. IO (SeenSnapshot tx)
getNoSeenSnapshot
              IO (Maybe (ConfirmedSnapshot SimpleTx))
forall {a}. IO (Maybe a)
getNothing
              IO [Integer]
IO [TxIdType SimpleTx]
forall {a}. IO [a]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall {b}. b -> IO ()
putClientInput
          )
          (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 (Set SimpleTxOut)
utxo of
                Maybe (Set SimpleTxOut)
Nothing -> ResponseMatcher
404
                Just Set SimpleTxOut
u -> ResponseMatcher
200{matchBody = matchJSON u}

      String -> (UTxO -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ok response matches schema" ((UTxO -> Property) -> Spec) -> (UTxO -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \(UTxOType Tx
utxo :: UTxOType Tx) ->
        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 a. UTxO' a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
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 a. UTxO' a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
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
            let getUTxO :: IO (Maybe UTxO)
getUTxO = Maybe UTxO -> IO (Maybe UTxO)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UTxO -> IO (Maybe UTxO)) -> Maybe UTxO -> IO (Maybe UTxO)
forall a b. (a -> b) -> a -> b
$ UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxOType Tx
UTxO
utxo
            Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
              ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO (SeenSnapshot tx)
-> IO (Maybe (ConfirmedSnapshot tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp @Tx
                  Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                  Chain Tx IO
forall tx. Chain tx IO
dummyChainHandle
                  Environment
testEnvironment
                  PParams LedgerEra
defaultPParams
                  IO CommitInfo
cantCommit
                  IO (Maybe (UTxOType Tx))
IO (Maybe UTxO)
getUTxO
                  IO (SeenSnapshot Tx)
forall {tx}. IO (SeenSnapshot tx)
getNoSeenSnapshot
                  IO (Maybe (ConfirmedSnapshot Tx))
forall {a}. IO (Maybe a)
getNothing
                  IO [TxIdType Tx]
IO [TxId]
forall {a}. IO [a]
getPendingDeposits
                  ClientInput Tx -> IO ()
forall {b}. b -> IO ()
putClientInput
              )
              (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 =
                        matchValidJSON
                          (schemaDir </> "api.json")
                          (key "channels" . key "/snapshot/utxo" . key "subscribe" . key "message" . key "payload")
                    }

      String -> (TxIn -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"has inlineDatumRaw" ((TxIn -> Property) -> Spec) -> (TxIn -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \TxIn
i ->
        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 Era
o' = (TxOutDatum Any Era -> TxOutDatum CtxUTxO Era)
-> TxOut Any -> TxOut CtxUTxO Era
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 getUTxO :: IO (Maybe UTxO)
getUTxO = Maybe UTxO -> IO (Maybe UTxO)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UTxO -> IO (Maybe UTxO)) -> Maybe UTxO -> IO (Maybe UTxO)
forall a b. (a -> b) -> a -> b
$ UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just (UTxO -> Maybe UTxO) -> UTxO -> Maybe UTxO
forall a b. (a -> b) -> a -> b
$ [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromPairs [(TxIn
i, TxOut CtxUTxO Era
o')]
          Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
            ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO (SeenSnapshot tx)
-> IO (Maybe (ConfirmedSnapshot tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp @Tx
                Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                Chain Tx IO
forall tx. Chain tx IO
dummyChainHandle
                Environment
testEnvironment
                PParams LedgerEra
defaultPParams
                IO CommitInfo
cantCommit
                IO (Maybe (UTxOType Tx))
IO (Maybe UTxO)
getUTxO
                IO (SeenSnapshot Tx)
forall {tx}. IO (SeenSnapshot tx)
getNoSeenSnapshot
                IO (Maybe (ConfirmedSnapshot Tx))
forall {a}. IO (Maybe a)
getNothing
                IO [TxIdType Tx]
IO [TxId]
forall {a}. IO [a]
getPendingDeposits
                ClientInput Tx -> IO ()
forall {b}. b -> IO ()
putClientInput
            )
            (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 ->
                      if Maybe Value -> Bool
forall a. Maybe a -> Bool
isNothing (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")
                        then 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
                        else Maybe String
forall a. Maybe a
Nothing
                  }

    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
NormalCommit (Gen HeadId -> Int -> HeadId
forall a. Gen a -> Int -> a
generateWith Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary Int
42)
      let workingChainHandle :: Chain Tx IO
workingChainHandle =
            Chain Tx IO
forall tx. Chain tx IO
dummyChainHandle
              { draftCommitTx = \HeadId
_ CommitBlueprintTx Tx
_ -> 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
-> Chain Tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType Tx))
-> IO (SeenSnapshot Tx)
-> IO (Maybe (ConfirmedSnapshot Tx))
-> IO [TxIdType Tx]
-> (ClientInput Tx -> IO ())
-> Application
forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO (SeenSnapshot tx)
-> IO (Maybe (ConfirmedSnapshot tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp
              Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Chain Tx IO
workingChainHandle
              Environment
testEnvironment
              PParams LedgerEra
defaultPParams
              IO CommitInfo
getHeadId
              IO (Maybe (UTxOType Tx))
IO (Maybe UTxO)
forall {a}. IO (Maybe a)
getNothing
              IO (SeenSnapshot Tx)
forall {tx}. IO (SeenSnapshot tx)
getNoSeenSnapshot
              IO (Maybe (ConfirmedSnapshot Tx))
forall {a}. IO (Maybe a)
getNothing
              IO [TxIdType Tx]
IO [TxId]
forall {a}. IO [a]
getPendingDeposits
              ClientInput Tx -> IO ()
forall {b}. b -> IO ()
putClientInput
          )
          (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

      let failingChainHandle :: PostTxError tx -> Chain tx IO
failingChainHandle PostTxError tx
postTxError =
            Chain tx IO
forall tx. Chain tx IO
dummyChainHandle
              { draftCommitTx = \HeadId
_ CommitBlueprintTx 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
$ PostTxError tx -> Either (PostTxError tx) tx
forall a b. a -> Either a b
Left PostTxError tx
postTxError
              , draftDepositTx = \HeadId
_ CommitBlueprintTx tx
_ UTCTime
_ -> 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 PostTxError tx
postTxError
              }
      String
-> (DraftCommitTxRequest Tx -> PostTxError Tx -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"handles PostTxErrors accordingly" ((DraftCommitTxRequest Tx -> PostTxError Tx -> Property) -> Spec)
-> (DraftCommitTxRequest Tx -> PostTxError Tx -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \DraftCommitTxRequest Tx
request PostTxError Tx
postTxError -> do
        let expectedResponse :: ResponseMatcher
expectedResponse =
              case PostTxError Tx
postTxError of
                CommittedTooMuchADAForMainnet{} -> ResponseMatcher
400
                UnsupportedLegacyOutput{} -> ResponseMatcher
400
                CannotFindOwnInitial{} -> ResponseMatcher
400
                PostTxError Tx
_ -> ResponseMatcher
500
        let coverage :: IO () -> Property
coverage = case PostTxError Tx
postTxError of
              CommittedTooMuchADAForMainnet{} -> Double -> Bool -> String -> IO () -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 Bool
True String
"CommittedTooMuchADAForMainnet"
              UnsupportedLegacyOutput{} -> Double -> Bool -> String -> IO () -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 Bool
True String
"UnsupportedLegacyOutput"
              InvalidHeadId{} -> Double -> Bool -> String -> IO () -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 Bool
True String
"InvalidHeadId"
              CannotFindOwnInitial{} -> Double -> Bool -> String -> IO () -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 Bool
True String
"CannotFindOwnInitial"
              PostTxError Tx
_ -> IO () -> Property
forall prop. Testable prop => prop -> Property
property
        Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage
          (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ IO () -> Property
coverage
          (IO () -> Property) -> IO () -> Property
forall a b. (a -> b) -> a -> b
$ Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
            ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO (SeenSnapshot tx)
-> IO (Maybe (ConfirmedSnapshot tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp @Tx
                Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                (PostTxError Tx -> Chain Tx IO
forall {tx}. PostTxError tx -> Chain tx IO
failingChainHandle PostTxError Tx
postTxError)
                Environment
testEnvironment
                PParams LedgerEra
defaultPParams
                IO CommitInfo
getHeadId
                IO (Maybe (UTxOType Tx))
IO (Maybe UTxO)
forall {a}. IO (Maybe a)
getNothing
                IO (SeenSnapshot Tx)
forall {tx}. IO (SeenSnapshot tx)
getNoSeenSnapshot
                IO (Maybe (ConfirmedSnapshot Tx))
forall {a}. IO (Maybe a)
getNothing
                IO [TxIdType Tx]
IO [TxId]
forall {a}. IO [a]
getPendingDeposits
                ClientInput Tx -> IO ()
forall {b}. b -> IO ()
putClientInput
            )
          (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 :: DraftCommitTxRequest Tx))
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
expectedResponse

-- * 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 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