{-# LANGUAGE UndecidableInstances #-}

module Hydra.API.HTTPServer where

import Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Core (PParams)
import Data.Aeson (KeyValue ((.=)), Value (Object), object, withObject, (.:), (.:?))
import Data.Aeson qualified as Aeson
import Data.Aeson.KeyMap qualified as KeyMap
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Short ()
import Data.Text (pack)
import Hydra.API.APIServerLog (APIServerLog (..), Method (..), PathInfo (..))
import Hydra.Cardano.Api (
  CtxUTxO,
  HashableScriptData,
  KeyWitnessInCtx (..),
  LedgerEra,
  PlutusScript,
  ScriptDatum (InlineScriptDatum, ScriptDatumForTxIn),
  ScriptWitnessInCtx (ScriptWitnessForSpending),
  Tx,
  TxOut,
  UTxO',
  deserialiseFromTextEnvelope,
  fromLedgerPParams,
  mkScriptWitness,
  proxyToAsType,
  serialiseToTextEnvelope,
  shelleyBasedEra,
  pattern KeyWitness,
  pattern ScriptWitness,
 )
import Hydra.Chain (Chain (..), IsChainState, PostTxError (..), draftCommitTx)
import Hydra.Chain.Direct.State ()
import Hydra.HeadId (HeadId)
import Hydra.Ledger.Cardano ()
import Hydra.Logging (Tracer, traceWith)
import Network.HTTP.Types (status200, status400, status500)
import Network.Wai (
  Application,
  Request (pathInfo, requestMethod),
  Response,
  consumeRequestBodyStrict,
  rawPathInfo,
  responseLBS,
 )

newtype DraftCommitTxResponse = DraftCommitTxResponse
  { DraftCommitTxResponse -> Tx
commitTx :: Tx
  }
  deriving stock (Int -> DraftCommitTxResponse -> ShowS
[DraftCommitTxResponse] -> ShowS
DraftCommitTxResponse -> String
(Int -> DraftCommitTxResponse -> ShowS)
-> (DraftCommitTxResponse -> String)
-> ([DraftCommitTxResponse] -> ShowS)
-> Show DraftCommitTxResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DraftCommitTxResponse -> ShowS
showsPrec :: Int -> DraftCommitTxResponse -> ShowS
$cshow :: DraftCommitTxResponse -> String
show :: DraftCommitTxResponse -> String
$cshowList :: [DraftCommitTxResponse] -> ShowS
showList :: [DraftCommitTxResponse] -> ShowS
Show, (forall x. DraftCommitTxResponse -> Rep DraftCommitTxResponse x)
-> (forall x. Rep DraftCommitTxResponse x -> DraftCommitTxResponse)
-> Generic DraftCommitTxResponse
forall x. Rep DraftCommitTxResponse x -> DraftCommitTxResponse
forall x. DraftCommitTxResponse -> Rep DraftCommitTxResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DraftCommitTxResponse -> Rep DraftCommitTxResponse x
from :: forall x. DraftCommitTxResponse -> Rep DraftCommitTxResponse x
$cto :: forall x. Rep DraftCommitTxResponse x -> DraftCommitTxResponse
to :: forall x. Rep DraftCommitTxResponse x -> DraftCommitTxResponse
Generic)

instance ToJSON DraftCommitTxResponse where
  toJSON :: DraftCommitTxResponse -> Value
toJSON (DraftCommitTxResponse Tx
tx) =
    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 (TextEnvelopeDescr -> Maybe TextEnvelopeDescr
forall a. a -> Maybe a
Just TextEnvelopeDescr
"Hydra commit transaction") Tx
tx

instance FromJSON DraftCommitTxResponse where
  parseJSON :: Value -> Parser DraftCommitTxResponse
parseJSON Value
v = do
    TextEnvelope
env <- Value -> Parser TextEnvelope
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
    case AsType Tx -> TextEnvelope -> Either TextEnvelopeError Tx
forall a.
HasTextEnvelope a =>
AsType a -> TextEnvelope -> Either TextEnvelopeError a
deserialiseFromTextEnvelope (Proxy Tx -> AsType Tx
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType Proxy Tx
forall {k} (t :: k). Proxy t
Proxy) TextEnvelope
env of
      Left TextEnvelopeError
e -> String -> Parser DraftCommitTxResponse
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser DraftCommitTxResponse)
-> String -> Parser DraftCommitTxResponse
forall a b. (a -> b) -> a -> b
$ TextEnvelopeError -> String
forall b a. (Show a, IsString b) => a -> b
show TextEnvelopeError
e
      Right Tx
tx -> DraftCommitTxResponse -> Parser DraftCommitTxResponse
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DraftCommitTxResponse -> Parser DraftCommitTxResponse)
-> DraftCommitTxResponse -> Parser DraftCommitTxResponse
forall a b. (a -> b) -> a -> b
$ Tx -> DraftCommitTxResponse
DraftCommitTxResponse Tx
tx

instance Arbitrary DraftCommitTxResponse where
  arbitrary :: Gen DraftCommitTxResponse
arbitrary = Gen DraftCommitTxResponse
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

  shrink :: DraftCommitTxResponse -> [DraftCommitTxResponse]
shrink = \case
    DraftCommitTxResponse Tx
