module Hydra.API.HTTPServerSpec where

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

import Cardano.Api.UTxO qualified as UTxO
import Control.Concurrent.STM (newTChanIO, writeTChan)
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.ByteString.Lazy qualified as LBS
import Data.Text qualified as Text
import Hydra.API.ClientInput (ClientInput)
import Hydra.API.HTTPServer (
  DraftCommitTxRequest (..),
  DraftCommitTxResponse (..),
  SideLoadSnapshotRequest (..),
  SubmitL2TxRequest (..),
  SubmitL2TxResponse (..),
  SubmitTxRequest (..),
  TransactionSubmitted,
  httpApp,
 )
import Hydra.API.ServerOutput (CommitInfo (CannotCommit, NormalCommit), ServerOutput (..), TimedServerOutput (..), 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.Chain.Direct.Handlers (rejectLowDeposits)
import Hydra.HeadLogic.State (ClosedState (..), HeadState (..), SeenSnapshot (..))
import Hydra.HeadLogicSpec (inIdleState)
import Hydra.JSONSchema (SchemaSelector, prop_validateJSONSchema, validateJSON, withJsonSpecifications)
import Hydra.Ledger (ValidationError (..))
import Hydra.Ledger.Cardano (Tx)
import Hydra.Ledger.Simple (SimpleTx (..))
import Hydra.Logging (nullTracer)
import Hydra.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, pparams)
import Test.Hydra.Tx.Gen (genTxOut, genUTxOAdaOnlyOfSize)
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)))
    Proxy (ReasonablySized SubmitL2TxResponse) -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a, Typeable a) =>
Proxy a -> Spec
roundtripAndGoldenSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ReasonablySized SubmitL2TxResponse))
    Proxy (ReasonablySized (SubmitL2TxRequest Tx)) -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a, Typeable a) =>
