{-# LANGUAGE UndecidableInstances #-}

module Hydra.API.HTTPServer where

import Hydra.Prelude

import Cardano.Ledger.Core (PParams)
import Data.Aeson (KeyValue ((.=)), object, withObject, (.:))
import Data.Aeson qualified as Aeson
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.Cardano.Api (
  LedgerEra,
  Tx,
 )
import Hydra.Chain (Chain (..), PostTxError (..), draftCommitTx)
import Hydra.Chain.ChainState (IsChainState)
import Hydra.Chain.Direct.State ()
import Hydra.Logging (Tracer, traceWith)
import Hydra.Tx (CommitBlueprintTx (..), HeadId, IsTx (..))
import Network.HTTP.Types (status200, 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)
forall {tx}.
FromJSON (UTxOType tx) =>
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 :: 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

-- | Hydra HTTP server
httpApp ::
  forall tx.
  IsChainState tx =>
  Tracer IO APIServerLog ->
  Chain tx IO ->
  PParams LedgerEra ->
  -- | A means to get the 'HeadId' if initializing the Head.
  IO (Maybe HeadId) ->
  -- | Get latest confirmed UTxO snapshot.
  IO (Maybe (UTxOType tx)) ->
  -- | Callback to yield a 'ClientInput' to the main event loop.
  (ClientInput tx -> IO ()) ->
  Application
httpApp :: forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> PParams LedgerEra
-> IO (Maybe HeadId)
-> IO (Maybe (UTxOType tx))
-> (ClientInput tx -> IO ())
-> Application
httpApp Tracer IO APIServerLog
tracer Chain tx IO
directChain PParams LedgerEra
pparams IO (Maybe HeadId)
getInitializingHeadId IO (Maybe (UTxOType tx))
getConfirmedUTxO ClientInput tx -> IO ()
putClientInput 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
"GET", [Text
"snapshot", Text
"utxo"]) ->
      -- XXX: Should ensure the UTxO is of the right head and the head is still
      -- open. This is something we should fix on the "read model" side of the
      -- server.
      IO (Maybe (UTxOType tx))
getConfirmedUTxO IO (Maybe (UTxOType tx))
-> (Maybe (UTxOType 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
>>= \case
        Maybe (UTxOType tx)
Nothing -> Response -> IO ResponseReceived
respond Response
notFound
        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
    (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 -> IO (Maybe HeadId) -> ByteString -> IO Response
forall tx.
IsChainState tx =>
Chain tx IO -> IO (Maybe HeadId) -> ByteString -> IO Response
handleDraftCommitUtxo Chain tx IO
directChain 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
"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
    (Method
"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 [] (ByteString -> Response)
-> (PParams StandardConway -> ByteString)
-> PParams StandardConway
-> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PParams StandardConway -> 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
    (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. 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
    (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.
handleDraftCommitUtxo ::
  forall tx.
  IsChainState tx =>
  Chain tx IO ->
  -- | A means to get the 'HeadId' if initializing the Head.
  IO (Maybe HeadId) ->
  -- | Request body.
  LBS.ByteString ->
  IO Response
handleDraftCommitUtxo :: forall tx.
IsChainState tx =>
Chain tx IO -> IO (Maybe HeadId) -> ByteString -> IO Response
handleDraftCommitUtxo Chain tx IO
directChain IO (Maybe HeadId)
getInitializingHeadId ByteString
body = do
  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
      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 [] (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 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
        Right 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
    -- 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
forall tx. PostTxError tx
FailedToDraftTxNotInitializing :: PostTxError tx))
 where
  draftCommit :: HeadId -> UTxOType tx -> tx -> IO Response
draftCommit HeadId
headId UTxOType tx
lookupUTxO tx
blueprintTx =
    MonadThrow IO =>
HeadId -> CommitBlueprintTx tx -> IO (Either (PostTxError tx) tx)
HeadId -> CommitBlueprintTx tx -> IO (Either (PostTxError tx) tx)
draftCommitTx HeadId
headId CommitBlueprintTx{UTxOType tx
lookupUTxO :: UTxOType tx
$sel:lookupUTxO:CommitBlueprintTx :: UTxOType tx
lookupUTxO, tx
blueprintTx :: tx
$sel:blueprintTx:CommitBlueprintTx :: 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 ->
        -- Distinguish between errors users can actually benefit from and
        -- other errors that are turned into 500 responses.
        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
          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} = Chain tx IO
directChain

-- | Handle request to submit a cardano transaction.
handleSubmitUserTx ::
  forall tx.
  FromJSON tx =>
  Chain tx IO ->
  -- | Request body.
  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 [] (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 [] (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 [] (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 [] (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")

badRequest :: IsChainState tx => PostTxError tx -> Response
badRequest :: forall tx. IsChainState tx => PostTxError tx -> Response
badRequest = 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

notFound :: Response
notFound :: Response
notFound = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status404 [] ByteString
""

okJSON :: ToJSON a => a -> Response
okJSON :: forall a. ToJSON a => a -> Response
okJSON = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 [] (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