xs -> Tx -> DraftCommitTxResponse
DraftCommitTxResponse (Tx -> DraftCommitTxResponse) -> [Tx] -> [DraftCommitTxResponse]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx -> [Tx]
forall a. Arbitrary a => a -> [a]
shrink Tx
xs

-- TODO: This should actually be isomorphic to ScriptWitness of cardano-api,
-- i.e. we should support also native scripts, other versions of plutus and
-- witnessing via reference inputs
data ScriptInfo = ScriptInfo
  { ScriptInfo -> HashableScriptData
redeemer :: HashableScriptData
  , ScriptInfo -> Maybe HashableScriptData
datum :: Maybe HashableScriptData
  , ScriptInfo -> PlutusScript
plutusV2Script :: PlutusScript
  }
  deriving stock (Int -> ScriptInfo -> ShowS
[ScriptInfo] -> ShowS
ScriptInfo -> String
(Int -> ScriptInfo -> ShowS)
-> (ScriptInfo -> String)
-> ([ScriptInfo] -> ShowS)
-> Show ScriptInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScriptInfo -> ShowS
showsPrec :: Int -> ScriptInfo -> ShowS
$cshow :: ScriptInfo -> String
show :: ScriptInfo -> String
$cshowList :: [ScriptInfo] -> ShowS
showList :: [ScriptInfo] -> ShowS
Show, ScriptInfo -> ScriptInfo -> Bool
(ScriptInfo -> ScriptInfo -> Bool)
-> (ScriptInfo -> ScriptInfo -> Bool) -> Eq ScriptInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScriptInfo -> ScriptInfo -> Bool
== :: ScriptInfo -> ScriptInfo -> Bool
$c/= :: ScriptInfo -> ScriptInfo -> Bool
/= :: ScriptInfo -> ScriptInfo -> Bool
Eq, (forall x. ScriptInfo -> Rep ScriptInfo x)
-> (forall x. Rep ScriptInfo x -> ScriptInfo) -> Generic ScriptInfo
forall x. Rep ScriptInfo x -> ScriptInfo
forall x. ScriptInfo -> Rep ScriptInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ScriptInfo -> Rep ScriptInfo x
from :: forall x. ScriptInfo -> Rep ScriptInfo x
$cto :: forall x. Rep ScriptInfo x -> ScriptInfo
to :: forall x. Rep ScriptInfo x -> ScriptInfo
Generic)
  deriving anyclass ([ScriptInfo] -> Value
[ScriptInfo] -> Encoding
ScriptInfo -> Bool
ScriptInfo -> Value
ScriptInfo -> Encoding
(ScriptInfo -> Value)
-> (ScriptInfo -> Encoding)
-> ([ScriptInfo] -> Value)
-> ([ScriptInfo] -> Encoding)
-> (ScriptInfo -> Bool)
-> ToJSON ScriptInfo
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ScriptInfo -> Value
toJSON :: ScriptInfo -> Value
$ctoEncoding :: ScriptInfo -> Encoding
toEncoding :: ScriptInfo -> Encoding
$ctoJSONList :: [ScriptInfo] -> Value
toJSONList :: [ScriptInfo] -> Value
$ctoEncodingList :: [ScriptInfo] -> Encoding
toEncodingList :: [ScriptInfo] -> Encoding
$comitField :: ScriptInfo -> Bool
omitField :: ScriptInfo -> Bool
ToJSON, Maybe ScriptInfo
Value -> Parser [ScriptInfo]
Value -> Parser ScriptInfo
(Value -> Parser ScriptInfo)
-> (Value -> Parser [ScriptInfo])
-> Maybe ScriptInfo
-> FromJSON ScriptInfo
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ScriptInfo
parseJSON :: Value -> Parser ScriptInfo
$cparseJSONList :: Value -> Parser [ScriptInfo]
parseJSONList :: Value -> Parser [ScriptInfo]
$comittedField :: Maybe ScriptInfo
omittedField :: Maybe ScriptInfo
FromJSON)

instance Arbitrary ScriptInfo where
  arbitrary :: Gen ScriptInfo
arbitrary = Gen ScriptInfo
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

data TxOutWithWitness = TxOutWithWitness
  { TxOutWithWitness -> TxOut CtxUTxO
txOut :: TxOut CtxUTxO
  , TxOutWithWitness -> Maybe ScriptInfo
witness :: Maybe ScriptInfo
  }
  deriving stock (Int -> TxOutWithWitness -> ShowS
[TxOutWithWitness] -> ShowS
TxOutWithWitness -> String
(Int -> TxOutWithWitness -> ShowS)
-> (TxOutWithWitness -> String)
-> ([TxOutWithWitness] -> ShowS)
-> Show TxOutWithWitness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TxOutWithWitness -> ShowS
showsPrec :: Int -> TxOutWithWitness -> ShowS
$cshow :: TxOutWithWitness -> String
show :: TxOutWithWitness -> String
$cshowList :: [TxOutWithWitness] -> ShowS
showList :: [TxOutWithWitness] -> ShowS
Show, TxOutWithWitness -> TxOutWithWitness -> Bool
(TxOutWithWitness -> TxOutWithWitness -> Bool)
-> (TxOutWithWitness -> TxOutWithWitness -> Bool)
-> Eq TxOutWithWitness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TxOutWithWitness -> TxOutWithWitness -> Bool
== :: TxOutWithWitness -> TxOutWithWitness -> Bool
$c/= :: TxOutWithWitness -> TxOutWithWitness -> Bool
/= :: TxOutWithWitness -> TxOutWithWitness -> Bool
Eq, (forall x. TxOutWithWitness -> Rep TxOutWithWitness x)
-> (forall x. Rep TxOutWithWitness x -> TxOutWithWitness)
-> Generic TxOutWithWitness
forall x. Rep TxOutWithWitness x -> TxOutWithWitness
forall x. TxOutWithWitness -> Rep TxOutWithWitness x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TxOutWithWitness -> Rep TxOutWithWitness x
from :: forall x. TxOutWithWitness -> Rep TxOutWithWitness x
$cto :: forall x. Rep TxOutWithWitness x -> TxOutWithWitness
to :: forall x. Rep TxOutWithWitness x -> TxOutWithWitness
Generic)

