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), getConfirmedSnapshot, getSeenSnapshot, getSnapshotUtxo)
import Hydra.API.ServerSpec (dummyChainHandle)
import Hydra.Cardano.Api (
  mkTxOutDatumInline,
  modifyTxOutDatum,
  renderTxIn,
  serialiseToTextEnvelope,
 )
import Hydra.Chain (Chain (draftCommitTx), PostTxError (..), draftDepositTx)
import Hydra.HeadLogic.State (ClosedState (..), HeadState (..), SeenSnapshot (..))
import Hydra.HeadLogicSpec (inIdleState)
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 Hydra.Tx.Snapshot (Snapshot (..))
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)))
    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)))

    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"

    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 [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 ())
        getHeadState :: IO (HeadState SimpleTx)
getHeadState = HeadState SimpleTx -> IO (HeadState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadState 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
      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 (HeadState tx)
-> IO CommitInfo
-> 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 (HeadState SimpleTx)
getHeadState
              IO CommitInfo
cantCommit
              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 /head" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> (HeadState SimpleTx -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds correctly" ((HeadState SimpleTx -> IO ()) -> Spec)
-> (HeadState SimpleTx -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadState SimpleTx
headState -> do
        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 (HeadState tx)
-> IO CommitInfo
-> 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
              (HeadState SimpleTx -> IO (HeadState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadState SimpleTx
headState)
              IO CommitInfo
cantCommit
              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
"/head"
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200{matchBody = matchJSON headState}
      String -> (HeadState Tx -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ok response matches schema" ((HeadState Tx -> Property) -> Spec)
-> (HeadState Tx -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadState Tx
headState -> do
        let isIdle :: Bool
isIdle = case HeadState Tx
headState of
              Idle{} -> Bool
True
              HeadState Tx
_ -> Bool
False
        let isInitial :: Bool
isInitial = case HeadState Tx
headState of
              Initial{} -> Bool
True
              HeadState Tx
_ -> Bool
False
        let isOpen :: Bool
isOpen = case HeadState Tx
headState of
              Open{} -> Bool
True
              HeadState Tx
_ -> Bool
False
        let isClosed :: Bool
isClosed = case HeadState Tx
headState 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
isInitial String
"InitialState"
          (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
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (HeadState tx)
-> IO CommitInfo
-> 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
                  (HeadState Tx -> IO (HeadState Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadState Tx
headState)
                  IO CommitInfo
cantCommit
                  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
"/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
      String -> (HeadState SimpleTx -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds correctly" ((HeadState SimpleTx -> IO ()) -> Spec)
-> (HeadState SimpleTx -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadState SimpleTx
headState -> do
        let SeenSnapshot SimpleTx
seenSnapshot :: SeenSnapshot SimpleTx = HeadState SimpleTx -> SeenSnapshot SimpleTx
forall tx. HeadState tx -> SeenSnapshot tx
getSeenSnapshot HeadState SimpleTx
headState
        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 (HeadState tx)
-> IO CommitInfo
-> 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
              (HeadState SimpleTx -> IO (HeadState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadState SimpleTx
headState)
              IO CommitInfo
cantCommit
              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 -> (HeadState SimpleTx -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds correctly" ((HeadState SimpleTx -> IO ()) -> Spec)
-> (HeadState SimpleTx -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadState SimpleTx
headState -> do
        let Maybe (ConfirmedSnapshot SimpleTx)
confirmedSnapshot :: Maybe (ConfirmedSnapshot SimpleTx) = HeadState SimpleTx -> Maybe (ConfirmedSnapshot SimpleTx)
forall tx.
IsChainState tx =>
HeadState tx -> Maybe (ConfirmedSnapshot tx)
getConfirmedSnapshot HeadState SimpleTx
headState
        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 (HeadState tx)
-> IO CommitInfo
-> 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
              (HeadState SimpleTx -> IO (HeadState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadState SimpleTx
headState)
              IO CommitInfo
cantCommit
              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
confirmedSn -> ResponseMatcher
200{matchBody = matchJSON confirmedSn}
      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) ->
        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
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (HeadState tx)
-> IO CommitInfo
-> 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
                  (HeadState Tx -> IO (HeadState Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClosedState Tx -> HeadState Tx
forall tx. ClosedState tx -> HeadState tx
Closed ClosedState Tx
closedState))
                  IO CommitInfo
cantCommit
                  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, HeadState Tx) -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds on valid requests" (((SideLoadSnapshotRequest Tx, HeadState Tx) -> Property) -> Spec)
-> ((SideLoadSnapshotRequest Tx, HeadState Tx) -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \(SideLoadSnapshotRequest Tx
request :: SideLoadSnapshotRequest Tx, HeadState Tx
headState) -> do
        Int -> IO () -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
10
          (IO () -> Property)
-> (WaiSession () () -> IO ()) -> WaiSession () () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (HeadState tx)
-> IO CommitInfo
-> 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
                (HeadState Tx -> IO (HeadState Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadState Tx
headState)
                IO CommitInfo
cantCommit
                IO [TxIdType Tx]
IO [TxId]
forall {a}. IO [a]
getPendingDeposits
                ClientInput Tx -> IO ()
forall {b}. b -> IO ()
putClientInput
            )
          (WaiSession () () -> Property) -> WaiSession () () -> Property
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 -> (HeadState SimpleTx -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds correctly" ((HeadState SimpleTx -> IO ()) -> Spec)
-> (HeadState SimpleTx -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadState SimpleTx
headState -> do
        let Maybe (UTxOType SimpleTx)
utxo :: Maybe (UTxOType SimpleTx) = HeadState SimpleTx -> Maybe (UTxOType SimpleTx)
forall tx.
Monoid (UTxOType tx) =>
HeadState tx -> Maybe (UTxOType tx)
getSnapshotUtxo HeadState SimpleTx
headState
        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 (HeadState tx)
-> IO CommitInfo
-> 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
              (HeadState SimpleTx -> IO (HeadState SimpleTx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadState SimpleTx
headState)
              IO CommitInfo
cantCommit
              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 (UTxOType SimpleTx)
utxo of
                Maybe (UTxOType SimpleTx)
Nothing -> ResponseMatcher
404
                Just UTxOType SimpleTx
u -> ResponseMatcher
200{matchBody = matchJSON u}
      String -> (HeadState Tx -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ok response matches schema" ((HeadState Tx -> Property) -> Spec)
-> (HeadState Tx -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \HeadState Tx
headState -> do
        let mUTxO :: Maybe (UTxOType Tx)
mUTxO = HeadState Tx -> Maybe (UTxOType Tx)
forall tx.
Monoid (UTxOType tx) =>
HeadState tx -> Maybe (UTxOType tx)
getSnapshotUtxo HeadState Tx
headState
            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 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
            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 (HeadState tx)
-> IO CommitInfo
-> 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
                  (HeadState Tx -> IO (HeadState Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadState Tx
headState)
                  IO CommitInfo
cantCommit
                  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` 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 out. [(TxIn, out)] -> UTxO' out
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, $sel:initialUTxO:InitialSnapshot :: UTxOType Tx
initialUTxO = UTxOType Tx
utxo'}
                  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} = 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}
                     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
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (HeadState tx)
-> IO CommitInfo
-> 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
                (HeadState Tx -> IO (HeadState Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClosedState Tx -> HeadState Tx
forall tx. ClosedState tx -> HeadState tx
Closed ClosedState Tx
closedState'))
                IO CommitInfo
cantCommit
                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
              }
      let initialHeadState :: HeadState Tx
initialHeadState = InitialState Tx -> HeadState Tx
forall tx. InitialState tx -> HeadState tx
Initial (Gen (InitialState Tx) -> Int -> InitialState Tx
forall a. Gen a -> Int -> a
generateWith Gen (InitialState Tx)
forall a. Arbitrary a => Gen a
arbitrary Int
42)
      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 (HeadState Tx)
-> IO CommitInfo
-> IO [TxIdType Tx]
-> (ClientInput Tx -> IO ())
-> Application
forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (HeadState tx)
-> IO CommitInfo
-> 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
              (HeadState Tx -> IO (HeadState Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadState Tx
initialHeadState)
              IO CommitInfo
getHeadId
              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 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 (HeadState tx)
-> IO CommitInfo
-> 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
                (HeadState Tx -> IO (HeadState Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadState Tx
initialHeadState)
                IO CommitInfo
getHeadId
                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` case PostTxError Tx
postTxError of
                CommittedTooMuchADAForMainnet{} -> ResponseMatcher
400
                UnsupportedLegacyOutput{} -> ResponseMatcher
400
                CannotFindOwnInitial{} -> ResponseMatcher
400
                PostTxError Tx
_ -> ResponseMatcher
500

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