module Hydra.API.HTTPServerSpec where

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

import Data.Aeson (Result (Error, Success), eitherDecode, encode, fromJSON)
import Data.Aeson qualified as Aeson
import Data.Aeson.Lens (key, nth)
import Hydra.API.HTTPServer (DraftCommitTxRequest (..), DraftCommitTxResponse (..), SubmitTxRequest (..), TransactionSubmitted, httpApp)
import Hydra.API.ServerSpec (dummyChainHandle)
import Hydra.Cardano.Api (
  serialiseToTextEnvelope,
 )
import Hydra.Chain (Chain (draftCommitTx), PostTxError (..))
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.Tx.Fixture (defaultPParams)
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"

    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
    let 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
-> PParams LedgerEra
-> IO (Maybe HeadId)
-> IO (Maybe (UTxOType 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 PParams LedgerEra
defaultPParams IO (Maybe HeadId)
forall {a}. IO (Maybe a)
getNothing IO (Maybe (Set SimpleTxOut))
IO (Maybe (UTxOType SimpleTx))
forall {a}. IO (Maybe a)
getNothing 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
-> PParams LedgerEra
-> IO (Maybe HeadId)
-> IO (Maybe (UTxOType 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 PParams LedgerEra
defaultPParams IO (Maybe HeadId)
forall {a}. IO (Maybe a)
getNothing IO (Maybe (Set SimpleTxOut))
IO (Maybe (UTxOType SimpleTx))
getUTxO 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
-> PParams LedgerEra
-> IO (Maybe HeadId)
-> IO (Maybe (UTxOType 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 PParams LedgerEra
defaultPParams IO (Maybe HeadId)
forall {a}. IO (Maybe a)
getNothing IO (Maybe UTxO)
IO (Maybe (UTxOType Tx))
getUTxO 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 -> 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 (Maybe HeadId)
getHeadId = Maybe HeadId -> IO (Maybe HeadId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe HeadId -> IO (Maybe HeadId))
-> Maybe HeadId -> IO (Maybe HeadId)
forall a b. (a -> b) -> a -> b
$ HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just (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
-> PParams LedgerEra
-> IO (Maybe HeadId)
-> IO (Maybe (UTxOType Tx))
-> (ClientInput Tx -> IO ())
-> Application
forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> PParams LedgerEra
-> IO (Maybe HeadId)
-> IO (Maybe (UTxOType tx))
-> (ClientInput tx -> IO ())
-> Application
httpApp Tracer IO APIServerLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Chain Tx IO
workingChainHandle PParams LedgerEra
defaultPParams IO (Maybe HeadId)
getHeadId IO (Maybe UTxO)
IO (Maybe (UTxOType Tx))
forall {a}. IO (Maybe a)
getNothing ClientInput Tx -> IO ()
forall {b}. b -> IO ()
putClientInput) (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          ByteString -> ByteString -> WaiSession () SResponse
forall st. ByteString -> ByteString -> WaiSession st SResponse
post ByteString
"/commit" (DraftCommitTxRequest Tx -> ByteString
forall a. ToJSON a => a -> ByteString
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
              }
      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
                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
-> PParams LedgerEra
-> IO (Maybe HeadId)
-> IO (Maybe (UTxOType 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) PParams LedgerEra
defaultPParams IO (Maybe HeadId)
getHeadId IO (Maybe UTxO)
IO (Maybe (UTxOType Tx))
forall {a}. IO (Maybe a)
getNothing ClientInput Tx -> IO ()
forall {b}. b -> IO ()
putClientInput) (WaiSession () () -> IO ()) -> WaiSession () () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              ByteString -> ByteString -> WaiSession () SResponse
forall st. ByteString -> ByteString -> WaiSession st SResponse
post ByteString
"/commit" (DraftCommitTxRequest Tx -> ByteString
forall a. ToJSON a => a -> ByteString
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
. ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> String) -> (a -> ByteString) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
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] -> ByteString -> Maybe String) -> MatchBody
MatchBody (([Header] -> ByteString -> Maybe String) -> MatchBody)
-> ([Header] -> ByteString -> Maybe String) -> MatchBody
forall a b. (a -> b) -> a -> b
$ \[Header]
_headers ByteString
body ->
    case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
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