instance ToJSON TxOutWithWitness where
  toJSON :: TxOutWithWitness -> Value
toJSON TxOutWithWitness{TxOut CtxUTxO
$sel:txOut:TxOutWithWitness :: TxOutWithWitness -> TxOut CtxUTxO
txOut :: TxOut CtxUTxO
txOut, Maybe ScriptInfo
$sel:witness:TxOutWithWitness :: TxOutWithWitness -> Maybe ScriptInfo
witness :: Maybe ScriptInfo
witness} =
    case TxOut CtxUTxO -> Value
forall a. ToJSON a => a -> Value
toJSON TxOut CtxUTxO
txOut of
      Object Object
km
        | Maybe ScriptInfo -> Bool
forall a. Maybe a -> Bool
isJust Maybe ScriptInfo
witness ->
            Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Object
km Object -> (Object -> Object) -> Object
forall a b. a -> (a -> b) -> b
& Key
"witness" Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
`KeyMap.insert` Maybe ScriptInfo -> Value
forall a. ToJSON a => a -> Value
toJSON Maybe ScriptInfo
witness
      Value
x -> Value
x

instance FromJSON TxOutWithWitness where
  parseJSON :: Value -> Parser TxOutWithWitness
parseJSON Value
v = do
    TxOut CtxUTxO
txOut <- Value -> Parser (TxOut CtxUTxO)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
    ((Object -> Parser TxOutWithWitness)
 -> Value -> Parser TxOutWithWitness)
-> Value
-> (Object -> Parser TxOutWithWitness)
-> Parser TxOutWithWitness
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String
-> (Object -> Parser TxOutWithWitness)
-> Value
-> Parser TxOutWithWitness
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"TxOutWithWitness") Value
v ((Object -> Parser TxOutWithWitness) -> Parser TxOutWithWitness)
-> (Object -> Parser TxOutWithWitness) -> Parser TxOutWithWitness
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
      Maybe ScriptInfo
witness <- Object
o Object -> Key -> Parser (Maybe ScriptInfo)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"witness"
      TxOutWithWitness -> Parser TxOutWithWitness
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOutWithWitness -> Parser TxOutWithWitness)
-> TxOutWithWitness -> Parser TxOutWithWitness
forall a b. (a -> b) -> a -> b
$ TxOutWithWitness{TxOut CtxUTxO
$sel:txOut:TxOutWithWitness :: TxOut CtxUTxO
txOut :: TxOut CtxUTxO
txOut, Maybe ScriptInfo
$sel:witness:TxOutWithWitness :: Maybe ScriptInfo
witness :: Maybe ScriptInfo
witness}

instance Arbitrary TxOutWithWitness where
  arbitrary :: Gen TxOutWithWitness
arbitrary = Gen TxOutWithWitness
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