Proxy a -> Spec
roundtripAndGoldenSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ReasonablySized (SubmitL2TxRequest Tx)))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"GET /head" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
-> SpecM
     ()
     (TChan
        (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall r a. IO r -> SpecM a r
runIO IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
      String -> (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 ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> 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 tx. IO [tx]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/head"
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200{matchBody = matchJSON headState}
      TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannelSimpleTx <- IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
-> SpecM
     () (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall r a. IO r -> SpecM a r
runIO IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall a. IO (TChan a)
newTChanIO
      String -> (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 ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> 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 tx. IO [tx]
getPendingDeposits
                  ClientInput Tx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
                  ApiTransactionTimeout
300
                  TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannelSimpleTx
              )
              (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/head"
                  WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200
                    { matchBody =
                        matchValidJSON
                          (schemaDir </> "api.json")
                          (key "channels" . key "/head" . key "subscribe" . key "message")
                    }
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"GET /snapshot/last-seen" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
-> SpecM
     ()
     (TChan
        (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall r a. IO r -> SpecM a r
runIO IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
      String -> (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 ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> 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 tx. IO [tx]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/snapshot/last-seen"
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200{matchBody = matchJSON seenSnapshot}
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"GET /snapshot" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
-> SpecM
     ()
     (TChan
        (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall r a. IO r -> SpecM a r
runIO IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
      String -> (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 ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> 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 tx. IO [tx]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/snapshot"
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` case Maybe (ConfirmedSnapshot SimpleTx)
confirmedSnapshot of
                Maybe (ConfirmedSnapshot SimpleTx)
Nothing -> ResponseMatcher
404
                Just ConfirmedSnapshot SimpleTx
confirmedSn -> ResponseMatcher
200{matchBody = matchJSON confirmedSn}
      TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannelSimpleTx <- IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
-> SpecM
     () (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall r a. IO r -> SpecM a r
runIO IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall a. IO (TChan a)
newTChanIO
      String -> (ClosedState Tx -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ok response matches schema" ((ClosedState Tx -> Property) -> Spec)
-> (ClosedState Tx -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \(ClosedState Tx
closedState :: ClosedState tx) -> do
        Int -> IO () -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
4
          (IO () -> Property)
-> ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO ()) -> IO ()
forall (m :: * -> *) r. MonadIO m => (String -> m r) -> m r
withJsonSpecifications
          ((String -> IO ()) -> Property) -> (String -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$ \String
schemaDir -> do
            Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
              ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (HeadState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @Tx
                  Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                  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 tx. IO [tx]
getPendingDeposits
                  ClientInput Tx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
                  ApiTransactionTimeout
300
                  TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannelSimpleTx
              )
              (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/snapshot"
                  WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200
                    { matchBody =
                        matchValidJSON
                          (schemaDir </> "api.json")
                          (key "channels" . key "/snapshot" . key "subscribe" . key "message" . key "payload")
                    }

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"POST /snapshot" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannel <- IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
-> SpecM
     () (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall r a. IO r -> SpecM a r
runIO IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall a. IO (TChan a)
newTChanIO
      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 ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> 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 tx. IO [tx]
getPendingDeposits
                ClientInput Tx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
                ApiTransactionTimeout
300
                TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannel
            )
          (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
      TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel <- IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
-> SpecM
     ()
     (TChan
        (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall r a. IO r -> SpecM a r
runIO IO
  (TChan
     (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx)))
forall a. IO (TChan a)
newTChanIO
      String -> (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 ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> 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 tx. IO [tx]
getPendingDeposits
              ClientInput SimpleTx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan
  (Either (TimedServerOutput SimpleTx) (ClientMessage SimpleTx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/snapshot/utxo"
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` case Maybe (UTxOType SimpleTx)
utxo of
                Maybe (UTxOType SimpleTx)
Nothing -> ResponseMatcher
404
                Just UTxOType SimpleTx
u -> ResponseMatcher
200{matchBody = matchJSON u}
      TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannelSimpleTx <- IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
-> SpecM
     () (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall r a. IO r -> SpecM a r
runIO IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall a. IO (TChan a)
newTChanIO
      String -> (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
UTxO.null UTxOType Tx
UTxO
utxo) String
"empty"
          (Property -> Property)
-> ((String -> IO ()) -> Property) -> (String -> IO ()) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool -> String -> IO () -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ UTxO -> Bool
UTxO.null UTxOType Tx
UTxO
utxo) String
"non empty"
          (IO () -> Property)
-> ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO ()) -> IO ()
forall (m :: * -> *) r. MonadIO m => (String -> m r) -> m r
withJsonSpecifications
          ((String -> IO ()) -> Property) -> (String -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$ \String
schemaDir -> do
            Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication
              ( forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (HeadState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp @Tx
                  Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                  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 tx. IO [tx]
getPendingDeposits
                  ClientInput Tx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
                  ApiTransactionTimeout
300
                  TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannelSimpleTx
              )
              (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/snapshot/utxo"
                  WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` case Maybe (UTxOType Tx)
mUTxO of
                    Maybe (UTxOType Tx)
Nothing -> ResponseMatcher
404
                    Just UTxOType Tx
_ ->
                      ResponseMatcher
200
                        { matchBody =
                            matchValidJSON
                              (schemaDir </> "api.json")
                              (key "channels" . key "/snapshot/utxo" . key "subscribe" . key "message" . key "payload")
                        }

      String -> ((TxIn, ClosedState Tx) -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"has inlineDatumRaw" (((TxIn, ClosedState Tx) -> Property) -> Spec)
-> ((TxIn, ClosedState Tx) -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \(TxIn
i, ClosedState Tx
closedState) ->
        Gen (TxOut Any) -> (TxOut Any -> IO ()) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (TxOut Any)
forall ctx. Gen (TxOut ctx)
genTxOut ((TxOut Any -> IO ()) -> Property)
-> (TxOut Any -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$ \TxOut Any
o -> do
          let o' :: TxOut CtxUTxO
o' = (TxOutDatum Any Era -> TxOutDatum CtxUTxO Era)
-> TxOut Any -> TxOut CtxUTxO
forall ctx0 era ctx1.
(TxOutDatum ctx0 era -> TxOutDatum ctx1 era)
-> TxOut ctx0 era -> TxOut ctx1 era
modifyTxOutDatum (TxOutDatum CtxUTxO Era
-> TxOutDatum Any Era -> TxOutDatum CtxUTxO Era
forall a b. a -> b -> a
const (TxOutDatum CtxUTxO Era
 -> TxOutDatum Any Era -> TxOutDatum CtxUTxO Era)
-> TxOutDatum CtxUTxO Era
-> TxOutDatum Any Era
-> TxOutDatum CtxUTxO Era
forall a b. (a -> b) -> a -> b
$ Integer -> TxOutDatum CtxUTxO Era
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (Integer
123 :: Integer)) TxOut Any
o
          let UTxOType Tx
utxo' :: UTxOType Tx = [(TxIn, TxOut CtxUTxO)] -> UTxO
forall 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 ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> 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 tx. IO [tx]
getPendingDeposits
                ClientInput Tx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
                ApiTransactionTimeout
300
                TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannelSimpleTx
            )
            (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/snapshot/utxo"
                WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200
                  { matchBody = MatchBody $ \[Header]
_ Body
body ->
                      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)
      let openHeadState :: HeadState Tx
openHeadState = OpenState Tx -> HeadState Tx
forall tx. OpenState tx -> HeadState tx
Open (Gen (OpenState Tx) -> Int -> OpenState Tx
forall a. Gen a -> Int -> a
generateWith Gen (OpenState Tx)
forall a. Arbitrary a => Gen a
arbitrary Int
42)
      TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannel <- IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
-> SpecM
     () (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall r a. IO r -> SpecM a r
runIO IO (TChan (Either (TimedServerOutput Tx) (ClientMessage Tx)))
forall a. IO (TChan a)
newTChanIO
      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 ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
-> 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 ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> 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 tx. IO [tx]
getPendingDeposits
              ClientInput Tx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
              ApiTransactionTimeout
300
              TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannel
          )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/commit" (DraftCommitTxRequest Tx -> Body
forall a. ToJSON a => a -> Body
Aeson.encode DraftCommitTxRequest Tx
request)
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200

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

      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"
              DepositTooLow{} -> Double -> Bool -> String -> IO () -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 Bool
True String
"DepositTooLow"
              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 ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> 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
openHeadState)
                IO CommitInfo
getHeadId
                IO [TxIdType Tx]
IO [TxId]
forall tx. IO [tx]
getPendingDeposits
                ClientInput Tx -> IO ()
forall tx. ClientInput tx -> IO ()
putClientInput
                ApiTransactionTimeout
300
                TChan (Either (TimedServerOutput Tx) (ClientMessage Tx))
responseChannel
            )
          (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/commit" (DraftCommitTxRequest Tx -> Body
forall a. ToJSON a => a -> Body
Aeson.encode (DraftCommitTxRequest Tx
request :: 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
                DepositTooLow{} -> ResponseMatcher
400
                PostTxError Tx
_ -> ResponseMatcher
500

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

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

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

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

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