module Hydra.API.HTTPServerSpec where

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

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

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

    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"

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

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

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"GET /protocol-parameters" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      IO Application -> SpecWith ((), Application) -> Spec
with (Application -> IO Application
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp @SimpleTx Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle Environment
testEnvironment PParams LedgerEra
defaultPParams IO CommitInfo
cantCommit IO (Maybe (Set SimpleTxOut))
IO (Maybe (UTxOType SimpleTx))
forall {a}. IO (Maybe a)
getNothing IO [Integer]
IO [TxIdType SimpleTx]
forall {a}. IO [a]
getPendingDeposits ClientInput SimpleTx -> IO ()
forall {b}. b -> IO ()
putClientInput) (SpecWith ((), Application) -> Spec)
-> SpecWith ((), Application) -> Spec
forall a b. (a -> b) -> a -> b
$ do
        String -> WaiSession () () -> SpecWith (Arg (WaiSession () ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"matches schema" (WaiSession () () -> SpecWith (Arg (WaiSession () ())))
-> WaiSession () () -> SpecWith (Arg (WaiSession () ()))
forall a b. (a -> b) -> a -> b
$
          (String -> WaiSession () ()) -> WaiSession () ()
forall (m :: * -> *) r. MonadIO m => (String -> m r) -> m r
withJsonSpecifications ((String -> WaiSession () ()) -> WaiSession () ())
-> (String -> WaiSession () ()) -> WaiSession () ()
forall a b. (a -> b) -> a -> b
$ \String
schemaDir -> do
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/protocol-parameters"
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200
                { matchBody =
                    matchValidJSON
                      (schemaDir </> "api.json")
                      (key "components" . key "messages" . key "ProtocolParameters" . key "payload")
                }
        String -> WaiSession () () -> SpecWith (Arg (WaiSession () ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"responds given parameters" (WaiSession () () -> SpecWith (Arg (WaiSession () ())))
-> WaiSession () () -> SpecWith (Arg (WaiSession () ()))
forall a b. (a -> b) -> a -> b
$
          ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/protocol-parameters"
            WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200
              { matchBody = matchJSON defaultPParams
              }

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"GET /snapshot/utxo" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> (Maybe (Set SimpleTxOut) -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds correctly" ((Maybe (Set SimpleTxOut) -> IO ()) -> Spec)
-> (Maybe (Set SimpleTxOut) -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \Maybe (Set SimpleTxOut)
utxo -> do
        let getUTxO :: IO (Maybe (Set SimpleTxOut))
getUTxO = Maybe (Set SimpleTxOut) -> IO (Maybe (Set SimpleTxOut))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Set SimpleTxOut)
utxo
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication (forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp @SimpleTx Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Chain SimpleTx IO
forall tx. Chain tx IO
dummyChainHandle Environment
testEnvironment PParams LedgerEra
defaultPParams IO CommitInfo
cantCommit IO (Maybe (Set SimpleTxOut))
IO (Maybe (UTxOType SimpleTx))
getUTxO IO [Integer]
IO [TxIdType SimpleTx]
forall {a}. IO [a]
getPendingDeposits ClientInput SimpleTx -> IO ()
forall {b}. b -> IO ()
putClientInput) (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/snapshot/utxo"
            WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` case Maybe (Set SimpleTxOut)
utxo of
              Maybe (Set SimpleTxOut)
Nothing -> ResponseMatcher
404
              Just Set SimpleTxOut
u -> ResponseMatcher
200{matchBody = matchJSON u}

      String -> (UTxO -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ok response matches schema" ((UTxO -> Property) -> Spec) -> (UTxO -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \(UTxOType Tx
utxo :: UTxOType Tx) ->
        Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
4
          (Property -> Property)
-> ((String -> IO ()) -> Property) -> (String -> IO ()) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 (UTxO -> Bool
forall a. UTxO' a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null UTxO
UTxOType Tx
utxo) String
"empty"
          (Property -> Property)
-> ((String -> IO ()) -> Property) -> (String -> IO ()) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool -> String -> IO () -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ UTxO -> Bool
forall a. UTxO' a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null UTxO
UTxOType Tx
utxo) String
"non empty"
          (IO () -> Property)
-> ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO ()) -> IO ()
forall (m :: * -> *) r. MonadIO m => (String -> m r) -> m r
withJsonSpecifications
          ((String -> IO ()) -> Property) -> (String -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$ \String
schemaDir -> do
            let getUTxO :: IO (Maybe UTxO)
getUTxO = Maybe UTxO -> IO (Maybe UTxO)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UTxO -> IO (Maybe UTxO)) -> Maybe UTxO -> IO (Maybe UTxO)
forall a b. (a -> b) -> a -> b
$ UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
UTxOType Tx
utxo
            Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication (forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp @Tx Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Chain Tx IO
forall tx. Chain tx IO
dummyChainHandle Environment
testEnvironment PParams LedgerEra
defaultPParams IO CommitInfo
cantCommit IO (Maybe UTxO)
IO (Maybe (UTxOType Tx))
getUTxO IO [TxIdType Tx]
IO [TxId]
forall {a}. IO [a]
getPendingDeposits ClientInput Tx -> IO ()
forall {b}. b -> IO ()
putClientInput) (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/snapshot/utxo"
                WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200
                  { matchBody =
                      matchValidJSON
                        (schemaDir </> "api.json")
                        (key "channels" . key "/snapshot/utxo" . key "subscribe" . key "message" . key "payload")
                  }

      String -> (TxIn -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"has inlineDatumRaw" ((TxIn -> Property) -> Spec) -> (TxIn -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \TxIn
i ->
        Gen (TxOut Any) -> (TxOut Any -> IO ()) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (TxOut Any)
forall ctx. Gen (TxOut ctx)
genTxOut ((TxOut Any -> IO ()) -> Property)
-> (TxOut Any -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$ \TxOut Any
o -> do
          let o' :: TxOut CtxUTxO Era
o' = (TxOutDatum Any Era -> TxOutDatum CtxUTxO Era)
-> TxOut Any -> TxOut CtxUTxO Era
forall ctx0 era ctx1.
(TxOutDatum ctx0 era -> TxOutDatum ctx1 era)
-> TxOut ctx0 era -> TxOut ctx1 era
modifyTxOutDatum (TxOutDatum CtxUTxO Era
-> TxOutDatum Any Era -> TxOutDatum CtxUTxO Era
forall a b. a -> b -> a
const (TxOutDatum CtxUTxO Era
 -> TxOutDatum Any Era -> TxOutDatum CtxUTxO Era)
-> TxOutDatum CtxUTxO Era
-> TxOutDatum Any Era
-> TxOutDatum CtxUTxO Era
forall a b. (a -> b) -> a -> b
$ Integer -> TxOutDatum CtxUTxO Era
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (Integer
123 :: Integer)) TxOut Any
o
          let getUTxO :: IO (Maybe UTxO)
getUTxO = Maybe UTxO -> IO (Maybe UTxO)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UTxO -> IO (Maybe UTxO)) -> Maybe UTxO -> IO (Maybe UTxO)
forall a b. (a -> b) -> a -> b
$ UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just (UTxO -> Maybe UTxO) -> UTxO -> Maybe UTxO
forall a b. (a -> b) -> a -> b
$ [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromPairs [(TxIn
i, TxOut CtxUTxO Era
o')]
          Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication (forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp @Tx Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Chain Tx IO
forall tx. Chain tx IO
dummyChainHandle Environment
testEnvironment PParams LedgerEra
defaultPParams IO CommitInfo
cantCommit IO (Maybe UTxO)
IO (Maybe (UTxOType Tx))
getUTxO IO [TxIdType Tx]
IO [TxId]
forall {a}. IO [a]
getPendingDeposits ClientInput Tx -> IO ()
forall {b}. b -> IO ()
putClientInput) (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> WaiSession () SResponse
forall st. ByteString -> WaiSession st SResponse
get ByteString
"/snapshot/utxo"
              WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200
                { matchBody = MatchBody $ \[Header]
_ Body
body ->
                    if Maybe Value -> Bool
forall a. Maybe a -> Bool
isNothing (Body
body Body -> Getting (First Value) Body Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Body Value
forall t. AsValue t => Key -> Traversal' t Value
key (String -> Key
forall a. IsString a => String -> a
fromString (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TxIn -> Text
renderTxIn TxIn
i) Getting (First Value) Body Value
-> ((Value -> Const (First Value) Value)
    -> Value -> Const (First Value) Value)
-> Getting (First Value) Body Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"inlineDatumRaw")
                      then String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"\ninlineDatumRaw not found in body:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Body -> String
forall b a. (Show a, IsString b) => a -> b
show Body
body
                      else Maybe String
forall a. Maybe a
Nothing
                }

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"POST /commit" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      let getHeadId :: IO CommitInfo
getHeadId = CommitInfo -> IO CommitInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommitInfo -> IO CommitInfo) -> CommitInfo -> IO CommitInfo
forall a b. (a -> b) -> a -> b
$ HeadId -> CommitInfo
NormalCommit (Gen HeadId -> Int -> HeadId
forall a. Gen a -> Int -> a
generateWith Gen HeadId
forall a. Arbitrary a => Gen a
arbitrary Int
42)
      let workingChainHandle :: Chain Tx IO
workingChainHandle =
            Chain Tx IO
forall tx. Chain tx IO
dummyChainHandle
              { draftCommitTx = \HeadId
_ CommitBlueprintTx Tx
_ -> do
                  Tx
tx <- Gen Tx -> IO Tx
forall a. Gen a -> IO a
generate (Gen Tx -> IO Tx) -> Gen Tx -> IO Tx
forall a b. (a -> b) -> a -> b
$ forall a. Arbitrary a => Gen a
arbitrary @Tx
                  Either (PostTxError Tx) Tx -> IO (Either (PostTxError Tx) Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (PostTxError Tx) Tx -> IO (Either (PostTxError Tx) Tx))
-> Either (PostTxError Tx) Tx -> IO (Either (PostTxError Tx) Tx)
forall a b. (a -> b) -> a -> b
$ Tx -> Either (PostTxError Tx) Tx
forall a b. b -> Either a b
Right Tx
tx
              }
      String -> (DraftCommitTxRequest Tx -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"responds on valid requests" ((DraftCommitTxRequest Tx -> IO ()) -> Spec)
-> (DraftCommitTxRequest Tx -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \(DraftCommitTxRequest Tx
request :: DraftCommitTxRequest Tx) ->
        Application -> WaiSession () () -> IO ()
forall a. Application -> WaiSession () a -> IO a
withApplication (Tracer IO APIServerLog
-> Chain Tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType Tx))
-> IO [TxIdType Tx]
-> (ClientInput Tx -> IO ())
-> Application
forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Chain Tx IO
workingChainHandle Environment
testEnvironment PParams LedgerEra
defaultPParams IO CommitInfo
getHeadId IO (Maybe UTxO)
IO (Maybe (UTxOType Tx))
forall {a}. IO (Maybe a)
getNothing IO [TxIdType Tx]
IO [TxId]
forall {a}. IO [a]
getPendingDeposits ClientInput Tx -> IO ()
forall {b}. b -> IO ()
putClientInput) (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          ByteString -> Body -> WaiSession () SResponse
forall st. ByteString -> Body -> WaiSession st SResponse
post ByteString
"/commit" (DraftCommitTxRequest Tx -> Body
forall a. ToJSON a => a -> Body
Aeson.encode DraftCommitTxRequest Tx
request)
            WaiSession () SResponse -> ResponseMatcher -> WaiSession () ()
forall st.
HasCallStack =>
WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st
`shouldRespondWith` ResponseMatcher
200

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

-- * Helpers

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

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