deriving newtype instance Arbitrary (UTxO' TxOutWithWitness)

newtype DraftCommitTxRequest = DraftCommitTxRequest
  { DraftCommitTxRequest -> UTxO' TxOutWithWitness
utxoToCommit :: UTxO' TxOutWithWitness
  }
  deriving stock (DraftCommitTxRequest -> DraftCommitTxRequest -> Bool
(DraftCommitTxRequest -> DraftCommitTxRequest -> Bool)
-> (DraftCommitTxRequest -> DraftCommitTxRequest -> Bool)
-> Eq DraftCommitTxRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DraftCommitTxRequest -> DraftCommitTxRequest -> Bool
== :: DraftCommitTxRequest -> DraftCommitTxRequest -> Bool
$c/= :: DraftCommitTxRequest -> DraftCommitTxRequest -> Bool
/= :: DraftCommitTxRequest -> DraftCommitTxRequest -> Bool
Eq, Int -> DraftCommitTxRequest -> ShowS
[DraftCommitTxRequest] -> ShowS
DraftCommitTxRequest -> String
(Int -> DraftCommitTxRequest -> ShowS)
-> (DraftCommitTxRequest -> String)
-> ([DraftCommitTxRequest] -> ShowS)
-> Show DraftCommitTxRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DraftCommitTxRequest -> ShowS
showsPrec :: Int -> DraftCommitTxRequest -> ShowS
$cshow :: DraftCommitTxRequest -> String
show :: DraftCommitTxRequest -> String
$cshowList :: [DraftCommitTxRequest] -> ShowS
showList :: [DraftCommitTxRequest] -> ShowS
Show, (forall x. DraftCommitTxRequest -> Rep DraftCommitTxRequest x)
-> (forall x. Rep DraftCommitTxRequest x -> DraftCommitTxRequest)
-> Generic DraftCommitTxRequest
forall x. Rep DraftCommitTxRequest x -> DraftCommitTxRequest
forall x. DraftCommitTxRequest -> Rep DraftCommitTxRequest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DraftCommitTxRequest -> Rep DraftCommitTxRequest x
from :: forall x. DraftCommitTxRequest -> Rep DraftCommitTxRequest x
$cto :: forall x. Rep DraftCommitTxRequest x -> DraftCommitTxRequest
to :: forall x. Rep DraftCommitTxRequest x -> DraftCommitTxRequest
Generic)
  deriving newtype ([DraftCommitTxRequest] -> Value
[DraftCommitTxRequest] -> Encoding
DraftCommitTxRequest -> Bool
DraftCommitTxRequest -> Value
DraftCommitTxRequest -> Encoding
(DraftCommitTxRequest -> Value)
-> (DraftCommitTxRequest -> Encoding)
-> ([DraftCommitTxRequest] -> Value)
-> ([DraftCommitTxRequest] -> Encoding)
-> (DraftCommitTxRequest -> Bool)
-> ToJSON DraftCommitTxRequest
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: DraftCommitTxRequest -> Value
toJSON :: DraftCommitTxRequest -> Value
$ctoEncoding :: DraftCommitTxRequest -> Encoding
toEncoding :: DraftCommitTxRequest -> Encoding
$ctoJSONList :: [DraftCommitTxRequest] -> Value
toJSONList :: [DraftCommitTxRequest] -> Value
$ctoEncodingList :: [DraftCommitTxRequest] -> Encoding
toEncodingList :: [DraftCommitTxRequest] -> Encoding
$comitField :: DraftCommitTxRequest -> Bool
omitField :: DraftCommitTxRequest -> Bool
ToJSON, Maybe DraftCommitTxRequest
Value -> Parser [DraftCommitTxRequest]
Value -> Parser DraftCommitTxRequest
(Value -> Parser DraftCommitTxRequest)
-> (Value -> Parser [DraftCommitTxRequest])
-> Maybe DraftCommitTxRequest
-> FromJSON DraftCommitTxRequest
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser DraftCommitTxRequest
parseJSON :: Value -> Parser DraftCommitTxRequest
$cparseJSONList :: Value -> Parser [DraftCommitTxRequest]
parseJSONList :: Value -> Parser [DraftCommitTxRequest]
$comittedField :: Maybe DraftCommitTxRequest
omittedField :: Maybe DraftCommitTxRequest
FromJSON)

instance Arbitrary DraftCommitTxRequest where
  arbitrary :: Gen DraftCommitTxRequest
arbitrary = Gen DraftCommitTxRequest
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

  shrink :: DraftCommitTxRequest -> [DraftCommitTxRequest]
shrink = \case
    DraftCommitTxRequest UTxO' TxOutWithWitness
u -> UTxO' TxOutWithWitness -> DraftCommitTxRequest
DraftCommitTxRequest (UTxO' TxOutWithWitness -> DraftCommitTxRequest)
-> [UTxO' TxOutWithWitness] -> [DraftCommitTxRequest]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO' TxOutWithWitness -> [UTxO' TxOutWithWitness]
forall a. Arbitrary a => a -> [a]
shrink UTxO' TxOutWithWitness
u

newtype SubmitTxRequest tx = SubmitTxRequest
  { forall tx. SubmitTxRequest tx -> tx
txToSubmit :: tx
  }
  deriving newtype (SubmitTxRequest tx -> SubmitTxRequest tx -> Bool
(SubmitTxRequest tx -> SubmitTxRequest tx -> Bool)
-> (SubmitTxRequest tx -> SubmitTxRequest tx -> Bool)
-> Eq (SubmitTxRequest tx)
forall tx.
Eq tx =>
SubmitTxRequest tx -> SubmitTxRequest tx -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall tx.
Eq tx =>
SubmitTxRequest tx -> SubmitTxRequest tx -> Bool
== :: SubmitTxRequest tx -> SubmitTxRequest tx -> Bool
$c/= :: forall tx.
Eq tx =>
SubmitTxRequest tx -> SubmitTxRequest tx -> Bool
/= :: SubmitTxRequest tx -> SubmitTxRequest tx -> Bool
Eq, Int -> SubmitTxRequest tx -> ShowS
[SubmitTxRequest tx] -> ShowS
SubmitTxRequest tx -> String
(Int -> SubmitTxRequest tx -> ShowS)
-> (SubmitTxRequest tx -> String)
-> ([SubmitTxRequest tx] -> ShowS)
-> Show (SubmitTxRequest tx)
forall tx. Show tx => Int -> SubmitTxRequest tx -> ShowS
forall tx. Show tx => [SubmitTxRequest tx] -> ShowS
forall tx. Show tx => SubmitTxRequest tx -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall tx. Show tx => Int -> SubmitTxRequest tx -> ShowS
showsPrec :: Int -> SubmitTxRequest tx -> ShowS
$cshow :: forall tx. Show tx => SubmitTxRequest tx -> String
show :: SubmitTxRequest tx -> String
$cshowList :: forall tx. Show tx => [SubmitTxRequest tx] -> ShowS
showList :: [SubmitTxRequest tx] -> ShowS
Show, Gen (SubmitTxRequest tx)
Gen (SubmitTxRequest tx)
-> (SubmitTxRequest tx -> [SubmitTxRequest tx])
-> Arbitrary (SubmitTxRequest tx)
SubmitTxRequest tx -> [SubmitTxRequest tx]
forall tx. Arbitrary tx => Gen (SubmitTxRequest tx)
forall tx.
Arbitrary tx =>
SubmitTxRequest tx -> [SubmitTxRequest tx]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: forall tx. Arbitrary tx => Gen (SubmitTxRequest tx)
arbitrary :: Gen (SubmitTxRequest tx)
$cshrink :: forall tx.
Arbitrary tx =>
SubmitTxRequest tx -> [SubmitTxRequest tx]
shrink :: SubmitTxRequest tx -> [SubmitTxRequest tx]
Arbitrary)
  deriving newtype ([SubmitTxRequest tx] -> Value
[SubmitTxRequest tx] -> Encoding
SubmitTxRequest tx -> Bool
SubmitTxRequest tx -> Value
SubmitTxRequest tx -> Encoding
(SubmitTxRequest tx -> Value)
-> (SubmitTxRequest tx -> Encoding)
-> ([SubmitTxRequest tx] -> Value)
-> ([SubmitTxRequest tx] -> Encoding)
-> (SubmitTxRequest tx -> Bool)
-> ToJSON (SubmitTxRequest tx)
forall tx. ToJSON tx => [SubmitTxRequest tx] -> Value
forall tx. ToJSON tx => [SubmitTxRequest tx] -> Encoding
forall tx. ToJSON tx => SubmitTxRequest tx -> Bool
forall tx. ToJSON tx => SubmitTxRequest tx -> Value
forall tx. ToJSON tx => SubmitTxRequest tx -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: forall tx. ToJSON tx => SubmitTxRequest tx -> Value
toJSON :: SubmitTxRequest tx -> Value
$ctoEncoding :: forall tx. ToJSON tx => SubmitTxRequest tx -> Encoding
toEncoding :: SubmitTxRequest tx -> Encoding
$ctoJSONList :: forall tx. ToJSON tx => [SubmitTxRequest tx] -> Value
toJSONList :: [SubmitTxRequest tx] -> Value
$ctoEncodingList :: forall tx. ToJSON tx => [SubmitTxRequest tx] -> Encoding
toEncodingList :: [SubmitTxRequest tx] -> Encoding
$comitField :: forall tx. ToJSON tx => SubmitTxRequest tx -> Bool
omitField :: SubmitTxRequest tx -> Bool
ToJSON, Maybe (SubmitTxRequest tx)
Value -> Parser [SubmitTxRequest tx]
Value -> Parser (SubmitTxRequest tx)
(Value -> Parser (SubmitTxRequest tx))
-> (Value -> Parser [SubmitTxRequest tx])
-> Maybe (SubmitTxRequest tx)
-> FromJSON (SubmitTxRequest tx)
forall tx. FromJSON tx => Maybe (SubmitTxRequest tx)
forall tx. FromJSON tx => Value -> Parser [SubmitTxRequest tx]
forall tx. FromJSON tx => Value -> Parser (SubmitTxRequest tx)
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: forall tx. FromJSON tx => Value -> Parser (SubmitTxRequest tx)
parseJSON :: Value -> Parser (SubmitTxRequest tx)
$cparseJSONList :: forall tx. FromJSON tx => Value -> Parser [SubmitTxRequest tx]
parseJSONList :: Value -> Parser [SubmitTxRequest tx]
$comittedField :: forall tx. FromJSON tx => Maybe (SubmitTxRequest tx)
omittedField :: Maybe (SubmitTxRequest tx)
FromJSON)

data TransactionSubmitted = TransactionSubmitted
  deriving stock (TransactionSubmitted -> TransactionSubmitted -> Bool
(TransactionSubmitted -> TransactionSubmitted -> Bool)
-> (TransactionSubmitted -> TransactionSubmitted -> Bool)
-> Eq TransactionSubmitted
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransactionSubmitted -> TransactionSubmitted -> Bool
== :: TransactionSubmitted -> TransactionSubmitted -> Bool
$c/= :: TransactionSubmitted -> TransactionSubmitted -> Bool
/= :: TransactionSubmitted -> TransactionSubmitted -> Bool
Eq, Int -> TransactionSubmitted -> ShowS
[TransactionSubmitted] -> ShowS
TransactionSubmitted -> String
(Int -> TransactionSubmitted -> ShowS)
-> (TransactionSubmitted -> String)
-> ([TransactionSubmitted] -> ShowS)
-> Show TransactionSubmitted
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransactionSubmitted -> ShowS
showsPrec :: Int -> TransactionSubmitted -> ShowS
$cshow :: TransactionSubmitted -> String
show :: TransactionSubmitted -> String
$cshowList :: [TransactionSubmitted] -> ShowS
showList :: [TransactionSubmitted] -> ShowS
Show, (forall x. TransactionSubmitted -> Rep TransactionSubmitted x)
-> (forall x. Rep TransactionSubmitted x -> TransactionSubmitted)
-> Generic TransactionSubmitted
forall x. Rep TransactionSubmitted x -> TransactionSubmitted
forall x. TransactionSubmitted -> Rep TransactionSubmitted x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TransactionSubmitted -> Rep TransactionSubmitted x
from :: forall x. TransactionSubmitted -> Rep TransactionSubmitted x
$cto :: forall x. Rep TransactionSubmitted x -> TransactionSubmitted
to :: forall x. Rep TransactionSubmitted x -> TransactionSubmitted
Generic)

instance ToJSON TransactionSubmitted where
  toJSON :: TransactionSubmitted -> Value
toJSON TransactionSubmitted
_ =
    [Pair] -> Value
object
      [ Key
"tag" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String Text
"TransactionSubmitted"
      ]

instance FromJSON TransactionSubmitted where
  parseJSON :: Value -> Parser TransactionSubmitted
parseJSON = String
-> (Object -> Parser TransactionSubmitted)
-> Value
-> Parser TransactionSubmitted
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"TransactionSubmitted" ((Object -> Parser TransactionSubmitted)
 -> Value -> Parser TransactionSubmitted)
-> (Object -> Parser TransactionSubmitted)
-> Value
-> Parser TransactionSubmitted
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
tag <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tag"
    case Text
tag :: Text of
      Text
"TransactionSubmitted" ->
        TransactionSubmitted -> Parser TransactionSubmitted
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TransactionSubmitted
TransactionSubmitted
      Text
_ -> String -> Parser TransactionSubmitted
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected tag to be TransactionSubmitted"

instance Arbitrary TransactionSubmitted where
  arbitrary :: Gen TransactionSubmitted
arbitrary = Gen TransactionSubmitted
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

-- | Hydra HTTP server
httpApp ::
  Tracer IO APIServerLog ->
  Chain tx IO ->
  PParams LedgerEra ->
  -- | A means to get the 'HeadId' if initializing the Head.
  (STM IO) (Maybe HeadId) ->
  Application
httpApp :: forall tx.
Tracer IO APIServerLog
-> Chain tx IO
-> PParams LedgerEra
-> STM IO (Maybe HeadId)
-> Application
httpApp Tracer IO APIServerLog
tracer Chain tx IO
directChain PParams LedgerEra
pparams STM IO (Maybe HeadId)
getInitializingHeadId Request
request Response -> IO ResponseReceived
respond = do
  Tracer IO APIServerLog -> APIServerLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO APIServerLog
tracer (APIServerLog -> IO ()) -> APIServerLog -> IO ()
forall a b. (a -> b) -> a -> b
$
    APIHTTPRequestReceived
      { $sel:method:APIServerStarted :: Method
method = Method -> Method
Method (Method -> Method) -> Method -> Method
forall a b. (a -> b) -> a -> b
$ Request -> Method
requestMethod Request
request
      , $sel:path:APIServerStarted :: PathInfo
path = Method -> PathInfo
PathInfo (Method -> PathInfo) -> Method -> PathInfo
forall a b. (a -> b) -> a -> b
$ Request -> Method
rawPathInfo Request
request
      }
  case (Request -> Method
requestMethod Request
request, Request -> [Text]
pathInfo Request
request) of
    (Method
"POST", [Text
"commit"]) ->
      Request -> IO ByteString
consumeRequestBodyStrict Request
request
        IO ByteString -> (ByteString -> IO Response) -> IO Response
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Chain tx IO -> STM IO (Maybe HeadId) -> ByteString -> IO Response
forall tx.
Chain tx IO -> STM IO (Maybe HeadId) -> ByteString -> IO Response
handleDraftCommitUtxo Chain tx IO
directChain STM IO (Maybe HeadId)
getInitializingHeadId
        IO Response
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response -> IO ResponseReceived
respond
    (Method
"GET", [Text
"protocol-parameters"]) ->
      Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> (ProtocolParameters -> Response)
-> ProtocolParameters
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 [] (ByteString -> Response)
-> (ProtocolParameters -> ByteString)
-> ProtocolParameters
-> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolParameters -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (ProtocolParameters -> IO ResponseReceived)
-> ProtocolParameters -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
        ShelleyBasedEra BabbageEra
-> PParams LedgerEra -> ProtocolParameters
forall era.
ShelleyBasedEra era
-> PParams (ShelleyLedgerEra era) -> ProtocolParameters
fromLedgerPParams ShelleyBasedEra BabbageEra
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra PParams LedgerEra
pparams
    (Method
"POST", [Text
"cardano-transaction"]) ->
      Request -> IO ByteString
consumeRequestBodyStrict Request
request
        IO ByteString -> (ByteString -> IO Response) -> IO Response
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Chain tx IO -> ByteString -> IO Response
forall tx. Chain tx IO -> ByteString -> IO Response
handleSubmitUserTx Chain tx IO
directChain
        IO Response
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response -> IO ResponseReceived
respond
    (Method, [Text])
_ ->
      Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status400 [] ByteString
"Resource not found"

-- * Handlers

-- | Handle request to obtain a draft commit tx.
--
-- Users can decide to commit a public key as well as script outputs.
--
-- ==== __Request body examples:__
--
-- @
--
-- // Committing public key output
--
-- {
--  "0406060506030602040508060506060306050406020207000508040704040203#89": {
--     "address": "addr_test1vz66ue36465w2qq40005h2hadad6pnjht8mu6sgplsfj74q9pm4f4",
--     "value": {
--       "lovelace": 7620669
--     }
-- }
--
-- @
--
-- @
--
-- // Committing a script output
--
-- {
--  "6f066e0f6ba373c0ea7d8b47aefd7e14d1a781698cd052d0254afe65e039b083#0": {
--   "address": "addr_test1wqv4z4hc0u5e2c3sppfdu8ckn82hfegpkjagsm4t8ttvlycg9mkca",
--   "datum": null,
--   "datumhash": "bb30a42c1e62f0afda5f0a4e8a562f7a13a24cea00ee81917b86b89e801314aa",
--   "inlineDatum": null,
--   "referenceScript": null,
--   "value": {
--     "lovelace": 1034400
--   },
--   "witness": {
--     "datum": "02",
--     "plutusV2Script": {
--       "cborHex": "484701000022200101",
--       "description": "",
--       "type": "PlutusScriptV2"
--     },
--     "redeemer": "01"
--   }
-- }
--
-- @
--
-- @
-- // Committing a script output using inline datum
--
-- {
--
-- "87a0c1e14be2cd8c385b6fe5a40b024b7201da9df375542029d91ccaba01ac82#0": {
--     "address": "addr_test1wqv4z4hc0u5e2c3sppfdu8ckn82hfegpkjagsm4t8ttvlycg9mkca",
--     "datum": null,
--     "inlineDatum": {
--       "int": 2
--     },
--     "inlineDatumhash": "bb30a42c1e62f0afda5f0a4e8a562f7a13a24cea00ee81917b86b89e801314aa",
--     "referenceScript": null,
--     "value": {
--       "lovelace": 905100
--     },
--     "witness": {
--       "datum": null,
--       "plutusV2Script": {
--         "cborHex": "484701000022200101",
--         "description": "",
--         "type": "PlutusScriptV2"
--       },
--       "redeemer": "01"
--     }
--   }
--   @
handleDraftCommitUtxo ::
  Chain tx IO ->
  -- | A means to get the 'HeadId' if initializing the Head.
  (STM IO) (Maybe HeadId) ->
  -- | Request body.
  LBS.ByteString ->
  IO Response
handleDraftCommitUtxo :: forall tx.
Chain tx IO -> STM IO (Maybe HeadId) -> ByteString -> IO Response
handleDraftCommitUtxo Chain tx IO
directChain STM IO (Maybe HeadId)
getInitializingHeadId ByteString
body = do
  case ByteString -> Either String DraftCommitTxRequest
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode' ByteString
body :: Either String DraftCommitTxRequest of
    Left String
err ->
      Response -> IO Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status400 [] (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Value
Aeson.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
err)
    Right DraftCommitTxRequest{UTxO' TxOutWithWitness
$sel:utxoToCommit:DraftCommitTxRequest :: DraftCommitTxRequest -> UTxO' TxOutWithWitness
utxoToCommit :: UTxO' TxOutWithWitness
utxoToCommit} -> do
      STM IO (Maybe HeadId) -> IO (Maybe HeadId)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM IO (Maybe HeadId)
getInitializingHeadId IO (Maybe HeadId) -> (Maybe HeadId -> IO Response) -> IO Response
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just HeadId
headId -> do
          MonadThrow IO =>
HeadId
-> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
-> IO (Either (PostTxError Tx) Tx)
HeadId
-> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
-> IO (Either (PostTxError Tx) Tx)
draftCommitTx HeadId
headId (TxOutWithWitness -> (TxOut CtxUTxO, Witness WitCtxTxIn)
fromTxOutWithWitness (TxOutWithWitness -> (TxOut CtxUTxO, Witness WitCtxTxIn))
-> UTxO' TxOutWithWitness
-> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO' TxOutWithWitness
utxoToCommit) IO (Either (PostTxError Tx) Tx)
-> (Either (PostTxError Tx) Tx -> Response) -> IO Response
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
            Left PostTxError Tx
e ->
              -- Distinguish between errors users can actually benefit from and
              -- other errors that are turned into 500 responses.
              case PostTxError Tx
e of
                PostTxError Tx
CannotCommitReferenceScript -> PostTxError Tx -> Response
forall tx. IsChainState tx => PostTxError tx -> Response
return400 PostTxError Tx
e
                CommittedTooMuchADAForMainnet Coin
_ Coin
_ -> PostTxError Tx -> Response
forall tx. IsChainState tx => PostTxError tx -> Response
return400 PostTxError Tx
e
                UnsupportedLegacyOutput Address ByronAddr
_ -> PostTxError Tx -> Response
forall tx. IsChainState tx => PostTxError tx -> Response
return400 PostTxError Tx
e
                walletUtxoErr :: PostTxError Tx
walletUtxoErr@PostTxError Tx
SpendingNodeUtxoForbidden -> PostTxError Tx -> Response
forall tx. IsChainState tx => PostTxError tx -> Response
return400 PostTxError Tx
walletUtxoErr
                PostTxError Tx
_ -> Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status500 [] (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ PostTxError Tx -> Value
forall a. ToJSON a => a -> Value
toJSON PostTxError Tx
e)
            Right Tx
commitTx ->
              Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 [] (DraftCommitTxResponse -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (DraftCommitTxResponse -> ByteString)
-> DraftCommitTxResponse -> ByteString
forall a b. (a -> b) -> a -> b
$ Tx -> DraftCommitTxResponse
DraftCommitTxResponse Tx
commitTx)
        -- XXX: This is not really an internal server error
        Maybe HeadId
Nothing -> Response -> IO Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status500 [] (PostTxError Tx -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (PostTxError Tx -> ByteString) -> PostTxError Tx -> ByteString
forall a b. (a -> b) -> a -> b
$ forall tx. PostTxError tx
FailedToDraftTxNotInitializing @Tx)
 where
  Chain{MonadThrow IO =>
HeadId
-> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
-> IO (Either (PostTxError Tx) Tx)
$sel:draftCommitTx:Chain :: forall tx (m :: * -> *).
Chain tx m
-> MonadThrow m =>
   HeadId
   -> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
   -> m (Either (PostTxError Tx) Tx)
draftCommitTx :: MonadThrow IO =>
HeadId
-> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
-> IO (Either (PostTxError Tx) Tx)
draftCommitTx} = Chain tx IO
directChain

  fromTxOutWithWitness :: TxOutWithWitness -> (TxOut CtxUTxO, Witness WitCtxTxIn)
fromTxOutWithWitness TxOutWithWitness{TxOut CtxUTxO
$sel:txOut:TxOutWithWitness :: TxOutWithWitness -> TxOut CtxUTxO
txOut :: TxOut CtxUTxO
txOut, Maybe ScriptInfo
$sel:witness:TxOutWithWitness :: TxOutWithWitness -> Maybe ScriptInfo
witness :: Maybe ScriptInfo
witness} =
    (TxOut CtxUTxO
txOut, Maybe ScriptInfo -> Witness WitCtxTxIn
toScriptWitness Maybe ScriptInfo
witness)
   where
    toScriptWitness :: Maybe ScriptInfo -> Witness WitCtxTxIn
toScriptWitness = \case
      Maybe ScriptInfo
Nothing ->
        KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn
forall ctx. KeyWitnessInCtx ctx -> Witness ctx
KeyWitness KeyWitnessInCtx WitCtxTxIn
KeyWitnessForSpending
      Just ScriptInfo{HashableScriptData
$sel:redeemer:ScriptInfo :: ScriptInfo -> HashableScriptData
redeemer :: HashableScriptData
redeemer, Maybe HashableScriptData
$sel:datum:ScriptInfo :: ScriptInfo -> Maybe HashableScriptData
datum :: Maybe HashableScriptData
datum, PlutusScript
$sel:plutusV2Script:ScriptInfo :: ScriptInfo -> PlutusScript
plutusV2Script :: PlutusScript
plutusV2Script} ->
        ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
ScriptWitnessForSpending (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall a b. (a -> b) -> a -> b
$
          case Maybe HashableScriptData
datum of
            Maybe HashableScriptData
Nothing ->
              -- In case the datum field is not present we are assumming the datum
              -- is inlined.
              PlutusScript
-> ScriptDatum WitCtxTxIn
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
PlutusScript lang
-> ScriptDatum ctx -> HashableScriptData -> ScriptWitness ctx era
mkScriptWitness PlutusScript
plutusV2Script ScriptDatum WitCtxTxIn
InlineScriptDatum HashableScriptData
redeemer
            Just HashableScriptData
d ->
              PlutusScript
-> ScriptDatum WitCtxTxIn
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
PlutusScript lang
-> ScriptDatum ctx -> HashableScriptData -> ScriptWitness ctx era
mkScriptWitness PlutusScript
plutusV2Script (HashableScriptData -> ScriptDatum WitCtxTxIn
ScriptDatumForTxIn HashableScriptData
d) HashableScriptData
redeemer

-- | Handle request to submit a cardano transaction.
handleSubmitUserTx ::
  Chain tx IO ->
  -- | Request body.
  LBS.ByteString ->
  IO Response
handleSubmitUserTx :: forall tx. Chain tx IO -> ByteString -> IO Response
handleSubmitUserTx Chain tx IO
directChain ByteString
body = do
  case ByteString -> Either String Tx
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode' ByteString
body :: Either String Tx of
    Left String
err ->
      Response -> IO Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status400 [] (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Value
Aeson.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
err)
    Right Tx
txToSubmit -> do
      IO () -> IO (Either (PostTxError Tx) ())
forall e a. Exception e => IO a -> IO (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (MonadThrow IO => Tx -> IO ()
Tx -> IO ()
submitTx Tx
txToSubmit) IO (Either (PostTxError Tx) ())
-> (Either (PostTxError Tx) () -> Response) -> IO Response
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        Left (PostTxError Tx
e :: PostTxError Tx) -> PostTxError Tx -> Response
forall tx. IsChainState tx => PostTxError tx -> Response
return400 PostTxError Tx
e
        Right ()
_ ->
          Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 [] (TransactionSubmitted -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode TransactionSubmitted
TransactionSubmitted)
 where
  Chain{MonadThrow IO => Tx -> IO ()
submitTx :: MonadThrow IO => Tx -> IO ()
$sel:submitTx:Chain :: forall tx (m :: * -> *). Chain tx m -> MonadThrow m => Tx -> m ()
submitTx} = Chain tx IO
directChain

return400 :: IsChainState tx => PostTxError tx -> Response
return400 :: forall tx. IsChainState tx => PostTxError tx -> Response
return400 = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status400 [] (ByteString -> Response)
-> (PostTxError tx -> ByteString) -> PostTxError tx -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> ByteString)
-> (PostTxError tx -> Value) -> PostTxError tx -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PostTxError tx -> Value
forall a. ToJSON a => a -> Value
toJSON