{-# LANGUAGE UndecidableInstances #-}
module Hydra.API.HTTPServer where
import Hydra.Prelude
import Cardano.Ledger.Core (PParams)
import Control.Concurrent.STM (TChan, dupTChan, readTChan)
import Data.Aeson (KeyValue ((.=)), object, withObject, (.:))
import Data.Aeson qualified as Aeson
import Data.Aeson.Types (Parser)
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Short ()
import Data.Text (pack)
import Hydra.API.APIServerLog (APIServerLog (..), Method (..), PathInfo (..))
import Hydra.API.ClientInput (ClientInput (..))
import Hydra.API.ServerOutput (ClientMessage, CommitInfo (..), ServerOutput (..), TimedServerOutput (..), getConfirmedSnapshot, getSeenSnapshot, getSnapshotUtxo)
import Hydra.Cardano.Api (LedgerEra, Tx)
import Hydra.Chain (Chain (..), PostTxError (..), draftCommitTx)
import Hydra.Chain.ChainState (IsChainState)
import Hydra.Chain.Direct.State ()
import Hydra.HeadLogic.State (HeadState (..))
import Hydra.Ledger (ValidationError (..))
import Hydra.Logging (Tracer, traceWith)
import Hydra.Node.ApiTransactionTimeout (ApiTransactionTimeout (..))
import Hydra.Node.DepositPeriod (toNominalDiffTime)
import Hydra.Node.Environment (Environment (..))
import Hydra.Tx (CommitBlueprintTx (..), ConfirmedSnapshot, IsTx (..), Snapshot (..), UTxOType)
import Network.HTTP.Types (ResponseHeaders, hContentType, status200, status202, status400, status404, status500)
import Network.Wai (Application, Request (pathInfo, requestMethod), Response, consumeRequestBodyStrict, rawPathInfo, responseLBS)
newtype DraftCommitTxResponse tx = DraftCommitTxResponse
{ forall tx. DraftCommitTxResponse tx -> tx
commitTx :: tx
}
deriving stock ((forall x.
DraftCommitTxResponse tx -> Rep (DraftCommitTxResponse tx) x)
-> (forall x.
Rep (DraftCommitTxResponse tx) x -> DraftCommitTxResponse tx)
-> Generic (DraftCommitTxResponse tx)
forall x.
Rep (DraftCommitTxResponse tx) x -> DraftCommitTxResponse tx
forall x.
DraftCommitTxResponse tx -> Rep (DraftCommitTxResponse tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x.
Rep (DraftCommitTxResponse tx) x -> DraftCommitTxResponse tx
forall tx x.
DraftCommitTxResponse tx -> Rep (DraftCommitTxResponse tx) x
$cfrom :: forall tx x.
DraftCommitTxResponse tx -> Rep (DraftCommitTxResponse tx) x
from :: forall x.
DraftCommitTxResponse tx -> Rep (DraftCommitTxResponse tx) x
$cto :: forall tx x.
Rep (DraftCommitTxResponse tx) x -> DraftCommitTxResponse tx
to :: forall x.
Rep (DraftCommitTxResponse tx) x -> DraftCommitTxResponse tx
Generic)
deriving stock instance Show tx => Show (DraftCommitTxResponse tx)
instance IsTx tx => ToJSON (DraftCommitTxResponse tx) where
toJSON :: DraftCommitTxResponse tx -> Value
toJSON (DraftCommitTxResponse tx
tx) = tx -> Value
forall a. ToJSON a => a -> Value
toJSON tx
tx
instance IsTx tx => FromJSON (DraftCommitTxResponse tx) where
parseJSON :: Value -> Parser (DraftCommitTxResponse tx)
parseJSON Value
v = tx -> DraftCommitTxResponse tx
forall tx. tx -> DraftCommitTxResponse tx
DraftCommitTxResponse (tx -> DraftCommitTxResponse tx)
-> Parser tx -> Parser (DraftCommitTxResponse tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser tx
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
instance Arbitrary tx => Arbitrary (DraftCommitTxResponse tx) where
arbitrary :: Gen (DraftCommitTxResponse tx)
arbitrary = Gen (DraftCommitTxResponse tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
shrink :: DraftCommitTxResponse tx -> [DraftCommitTxResponse tx]
shrink = \case
DraftCommitTxResponse tx
xs -> tx -> DraftCommitTxResponse tx
forall tx. tx -> DraftCommitTxResponse tx
DraftCommitTxResponse (tx -> DraftCommitTxResponse tx)
-> [tx] -> [DraftCommitTxResponse tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> tx -> [tx]
forall a. Arbitrary a => a -> [a]
shrink tx
xs
data DraftCommitTxRequest tx
= SimpleCommitRequest
{ forall tx. DraftCommitTxRequest tx -> UTxOType tx
utxoToCommit :: UTxOType tx
}
| FullCommitRequest
{ forall tx. DraftCommitTxRequest tx -> tx
blueprintTx :: tx
, forall tx. DraftCommitTxRequest tx -> UTxOType tx
utxo :: UTxOType tx
}
deriving stock ((forall x.
DraftCommitTxRequest tx -> Rep (DraftCommitTxRequest tx) x)
-> (forall x.
Rep (DraftCommitTxRequest tx) x -> DraftCommitTxRequest tx)
-> Generic (DraftCommitTxRequest tx)
forall x.
Rep (DraftCommitTxRequest tx) x -> DraftCommitTxRequest tx
forall x.
DraftCommitTxRequest tx -> Rep (DraftCommitTxRequest tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x.
Rep (DraftCommitTxRequest tx) x -> DraftCommitTxRequest tx
forall tx x.
DraftCommitTxRequest tx -> Rep (DraftCommitTxRequest tx) x
$cfrom :: forall tx x.
DraftCommitTxRequest tx -> Rep (DraftCommitTxRequest tx) x
from :: forall x.
DraftCommitTxRequest tx -> Rep (DraftCommitTxRequest tx) x
$cto :: forall tx x.
Rep (DraftCommitTxRequest tx) x -> DraftCommitTxRequest tx
to :: forall x.
Rep (DraftCommitTxRequest tx) x -> DraftCommitTxRequest tx
Generic)
deriving stock instance (Eq tx, Eq (UTxOType tx)) => Eq (DraftCommitTxRequest tx)
deriving stock instance (Show tx, Show (UTxOType tx)) => Show (DraftCommitTxRequest tx)
instance (ToJSON tx, ToJSON (UTxOType tx)) => ToJSON (DraftCommitTxRequest tx) where
toJSON :: DraftCommitTxRequest tx -> Value
toJSON = \case
FullCommitRequest{tx
$sel:blueprintTx:SimpleCommitRequest :: forall tx. DraftCommitTxRequest tx -> tx
blueprintTx :: tx
blueprintTx, UTxOType tx
$sel:utxo:SimpleCommitRequest :: forall tx. DraftCommitTxRequest tx -> UTxOType tx
utxo :: UTxOType tx
utxo} ->
[Pair] -> Value
object
[ Key
"blueprintTx" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= tx -> Value
forall a. ToJSON a => a -> Value
toJSON tx
blueprintTx
, Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxOType tx -> Value
forall a. ToJSON a => a -> Value
toJSON UTxOType tx
utxo
]
SimpleCommitRequest{UTxOType tx
$sel:utxoToCommit:SimpleCommitRequest :: forall tx. DraftCommitTxRequest tx -> UTxOType tx
utxoToCommit :: UTxOType tx
utxoToCommit} ->
UTxOType tx -> Value
forall a. ToJSON a => a -> Value
toJSON UTxOType tx
utxoToCommit
instance (FromJSON tx, FromJSON (UTxOType tx)) => FromJSON (DraftCommitTxRequest tx) where
parseJSON :: Value -> Parser (DraftCommitTxRequest tx)
parseJSON Value
v = Value -> Parser (DraftCommitTxRequest tx)
fullVariant Value
v Parser (DraftCommitTxRequest tx)
-> Parser (DraftCommitTxRequest tx)
-> Parser (DraftCommitTxRequest tx)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser (DraftCommitTxRequest tx)
simpleVariant Value
v
where
fullVariant :: Value -> Parser (DraftCommitTxRequest tx)
fullVariant = String
-> (Object -> Parser (DraftCommitTxRequest tx))
-> Value
-> Parser (DraftCommitTxRequest tx)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"FullCommitRequest" ((Object -> Parser (DraftCommitTxRequest tx))
-> Value -> Parser (DraftCommitTxRequest tx))
-> (Object -> Parser (DraftCommitTxRequest tx))
-> Value
-> Parser (DraftCommitTxRequest tx)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
tx
blueprintTx :: tx <- Object
o Object -> Key -> Parser tx
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"blueprintTx"
UTxOType tx
utxo <- Object
o Object -> Key -> Parser (UTxOType tx)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"utxo"
DraftCommitTxRequest tx -> Parser (DraftCommitTxRequest tx)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FullCommitRequest{tx
$sel:blueprintTx:SimpleCommitRequest :: tx
blueprintTx :: tx
blueprintTx, UTxOType tx
$sel:utxo:SimpleCommitRequest :: UTxOType tx
utxo :: UTxOType tx
utxo}
simpleVariant :: Aeson.Value -> Parser (DraftCommitTxRequest tx)
simpleVariant :: Value -> Parser (DraftCommitTxRequest tx)
simpleVariant Value
val = UTxOType tx -> DraftCommitTxRequest tx
forall tx. UTxOType tx -> DraftCommitTxRequest tx
SimpleCommitRequest (UTxOType tx -> DraftCommitTxRequest tx)
-> Parser (UTxOType tx) -> Parser (DraftCommitTxRequest tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (UTxOType tx)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val
instance (Arbitrary tx, Arbitrary (UTxOType tx)) => Arbitrary (DraftCommitTxRequest tx) where
arbitrary :: Gen (DraftCommitTxRequest tx)
arbitrary = Gen (DraftCommitTxRequest tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
shrink :: DraftCommitTxRequest tx -> [DraftCommitTxRequest tx]
shrink = \case
SimpleCommitRequest UTxOType tx
u -> UTxOType tx -> DraftCommitTxRequest tx
forall tx. UTxOType tx -> DraftCommitTxRequest tx
SimpleCommitRequest (UTxOType tx -> DraftCommitTxRequest tx)
-> [UTxOType tx] -> [DraftCommitTxRequest tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxOType tx -> [UTxOType tx]
forall a. Arbitrary a => a -> [a]
shrink UTxOType tx
u
FullCommitRequest tx
a UTxOType tx
b -> tx -> UTxOType tx -> DraftCommitTxRequest tx
forall tx. tx -> UTxOType tx -> DraftCommitTxRequest tx
FullCommitRequest (tx -> UTxOType tx -> DraftCommitTxRequest tx)
-> [tx] -> [UTxOType tx -> DraftCommitTxRequest tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> tx -> [tx]
forall a. Arbitrary a => a -> [a]
shrink tx
a [UTxOType tx -> DraftCommitTxRequest tx]
-> [UTxOType tx] -> [DraftCommitTxRequest tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UTxOType tx -> [UTxOType tx]
forall a. Arbitrary a => a -> [a]
shrink UTxOType tx
b
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
newtype SideLoadSnapshotRequest tx = SideLoadSnapshotRequest
{ forall tx. SideLoadSnapshotRequest tx -> ConfirmedSnapshot tx
snapshot :: ConfirmedSnapshot tx
}
deriving newtype (SideLoadSnapshotRequest tx -> SideLoadSnapshotRequest tx -> Bool
(SideLoadSnapshotRequest tx -> SideLoadSnapshotRequest tx -> Bool)
-> (SideLoadSnapshotRequest tx
-> SideLoadSnapshotRequest tx -> Bool)
-> Eq (SideLoadSnapshotRequest tx)
forall tx.
IsTx tx =>
SideLoadSnapshotRequest tx -> SideLoadSnapshotRequest tx -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall tx.
IsTx tx =>
SideLoadSnapshotRequest tx -> SideLoadSnapshotRequest tx -> Bool
== :: SideLoadSnapshotRequest tx -> SideLoadSnapshotRequest tx -> Bool
$c/= :: forall tx.
IsTx tx =>
SideLoadSnapshotRequest tx -> SideLoadSnapshotRequest tx -> Bool
/= :: SideLoadSnapshotRequest tx -> SideLoadSnapshotRequest tx -> Bool
Eq, Int -> SideLoadSnapshotRequest tx -> ShowS
[SideLoadSnapshotRequest tx] -> ShowS
SideLoadSnapshotRequest tx -> String
(Int -> SideLoadSnapshotRequest tx -> ShowS)
-> (SideLoadSnapshotRequest tx -> String)
-> ([SideLoadSnapshotRequest tx] -> ShowS)
-> Show (SideLoadSnapshotRequest tx)
forall tx. IsTx tx => Int -> SideLoadSnapshotRequest tx -> ShowS
forall tx. IsTx tx => [SideLoadSnapshotRequest tx] -> ShowS
forall tx. IsTx tx => SideLoadSnapshotRequest tx -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall tx. IsTx tx => Int -> SideLoadSnapshotRequest tx -> ShowS
showsPrec :: Int -> SideLoadSnapshotRequest tx -> ShowS
$cshow :: forall tx. IsTx tx => SideLoadSnapshotRequest tx -> String
show :: SideLoadSnapshotRequest tx -> String
$cshowList :: forall tx. IsTx tx => [SideLoadSnapshotRequest tx] -> ShowS
showList :: [SideLoadSnapshotRequest tx] -> ShowS
Show, (forall x.
SideLoadSnapshotRequest tx -> Rep (SideLoadSnapshotRequest tx) x)
-> (forall x.
Rep (SideLoadSnapshotRequest tx) x -> SideLoadSnapshotRequest tx)
-> Generic (SideLoadSnapshotRequest tx)
forall x.
Rep (SideLoadSnapshotRequest tx) x -> SideLoadSnapshotRequest tx
forall x.
SideLoadSnapshotRequest tx -> Rep (SideLoadSnapshotRequest tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x.
Rep (SideLoadSnapshotRequest tx) x -> SideLoadSnapshotRequest tx
forall tx x.
SideLoadSnapshotRequest tx -> Rep (SideLoadSnapshotRequest tx) x
$cfrom :: forall tx x.
SideLoadSnapshotRequest tx -> Rep (SideLoadSnapshotRequest tx) x
from :: forall x.
SideLoadSnapshotRequest tx -> Rep (SideLoadSnapshotRequest tx) x
$cto :: forall tx x.
Rep (SideLoadSnapshotRequest tx) x -> SideLoadSnapshotRequest tx
to :: forall x.
Rep (SideLoadSnapshotRequest tx) x -> SideLoadSnapshotRequest tx
Generic)
deriving newtype ([SideLoadSnapshotRequest tx] -> Value
[SideLoadSnapshotRequest tx] -> Encoding
SideLoadSnapshotRequest tx -> Bool
SideLoadSnapshotRequest tx -> Value
SideLoadSnapshotRequest tx -> Encoding
(SideLoadSnapshotRequest tx -> Value)
-> (SideLoadSnapshotRequest tx -> Encoding)
-> ([SideLoadSnapshotRequest tx] -> Value)
-> ([SideLoadSnapshotRequest tx] -> Encoding)
-> (SideLoadSnapshotRequest tx -> Bool)
-> ToJSON (SideLoadSnapshotRequest tx)
forall tx. IsTx tx => [SideLoadSnapshotRequest tx] -> Value
forall tx. IsTx tx => [SideLoadSnapshotRequest tx] -> Encoding
forall tx. IsTx tx => SideLoadSnapshotRequest tx -> Bool
forall tx. IsTx tx => SideLoadSnapshotRequest tx -> Value
forall tx. IsTx tx => SideLoadSnapshotRequest tx -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: forall tx. IsTx tx => SideLoadSnapshotRequest tx -> Value
toJSON :: SideLoadSnapshotRequest tx -> Value
$ctoEncoding :: forall tx. IsTx tx => SideLoadSnapshotRequest tx -> Encoding
toEncoding :: SideLoadSnapshotRequest tx -> Encoding
$ctoJSONList :: forall tx. IsTx tx => [SideLoadSnapshotRequest tx] -> Value
toJSONList :: [SideLoadSnapshotRequest tx] -> Value
$ctoEncodingList :: forall tx. IsTx tx => [SideLoadSnapshotRequest tx] -> Encoding
toEncodingList :: [SideLoadSnapshotRequest tx] -> Encoding
$comitField :: forall tx. IsTx tx => SideLoadSnapshotRequest tx -> Bool
omitField :: SideLoadSnapshotRequest tx -> Bool
ToJSON, Maybe (SideLoadSnapshotRequest tx)
Value -> Parser [SideLoadSnapshotRequest tx]
Value -> Parser (SideLoadSnapshotRequest tx)
(Value -> Parser (SideLoadSnapshotRequest tx))
-> (Value -> Parser [SideLoadSnapshotRequest tx])
-> Maybe (SideLoadSnapshotRequest tx)
-> FromJSON (SideLoadSnapshotRequest tx)
forall tx. IsTx tx => Maybe (SideLoadSnapshotRequest tx)
forall tx. IsTx tx => Value -> Parser [SideLoadSnapshotRequest tx]
forall tx. IsTx tx => Value -> Parser (SideLoadSnapshotRequest tx)
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: forall tx. IsTx tx => Value -> Parser (SideLoadSnapshotRequest tx)
parseJSON :: Value -> Parser (SideLoadSnapshotRequest tx)
$cparseJSONList :: forall tx. IsTx tx => Value -> Parser [SideLoadSnapshotRequest tx]
parseJSONList :: Value -> Parser [SideLoadSnapshotRequest tx]
$comittedField :: forall tx. IsTx tx => Maybe (SideLoadSnapshotRequest tx)
omittedField :: Maybe (SideLoadSnapshotRequest tx)
FromJSON)
instance (Arbitrary tx, Arbitrary (UTxOType tx), IsTx tx) => Arbitrary (SideLoadSnapshotRequest tx) where
arbitrary :: Gen (SideLoadSnapshotRequest tx)
arbitrary = Gen (SideLoadSnapshotRequest tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
shrink :: SideLoadSnapshotRequest tx -> [SideLoadSnapshotRequest tx]
shrink = \case
SideLoadSnapshotRequest ConfirmedSnapshot tx
snapshot -> ConfirmedSnapshot tx -> SideLoadSnapshotRequest tx
forall tx. ConfirmedSnapshot tx -> SideLoadSnapshotRequest tx
SideLoadSnapshotRequest (ConfirmedSnapshot tx -> SideLoadSnapshotRequest tx)
-> [ConfirmedSnapshot tx] -> [SideLoadSnapshotRequest tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConfirmedSnapshot tx -> [ConfirmedSnapshot tx]
forall a. Arbitrary a => a -> [a]
shrink ConfirmedSnapshot tx
snapshot
newtype SubmitL2TxRequest tx = SubmitL2TxRequest
{ forall tx. SubmitL2TxRequest tx -> tx
submitL2Tx :: tx
}
deriving newtype (SubmitL2TxRequest tx -> SubmitL2TxRequest tx -> Bool
(SubmitL2TxRequest tx -> SubmitL2TxRequest tx -> Bool)
-> (SubmitL2TxRequest tx -> SubmitL2TxRequest tx -> Bool)
-> Eq (SubmitL2TxRequest tx)
forall tx.
Eq tx =>
SubmitL2TxRequest tx -> SubmitL2TxRequest tx -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall tx.
Eq tx =>
SubmitL2TxRequest tx -> SubmitL2TxRequest tx -> Bool
== :: SubmitL2TxRequest tx -> SubmitL2TxRequest tx -> Bool
$c/= :: forall tx.
Eq tx =>
SubmitL2TxRequest tx -> SubmitL2TxRequest tx -> Bool
/= :: SubmitL2TxRequest tx -> SubmitL2TxRequest tx -> Bool
Eq, Int -> SubmitL2TxRequest tx -> ShowS
[SubmitL2TxRequest tx] -> ShowS
SubmitL2TxRequest tx -> String
(Int -> SubmitL2TxRequest tx -> ShowS)
-> (SubmitL2TxRequest tx -> String)
-> ([SubmitL2TxRequest tx] -> ShowS)
-> Show (SubmitL2TxRequest tx)
forall tx. Show tx => Int -> SubmitL2TxRequest tx -> ShowS
forall tx. Show tx => [SubmitL2TxRequest tx] -> ShowS
forall tx. Show tx => SubmitL2TxRequest tx -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall tx. Show tx => Int -> SubmitL2TxRequest tx -> ShowS
showsPrec :: Int -> SubmitL2TxRequest tx -> ShowS
$cshow :: forall tx. Show tx => SubmitL2TxRequest tx -> String
show :: SubmitL2TxRequest tx -> String
$cshowList :: forall tx. Show tx => [SubmitL2TxRequest tx] -> ShowS
showList :: [SubmitL2TxRequest tx] -> ShowS
Show, Gen (SubmitL2TxRequest tx)
Gen (SubmitL2TxRequest tx)
-> (SubmitL2TxRequest tx -> [SubmitL2TxRequest tx])
-> Arbitrary (SubmitL2TxRequest tx)
SubmitL2TxRequest tx -> [SubmitL2TxRequest tx]
forall tx. Arbitrary tx => Gen (SubmitL2TxRequest tx)
forall tx.
Arbitrary tx =>
SubmitL2TxRequest tx -> [SubmitL2TxRequest tx]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: forall tx. Arbitrary tx => Gen (SubmitL2TxRequest tx)
arbitrary :: Gen (SubmitL2TxRequest tx)
$cshrink :: forall tx.
Arbitrary tx =>
SubmitL2TxRequest tx -> [SubmitL2TxRequest tx]
shrink :: SubmitL2TxRequest tx -> [SubmitL2TxRequest tx]
Arbitrary)
deriving newtype ([SubmitL2TxRequest tx] -> Value
[SubmitL2TxRequest tx] -> Encoding
SubmitL2TxRequest tx -> Bool
SubmitL2TxRequest tx -> Value
SubmitL2TxRequest tx -> Encoding
(SubmitL2TxRequest tx -> Value)
-> (SubmitL2TxRequest tx -> Encoding)
-> ([SubmitL2TxRequest tx] -> Value)
-> ([SubmitL2TxRequest tx] -> Encoding)
-> (SubmitL2TxRequest tx -> Bool)
-> ToJSON (SubmitL2TxRequest tx)
forall tx. ToJSON tx => [SubmitL2TxRequest tx] -> Value
forall tx. ToJSON tx => [SubmitL2TxRequest tx] -> Encoding
forall tx. ToJSON tx => SubmitL2TxRequest tx -> Bool
forall tx. ToJSON tx => SubmitL2TxRequest tx -> Value
forall tx. ToJSON tx => SubmitL2TxRequest tx -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: forall tx. ToJSON tx => SubmitL2TxRequest tx -> Value
toJSON :: SubmitL2TxRequest tx -> Value
$ctoEncoding :: forall tx. ToJSON tx => SubmitL2TxRequest tx -> Encoding
toEncoding :: SubmitL2TxRequest tx -> Encoding
$ctoJSONList :: forall tx. ToJSON tx => [SubmitL2TxRequest tx] -> Value
toJSONList :: [SubmitL2TxRequest tx] -> Value
$ctoEncodingList :: forall tx. ToJSON tx => [SubmitL2TxRequest tx] -> Encoding
toEncodingList :: [SubmitL2TxRequest tx] -> Encoding
$comitField :: forall tx. ToJSON tx => SubmitL2TxRequest tx -> Bool
omitField :: SubmitL2TxRequest tx -> Bool
ToJSON, Maybe (SubmitL2TxRequest tx)
Value -> Parser [SubmitL2TxRequest tx]
Value -> Parser (SubmitL2TxRequest tx)
(Value -> Parser (SubmitL2TxRequest tx))
-> (Value -> Parser [SubmitL2TxRequest tx])
-> Maybe (SubmitL2TxRequest tx)
-> FromJSON (SubmitL2TxRequest tx)
forall tx. FromJSON tx => Maybe (SubmitL2TxRequest tx)
forall tx. FromJSON tx => Value -> Parser [SubmitL2TxRequest tx]
forall tx. FromJSON tx => Value -> Parser (SubmitL2TxRequest tx)
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: forall tx. FromJSON tx => Value -> Parser (SubmitL2TxRequest tx)
parseJSON :: Value -> Parser (SubmitL2TxRequest tx)
$cparseJSONList :: forall tx. FromJSON tx => Value -> Parser [SubmitL2TxRequest tx]
parseJSONList :: Value -> Parser [SubmitL2TxRequest tx]
$comittedField :: forall tx. FromJSON tx => Maybe (SubmitL2TxRequest tx)
omittedField :: Maybe (SubmitL2TxRequest tx)
FromJSON)
data SubmitL2TxResponse
=
SubmitTxConfirmed Integer
|
SubmitTxInvalidResponse Text
|
SubmitTxSubmitted
deriving stock (SubmitL2TxResponse -> SubmitL2TxResponse -> Bool
(SubmitL2TxResponse -> SubmitL2TxResponse -> Bool)
-> (SubmitL2TxResponse -> SubmitL2TxResponse -> Bool)
-> Eq SubmitL2TxResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SubmitL2TxResponse -> SubmitL2TxResponse -> Bool
== :: SubmitL2TxResponse -> SubmitL2TxResponse -> Bool
$c/= :: SubmitL2TxResponse -> SubmitL2TxResponse -> Bool
/= :: SubmitL2TxResponse -> SubmitL2TxResponse -> Bool
Eq, Int -> SubmitL2TxResponse -> ShowS
[SubmitL2TxResponse] -> ShowS
SubmitL2TxResponse -> String
(Int -> SubmitL2TxResponse -> ShowS)
-> (SubmitL2TxResponse -> String)
-> ([SubmitL2TxResponse] -> ShowS)
-> Show SubmitL2TxResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SubmitL2TxResponse -> ShowS
showsPrec :: Int -> SubmitL2TxResponse -> ShowS
$cshow :: SubmitL2TxResponse -> String
show :: SubmitL2TxResponse -> String
$cshowList :: [SubmitL2TxResponse] -> ShowS
showList :: [SubmitL2TxResponse] -> ShowS
Show, (forall x. SubmitL2TxResponse -> Rep SubmitL2TxResponse x)
-> (forall x. Rep SubmitL2TxResponse x -> SubmitL2TxResponse)
-> Generic SubmitL2TxResponse
forall x. Rep SubmitL2TxResponse x -> SubmitL2TxResponse
forall x. SubmitL2TxResponse -> Rep SubmitL2TxResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SubmitL2TxResponse -> Rep SubmitL2TxResponse x
from :: forall x. SubmitL2TxResponse -> Rep SubmitL2TxResponse x
$cto :: forall x. Rep SubmitL2TxResponse x -> SubmitL2TxResponse
to :: forall x. Rep SubmitL2TxResponse x -> SubmitL2TxResponse
Generic)
instance ToJSON SubmitL2TxResponse where
toJSON :: SubmitL2TxResponse -> Value
toJSON = \case
SubmitTxConfirmed Integer
snapshotNumber ->
[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
"SubmitTxConfirmed"
, Key
"snapshotNumber" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Integer
snapshotNumber
]
SubmitTxInvalidResponse Text
validationError ->
[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
"SubmitTxInvalid"
, Key
"validationError" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
validationError
]
SubmitL2TxResponse
SubmitTxSubmitted -> [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
"SubmitTxSubmitted"]
instance FromJSON SubmitL2TxResponse where
parseJSON :: Value -> Parser SubmitL2TxResponse
parseJSON = String
-> (Object -> Parser SubmitL2TxResponse)
-> Value
-> Parser SubmitL2TxResponse
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"SubmitTxResponse" ((Object -> Parser SubmitL2TxResponse)
-> Value -> Parser SubmitL2TxResponse)
-> (Object -> Parser SubmitL2TxResponse)
-> Value
-> Parser SubmitL2TxResponse
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
"SubmitTxConfirmed" -> Integer -> SubmitL2TxResponse
SubmitTxConfirmed (Integer -> SubmitL2TxResponse)
-> Parser Integer -> Parser SubmitL2TxResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Integer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"snapshotNumber"
Text
"SubmitTxInvalid" -> Text -> SubmitL2TxResponse
SubmitTxInvalidResponse (Text -> SubmitL2TxResponse)
-> Parser Text -> Parser SubmitL2TxResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"validationError"
Text
"SubmitTxSubmitted" -> SubmitL2TxResponse -> Parser SubmitL2TxResponse
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubmitL2TxResponse
SubmitTxSubmitted
Text
_ -> String -> Parser SubmitL2TxResponse
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected tag to be SubmitTxConfirmed, SubmitTxInvalid, or SubmitTxSubmitted"
instance Arbitrary SubmitL2TxResponse where
arbitrary :: Gen SubmitL2TxResponse
arbitrary = Gen SubmitL2TxResponse
forall a.
(Generic a, GA UnsizedOpts (Rep a),
UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
jsonContent :: ResponseHeaders
jsonContent :: ResponseHeaders
jsonContent = [(HeaderName
hContentType, ByteString
"application/json")]
httpApp ::
forall tx.
IsChainState tx =>
Tracer IO APIServerLog ->
Chain tx IO ->
Environment ->
PParams LedgerEra ->
IO (HeadState tx) ->
IO CommitInfo ->
IO [TxIdType tx] ->
(ClientInput tx -> IO ()) ->
ApiTransactionTimeout ->
TChan (Either (TimedServerOutput tx) (ClientMessage tx)) ->
Application
httpApp :: forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (HeadState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp Tracer IO APIServerLog
tracer Chain tx IO
directChain Environment
env PParams LedgerEra
pparams IO (HeadState tx)
getHeadState IO CommitInfo
getCommitInfo IO [TxIdType tx]
getPendingDeposits ClientInput tx -> IO ()
putClientInput ApiTransactionTimeout
apiTransactionTimeout TChan (Either (TimedServerOutput tx) (ClientMessage tx))
responseChannel 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 = ByteString -> Method
Method (ByteString -> Method) -> ByteString -> Method
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
requestMethod Request
request
, $sel:path:APIServerStarted :: PathInfo
path = ByteString -> PathInfo
PathInfo (ByteString -> PathInfo) -> ByteString -> PathInfo
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rawPathInfo Request
request
}
case (Request -> ByteString
requestMethod Request
request, Request -> [Text]
pathInfo Request
request) of
(ByteString
"GET", [Text
"head"]) ->
IO (HeadState tx)
getHeadState IO (HeadState tx)
-> (HeadState tx -> 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 (Response -> IO ResponseReceived)
-> (HeadState tx -> Response)
-> HeadState tx
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeadState tx -> Response
forall a. ToJSON a => a -> Response
okJSON
(ByteString
"GET", [Text
"snapshot"]) -> do
HeadState tx
hs <- IO (HeadState tx)
getHeadState
case HeadState tx -> Maybe (ConfirmedSnapshot tx)
forall tx.
IsChainState tx =>
HeadState tx -> Maybe (ConfirmedSnapshot tx)
getConfirmedSnapshot HeadState tx
hs of
Just ConfirmedSnapshot tx
confirmedSnapshot -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ConfirmedSnapshot tx -> Response
forall a. ToJSON a => a -> Response
okJSON ConfirmedSnapshot tx
confirmedSnapshot
Maybe (ConfirmedSnapshot tx)
Nothing -> Response -> IO ResponseReceived
respond Response
notFound
(ByteString
"GET", [Text
"snapshot", Text
"utxo"]) -> do
HeadState tx
hs <- IO (HeadState tx)
getHeadState
case HeadState tx -> Maybe (UTxOType tx)
forall tx.
Monoid (UTxOType tx) =>
HeadState tx -> Maybe (UTxOType tx)
getSnapshotUtxo HeadState tx
hs of
Just UTxOType tx
utxo -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ UTxOType tx -> Response
forall a. ToJSON a => a -> Response
okJSON UTxOType tx
utxo
Maybe (UTxOType tx)
_ -> Response -> IO ResponseReceived
respond Response
notFound
(ByteString
"GET", [Text
"snapshot", Text
"last-seen"]) -> do
HeadState tx
hs <- IO (HeadState tx)
getHeadState
Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> (SeenSnapshot tx -> Response)
-> SeenSnapshot tx
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SeenSnapshot tx -> Response
forall a. ToJSON a => a -> Response
okJSON (SeenSnapshot tx -> IO ResponseReceived)
-> SeenSnapshot tx -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ HeadState tx -> SeenSnapshot tx
forall tx. HeadState tx -> SeenSnapshot tx
getSeenSnapshot HeadState tx
hs
(ByteString
"POST", [Text
"snapshot"]) ->
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
>>= (ClientInput tx -> IO ()) -> ByteString -> IO Response
forall tx.
IsChainState tx =>
(ClientInput tx -> IO ()) -> ByteString -> IO Response
handleSideLoadSnapshot ClientInput tx -> IO ()
putClientInput
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
(ByteString
"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
>>= Environment
-> PParams LedgerEra
-> Chain tx IO
-> IO CommitInfo
-> ByteString
-> IO Response
forall tx.
IsChainState tx =>
Environment
-> PParams LedgerEra
-> Chain tx IO
-> IO CommitInfo
-> ByteString
-> IO Response
handleDraftCommitUtxo Environment
env PParams LedgerEra
pparams Chain tx IO
directChain IO CommitInfo
getCommitInfo
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
(ByteString
"DELETE", [Text
"commits", Text
_]) ->
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
>>= (ClientInput tx -> IO ()) -> Text -> ByteString -> IO Response
forall tx.
IsChainState tx =>
(ClientInput tx -> IO ()) -> Text -> ByteString -> IO Response
handleRecoverCommitUtxo ClientInput tx -> IO ()
putClientInput (NonEmpty Text -> Text
forall (f :: * -> *) a. IsNonEmpty f a a "last" => f a -> a
last (NonEmpty Text -> Text)
-> ([Text] -> NonEmpty Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Item (NonEmpty Text)] -> NonEmpty Text
[Text] -> NonEmpty Text
forall l. IsList l => [Item l] -> l
fromList ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Request -> [Text]
pathInfo Request
request)
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
(ByteString
"GET", [Text
"commits"]) ->
IO [TxIdType tx]
getPendingDeposits IO [TxIdType tx]
-> ([TxIdType tx] -> 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 (Response -> IO ResponseReceived)
-> ([TxIdType tx] -> Response)
-> [TxIdType tx]
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 ResponseHeaders
jsonContent (ByteString -> Response)
-> ([TxIdType tx] -> ByteString) -> [TxIdType tx] -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxIdType tx] -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode
(ByteString
"POST", [Text
"decommit"]) ->
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
>>= (ClientInput tx -> IO ()) -> ByteString -> IO Response
forall tx.
FromJSON tx =>
(ClientInput tx -> IO ()) -> ByteString -> IO Response
handleDecommit ClientInput tx -> IO ()
putClientInput
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
(ByteString
"GET", [Text
"protocol-parameters"]) ->
Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> (PParams LedgerEra -> Response)
-> PParams LedgerEra
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 ResponseHeaders
jsonContent (ByteString -> Response)
-> (PParams ConwayEra -> ByteString)
-> PParams ConwayEra
-> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PParams ConwayEra -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (PParams LedgerEra -> IO ResponseReceived)
-> PParams LedgerEra -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ PParams LedgerEra
pparams
(ByteString
"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. FromJSON 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
(ByteString
"POST", [Text
"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
>>= (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> ByteString
-> IO Response
forall tx.
IsChainState tx =>
(ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> ByteString
-> IO Response
handleSubmitL2Tx ClientInput tx -> IO ()
putClientInput ApiTransactionTimeout
apiTransactionTimeout TChan (Either (TimedServerOutput tx) (ClientMessage tx))
responseChannel
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
(ByteString, [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 ResponseHeaders
jsonContent (ByteString -> Response)
-> (Value -> ByteString) -> Value -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> Response) -> Value -> Response
forall a b. (a -> b) -> a -> b
$ Text -> Value
Aeson.String Text
"Resource not found"
handleDraftCommitUtxo ::
forall tx.
IsChainState tx =>
Environment ->
PParams LedgerEra ->
Chain tx IO ->
IO CommitInfo ->
LBS.ByteString ->
IO Response
handleDraftCommitUtxo :: forall tx.
IsChainState tx =>
Environment
-> PParams LedgerEra
-> Chain tx IO
-> IO CommitInfo
-> ByteString
-> IO Response
handleDraftCommitUtxo Environment
env PParams LedgerEra
pparams Chain tx IO
directChain IO CommitInfo
getCommitInfo ByteString
body = do
case ByteString -> Either String (DraftCommitTxRequest tx)
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode' ByteString
body :: Either String (DraftCommitTxRequest 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 ResponseHeaders
jsonContent (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 tx
someCommitRequest ->
IO CommitInfo
getCommitInfo IO CommitInfo -> (CommitInfo -> 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
NormalCommit HeadId
headId ->
case DraftCommitTxRequest tx
someCommitRequest of
FullCommitRequest{tx
$sel:blueprintTx:SimpleCommitRequest :: forall tx. DraftCommitTxRequest tx -> tx
blueprintTx :: tx
blueprintTx, UTxOType tx
$sel:utxo:SimpleCommitRequest :: forall tx. DraftCommitTxRequest tx -> UTxOType tx
utxo :: UTxOType tx
utxo} -> do
HeadId -> UTxOType tx -> tx -> IO Response
draftCommit HeadId
headId UTxOType tx
utxo tx
blueprintTx
SimpleCommitRequest{UTxOType tx
$sel:utxoToCommit:SimpleCommitRequest :: forall tx. DraftCommitTxRequest tx -> UTxOType tx
utxoToCommit :: UTxOType tx
utxoToCommit} -> do
let blueprintTx :: tx
blueprintTx = UTxOType tx -> tx
forall tx. IsTx tx => UTxOType tx -> tx
txSpendingUTxO UTxOType tx
utxoToCommit
HeadId -> UTxOType tx -> tx -> IO Response
draftCommit HeadId
headId UTxOType tx
utxoToCommit tx
blueprintTx
IncrementalCommit HeadId
headId -> do
case DraftCommitTxRequest tx
someCommitRequest of
FullCommitRequest{tx
$sel:blueprintTx:SimpleCommitRequest :: forall tx. DraftCommitTxRequest tx -> tx
blueprintTx :: tx
blueprintTx, UTxOType tx
$sel:utxo:SimpleCommitRequest :: forall tx. DraftCommitTxRequest tx -> UTxOType tx
utxo :: UTxOType tx
utxo} -> do
HeadId -> CommitBlueprintTx tx -> IO Response
deposit HeadId
headId CommitBlueprintTx{tx
blueprintTx :: tx
$sel:blueprintTx:CommitBlueprintTx :: tx
blueprintTx, $sel:lookupUTxO:CommitBlueprintTx :: UTxOType tx
lookupUTxO = UTxOType tx
utxo}
SimpleCommitRequest{UTxOType tx
$sel:utxoToCommit:SimpleCommitRequest :: forall tx. DraftCommitTxRequest tx -> UTxOType tx
utxoToCommit :: UTxOType tx
utxoToCommit} ->
HeadId -> CommitBlueprintTx tx -> IO Response
deposit HeadId
headId CommitBlueprintTx{$sel:blueprintTx:CommitBlueprintTx :: tx
blueprintTx = UTxOType tx -> tx
forall tx. IsTx tx => UTxOType tx -> tx
txSpendingUTxO UTxOType tx
utxoToCommit, $sel:lookupUTxO:CommitBlueprintTx :: UTxOType tx
lookupUTxO = UTxOType tx
utxoToCommit}
CommitInfo
CannotCommit -> 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
forall tx. PostTxError tx
FailedToDraftTxNotInitializing :: PostTxError tx))
where
deposit :: HeadId -> CommitBlueprintTx tx -> IO Response
deposit HeadId
headId CommitBlueprintTx tx
commitBlueprint = do
UTCTime
deadline <- NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime
3 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* DepositPeriod -> NominalDiffTime
toNominalDiffTime DepositPeriod
depositPeriod) (UTCTime -> UTCTime) -> IO UTCTime -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
MonadThrow IO =>
HeadId
-> PParams LedgerEra
-> CommitBlueprintTx tx
-> UTCTime
-> IO (Either (PostTxError tx) tx)
HeadId
-> PParams LedgerEra
-> CommitBlueprintTx tx
-> UTCTime
-> IO (Either (PostTxError tx) tx)
draftDepositTx HeadId
headId PParams LedgerEra
pparams CommitBlueprintTx tx
commitBlueprint UTCTime
deadline 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 -> Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status400 ResponseHeaders
jsonContent (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
depositTx -> DraftCommitTxResponse tx -> Response
forall a. ToJSON a => a -> Response
okJSON (DraftCommitTxResponse tx -> Response)
-> DraftCommitTxResponse tx -> Response
forall a b. (a -> b) -> a -> b
$ tx -> DraftCommitTxResponse tx
forall tx. tx -> DraftCommitTxResponse tx
DraftCommitTxResponse tx
depositTx
draftCommit :: HeadId -> UTxOType tx -> tx -> IO Response
draftCommit HeadId
headId UTxOType tx
lookupUTxO tx
blueprintTx = do
MonadThrow IO =>
HeadId -> CommitBlueprintTx tx -> IO (Either (PostTxError tx) tx)
HeadId -> CommitBlueprintTx tx -> IO (Either (PostTxError tx) tx)
draftCommitTx HeadId
headId CommitBlueprintTx{UTxOType tx
$sel:lookupUTxO:CommitBlueprintTx :: UTxOType tx
lookupUTxO :: UTxOType tx
lookupUTxO, tx
$sel:blueprintTx:CommitBlueprintTx :: tx
blueprintTx :: tx
blueprintTx} 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 ->
case PostTxError tx
e of
CommittedTooMuchADAForMainnet Coin
_ Coin
_ -> PostTxError tx -> Response
forall tx. IsChainState tx => PostTxError tx -> Response
badRequest PostTxError tx
e
UnsupportedLegacyOutput Address ByronAddr
_ -> PostTxError tx -> Response
forall tx. IsChainState tx => PostTxError tx -> Response
badRequest PostTxError tx
e
CannotFindOwnInitial UTxOType tx
_ -> PostTxError tx -> Response
forall tx. IsChainState tx => PostTxError tx -> Response
badRequest PostTxError tx
e
DepositTooLow Coin
_ Coin
_ -> PostTxError tx -> Response
forall tx. IsChainState tx => PostTxError tx -> Response
badRequest PostTxError tx
e
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 ->
DraftCommitTxResponse tx -> Response
forall a. ToJSON a => a -> Response
okJSON (DraftCommitTxResponse tx -> Response)
-> DraftCommitTxResponse tx -> Response
forall a b. (a -> b) -> a -> b
$ tx -> DraftCommitTxResponse tx
forall tx. tx -> DraftCommitTxResponse tx
DraftCommitTxResponse tx
commitTx
Chain{MonadThrow IO =>
HeadId -> CommitBlueprintTx tx -> IO (Either (PostTxError tx) tx)
$sel:draftCommitTx:Chain :: forall tx (m :: * -> *).
Chain tx m
-> MonadThrow m =>
HeadId -> CommitBlueprintTx tx -> m (Either (PostTxError tx) tx)
draftCommitTx :: MonadThrow IO =>
HeadId -> CommitBlueprintTx tx -> IO (Either (PostTxError tx) tx)
draftCommitTx, MonadThrow IO =>
HeadId
-> PParams LedgerEra
-> CommitBlueprintTx tx
-> UTCTime
-> IO (Either (PostTxError tx) tx)
draftDepositTx :: MonadThrow IO =>
HeadId
-> PParams LedgerEra
-> CommitBlueprintTx tx
-> UTCTime
-> IO (Either (PostTxError tx) tx)
$sel:draftDepositTx:Chain :: forall tx (m :: * -> *).
Chain tx m
-> MonadThrow m =>
HeadId
-> PParams LedgerEra
-> CommitBlueprintTx tx
-> UTCTime
-> m (Either (PostTxError tx) tx)
draftDepositTx} = Chain tx IO
directChain
Environment{DepositPeriod
depositPeriod :: DepositPeriod
$sel:depositPeriod:Environment :: Environment -> DepositPeriod
depositPeriod} = Environment
env
handleRecoverCommitUtxo ::
forall tx.
IsChainState tx =>
(ClientInput tx -> IO ()) ->
Text ->
LBS.ByteString ->
IO Response
handleRecoverCommitUtxo :: forall tx.
IsChainState tx =>
(ClientInput tx -> IO ()) -> Text -> ByteString -> IO Response
handleRecoverCommitUtxo ClientInput tx -> IO ()
putClientInput Text
recoverPath ByteString
_body = do
case Text -> Either Response (TxIdType tx)
parseTxIdFromPath Text
recoverPath of
Left Response
err -> Response -> IO Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
err
Right TxIdType tx
recoverTxId -> do
ClientInput tx -> IO ()
putClientInput Recover{TxIdType tx
recoverTxId :: TxIdType tx
$sel:recoverTxId:Init :: TxIdType tx
recoverTxId}
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
status200 ResponseHeaders
jsonContent (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
"OK")
where
parseTxIdFromPath :: Text -> Either Response (TxIdType tx)
parseTxIdFromPath Text
txIdStr =
case ByteString -> Either String (TxIdType tx)
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
txIdStr) :: Either String (TxIdType tx) of
Left String
e -> Response -> Either Response (TxIdType tx)
forall a b. a -> Either a b
Left (Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status400 ResponseHeaders
jsonContent (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
$ Text
"Cannot recover funds. Failed to parse TxId: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
e))
Right TxIdType tx
txid -> TxIdType tx -> Either Response (TxIdType tx)
forall a b. b -> Either a b
Right TxIdType tx
txid
handleSubmitUserTx ::
forall tx.
FromJSON tx =>
Chain tx IO ->
LBS.ByteString ->
IO Response
handleSubmitUserTx :: forall tx. FromJSON 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 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 ResponseHeaders
jsonContent (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 (tx -> IO ()
MonadThrow 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
badRequest PostTxError Tx
e
Right ()
_ ->
Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 ResponseHeaders
jsonContent (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
handleDecommit :: forall tx. FromJSON tx => (ClientInput tx -> IO ()) -> LBS.ByteString -> IO Response
handleDecommit :: forall tx.
FromJSON tx =>
(ClientInput tx -> IO ()) -> ByteString -> IO Response
handleDecommit ClientInput tx -> IO ()
putClientInput ByteString
body =
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 ResponseHeaders
jsonContent (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
decommitTx -> do
ClientInput tx -> IO ()
putClientInput Decommit{tx
decommitTx :: tx
$sel:decommitTx:Init :: tx
decommitTx}
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
status200 ResponseHeaders
jsonContent (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
"OK")
handleSideLoadSnapshot ::
forall tx.
IsChainState tx =>
(ClientInput tx -> IO ()) ->
LBS.ByteString ->
IO Response
handleSideLoadSnapshot :: forall tx.
IsChainState tx =>
(ClientInput tx -> IO ()) -> ByteString -> IO Response
handleSideLoadSnapshot ClientInput tx -> IO ()
putClientInput ByteString
body = do
case ByteString -> Either String (SideLoadSnapshotRequest tx)
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode' ByteString
body :: Either String (SideLoadSnapshotRequest 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 ResponseHeaders
jsonContent (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 SideLoadSnapshotRequest{ConfirmedSnapshot tx
$sel:snapshot:SideLoadSnapshotRequest :: forall tx. SideLoadSnapshotRequest tx -> ConfirmedSnapshot tx
snapshot :: ConfirmedSnapshot tx
snapshot} -> do
ClientInput tx -> IO ()
putClientInput (ClientInput tx -> IO ()) -> ClientInput tx -> IO ()
forall a b. (a -> b) -> a -> b
$ ConfirmedSnapshot tx -> ClientInput tx
forall tx. ConfirmedSnapshot tx -> ClientInput tx
SideLoadSnapshot ConfirmedSnapshot tx
snapshot
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
status200 ResponseHeaders
jsonContent (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
"OK")
handleSubmitL2Tx ::
forall tx.
IsChainState tx =>
(ClientInput tx -> IO ()) ->
ApiTransactionTimeout ->
TChan (Either (TimedServerOutput tx) (ClientMessage tx)) ->
LBS.ByteString ->
IO Response
handleSubmitL2Tx :: forall tx.
IsChainState tx =>
(ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> ByteString
-> IO Response
handleSubmitL2Tx ClientInput tx -> IO ()
putClientInput ApiTransactionTimeout
apiTransactionTimeout TChan (Either (TimedServerOutput tx) (ClientMessage tx))
responseChannel ByteString
body = do
case forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode' @(SubmitL2TxRequest tx) ByteString
body 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 ResponseHeaders
jsonContent (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 SubmitL2TxRequest{tx
$sel:submitL2Tx:SubmitL2TxRequest :: forall tx. SubmitL2TxRequest tx -> tx
submitL2Tx :: tx
submitL2Tx} -> do
TChan (Either (TimedServerOutput tx) (ClientMessage tx))
dupChannel <- STM IO (TChan (Either (TimedServerOutput tx) (ClientMessage tx)))
-> IO (TChan (Either (TimedServerOutput tx) (ClientMessage tx)))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (TChan (Either (TimedServerOutput tx) (ClientMessage tx)))
-> IO (TChan (Either (TimedServerOutput tx) (ClientMessage tx))))
-> STM
IO (TChan (Either (TimedServerOutput tx) (ClientMessage tx)))
-> IO (TChan (Either (TimedServerOutput tx) (ClientMessage tx)))
forall a b. (a -> b) -> a -> b
$ TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> STM (TChan (Either (TimedServerOutput tx) (ClientMessage tx)))
forall a. TChan a -> STM (TChan a)
dupTChan TChan (Either (TimedServerOutput tx) (ClientMessage tx))
responseChannel
ClientInput tx -> IO ()
putClientInput (tx -> ClientInput tx
forall tx. tx -> ClientInput tx
NewTx tx
submitL2Tx)
let txid :: TxIdType tx
txid = tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId tx
submitL2Tx
Maybe SubmitL2TxResponse
result <-
DiffTime -> IO SubmitL2TxResponse -> IO (Maybe SubmitL2TxResponse)
forall a. DiffTime -> IO a -> IO (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout
(NominalDiffTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (ApiTransactionTimeout -> NominalDiffTime
apiTransactionTimeoutNominalDiffTime ApiTransactionTimeout
apiTransactionTimeout))
(TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> TxIdType tx -> IO SubmitL2TxResponse
waitForTransactionResult TChan (Either (TimedServerOutput tx) (ClientMessage tx))
dupChannel TxIdType tx
txid)
case Maybe SubmitL2TxResponse
result of
Just (SubmitTxConfirmed Integer
snapshotNumber) ->
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
status200 ResponseHeaders
jsonContent (SubmitL2TxResponse -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (SubmitL2TxResponse -> ByteString)
-> SubmitL2TxResponse -> ByteString
forall a b. (a -> b) -> a -> b
$ Integer -> SubmitL2TxResponse
SubmitTxConfirmed Integer
snapshotNumber)
Just (SubmitTxInvalidResponse Text
validationError) ->
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 ResponseHeaders
jsonContent (SubmitL2TxResponse -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (SubmitL2TxResponse -> ByteString)
-> SubmitL2TxResponse -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> SubmitL2TxResponse
SubmitTxInvalidResponse Text
validationError)
Just SubmitL2TxResponse
SubmitTxSubmitted ->
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
status202 ResponseHeaders
jsonContent (SubmitL2TxResponse -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode SubmitL2TxResponse
SubmitTxSubmitted)
Maybe SubmitL2TxResponse
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
status202
ResponseHeaders
jsonContent
( Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$
[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
"SubmitTxSubmitted"
, Key
"timeout" 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
"Transaction submission timed out after " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (ApiTransactionTimeout -> String
forall b a. (Show a, IsString b) => a -> b
show ApiTransactionTimeout
apiTransactionTimeout) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" seconds")
]
)
where
waitForTransactionResult :: TChan (Either (TimedServerOutput tx) (ClientMessage tx)) -> TxIdType tx -> IO SubmitL2TxResponse
waitForTransactionResult :: TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> TxIdType tx -> IO SubmitL2TxResponse
waitForTransactionResult TChan (Either (TimedServerOutput tx) (ClientMessage tx))
dupChannel TxIdType tx
txid = IO SubmitL2TxResponse
go
where
go :: IO SubmitL2TxResponse
go = do
Either (TimedServerOutput tx) (ClientMessage tx)
event <- STM IO (Either (TimedServerOutput tx) (ClientMessage tx))
-> IO (Either (TimedServerOutput tx) (ClientMessage tx))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (Either (TimedServerOutput tx) (ClientMessage tx))
-> IO (Either (TimedServerOutput tx) (ClientMessage tx)))
-> STM IO (Either (TimedServerOutput tx) (ClientMessage tx))
-> IO (Either (TimedServerOutput tx) (ClientMessage tx))
forall a b. (a -> b) -> a -> b
$ TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> STM (Either (TimedServerOutput tx) (ClientMessage tx))
forall a. TChan a -> STM a
readTChan TChan (Either (TimedServerOutput tx) (ClientMessage tx))
dupChannel
case Either (TimedServerOutput tx) (ClientMessage tx)
event of
Left (TimedServerOutput{ServerOutput tx
output :: ServerOutput tx
$sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output}) -> case ServerOutput tx
output of
TxValid{TxIdType tx
transactionId :: TxIdType tx
$sel:transactionId:NetworkConnected :: forall tx. ServerOutput tx -> TxIdType tx
transactionId}
| TxIdType tx
transactionId TxIdType tx -> TxIdType tx -> Bool
forall a. Eq a => a -> a -> Bool
== TxIdType tx
txid ->
SubmitL2TxResponse -> IO SubmitL2TxResponse
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubmitL2TxResponse
SubmitTxSubmitted
TxInvalid{tx
transaction :: tx
$sel:transaction:NetworkConnected :: forall tx. ServerOutput tx -> tx
transaction, $sel:validationError:NetworkConnected :: forall tx. ServerOutput tx -> ValidationError
validationError = ValidationError Text
reason}
| tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId tx
transaction TxIdType tx -> TxIdType tx -> Bool
forall a. Eq a => a -> a -> Bool
== TxIdType tx
txid ->
SubmitL2TxResponse -> IO SubmitL2TxResponse
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SubmitL2TxResponse -> IO SubmitL2TxResponse)
-> SubmitL2TxResponse -> IO SubmitL2TxResponse
forall a b. (a -> b) -> a -> b
$ Text -> SubmitL2TxResponse
SubmitTxInvalidResponse Text
reason
SnapshotConfirmed{Snapshot tx
snapshot :: Snapshot tx
$sel:snapshot:NetworkConnected :: forall tx. ServerOutput tx -> Snapshot tx
snapshot} ->
if TxIdType tx
txid TxIdType tx -> [TxIdType tx] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` (tx -> TxIdType tx) -> [tx] -> [TxIdType tx]
forall a b. (a -> b) -> [a] -> [b]
map tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId (Snapshot tx -> [tx]
forall tx. Snapshot tx -> [tx]
confirmed Snapshot tx
snapshot)
then SubmitL2TxResponse -> IO SubmitL2TxResponse
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SubmitL2TxResponse -> IO SubmitL2TxResponse)
-> SubmitL2TxResponse -> IO SubmitL2TxResponse
forall a b. (a -> b) -> a -> b
$ Integer -> SubmitL2TxResponse
SubmitTxConfirmed (SnapshotNumber -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SnapshotNumber -> Integer) -> SnapshotNumber -> Integer
forall a b. (a -> b) -> a -> b
$ Snapshot tx -> SnapshotNumber
forall tx. Snapshot tx -> SnapshotNumber
number Snapshot tx
snapshot)
else IO SubmitL2TxResponse
go
ServerOutput tx
_ -> IO SubmitL2TxResponse
go
Right ClientMessage tx
_ -> IO SubmitL2TxResponse
go
badRequest :: IsChainState tx => PostTxError tx -> Response
badRequest :: forall tx. IsChainState tx => PostTxError tx -> Response
badRequest = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status400 ResponseHeaders
jsonContent (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
notFound :: Response
notFound :: Response
notFound = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status404 ResponseHeaders
jsonContent (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
"")
okJSON :: ToJSON a => a -> Response
okJSON :: forall a. ToJSON a => a -> Response
okJSON = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 ResponseHeaders
jsonContent (ByteString -> Response) -> (a -> ByteString) -> a -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode