{-# LANGUAGE OverloadedStrings #-}

module DMQ.NodeToClient.LocalMsgSubmission where

import Control.Concurrent.Class.MonadSTM
import Control.Tracer
import Data.Aeson (ToJSON (..), object, (.=))
import Data.Aeson qualified as Aeson
import Data.Maybe

import Ouroboros.Network.TxSubmission.Inbound.V2

import DMQ.Protocol.LocalMsgSubmission.Server
import DMQ.Protocol.LocalMsgSubmission.Type

-- | Local transaction submission server, for adding txs to the 'Mempool'
--
localMsgSubmissionServer ::
     MonadSTM m
  => (msg -> msgid)
  -- ^ get message id
  -> Tracer m (TraceLocalMsgSubmission msgid)
  -> TxSubmissionMempoolWriter msgid msg idx m
  -> m (LocalMsgSubmissionServer msg m ())
localMsgSubmissionServer :: forall (m :: * -> *) msg msgid idx.
MonadSTM m =>
(msg -> msgid)
-> Tracer m (TraceLocalMsgSubmission msgid)
-> TxSubmissionMempoolWriter msgid msg idx m
-> m (LocalMsgSubmissionServer msg m ())
localMsgSubmissionServer msg -> msgid
getMsgId Tracer m (TraceLocalMsgSubmission msgid)
tracer TxSubmissionMempoolWriter { [msg] -> m [msgid]
mempoolAddTxs :: [msg] -> m [msgid]
mempoolAddTxs :: forall txid tx idx (m :: * -> *).
TxSubmissionMempoolWriter txid tx idx m -> [tx] -> m [txid]
mempoolAddTxs } =
    LocalMsgSubmissionServer msg m ()
-> m (LocalMsgSubmissionServer msg m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalMsgSubmissionServer msg m ()
server
  where
    failure :: m (SubmitResult SigMempoolFail, LocalMsgSubmissionServer msg m ())
failure =
      -- TODO remove dummy hardcode when mempool returns reason
      (SigMempoolFail -> SubmitResult SigMempoolFail
forall reason. reason -> SubmitResult reason
SubmitFail SigMempoolFail
SigExpired, LocalMsgSubmissionServer msg m ()
server) (SubmitResult SigMempoolFail, LocalMsgSubmissionServer msg m ())
-> m ()
-> m (SubmitResult SigMempoolFail,
      LocalMsgSubmissionServer msg m ())
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tracer m (TraceLocalMsgSubmission msgid)
-> TraceLocalMsgSubmission msgid -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalMsgSubmission msgid)
tracer (SigMempoolFail -> TraceLocalMsgSubmission msgid
forall msgid. SigMempoolFail -> TraceLocalMsgSubmission msgid
TraceSubmitFailure SigMempoolFail
SigExpired)
    success :: msgid
-> m (SubmitResult SigMempoolFail,
      LocalMsgSubmissionServer msg m ())
success msgid
msgid =
      (SubmitResult SigMempoolFail
forall reason. SubmitResult reason
SubmitSuccess, LocalMsgSubmissionServer msg m ()
server) (SubmitResult SigMempoolFail, LocalMsgSubmissionServer msg m ())
-> m ()
-> m (SubmitResult SigMempoolFail,
      LocalMsgSubmissionServer msg m ())
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tracer m (TraceLocalMsgSubmission msgid)
-> TraceLocalMsgSubmission msgid -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalMsgSubmission msgid)
tracer (msgid -> TraceLocalMsgSubmission msgid
forall msgid. msgid -> TraceLocalMsgSubmission msgid
TraceSubmitAccept msgid
msgid)

    server :: LocalMsgSubmissionServer msg m ()
server = LocalTxSubmissionServer {
      recvMsgSubmitTx :: msg
-> m (SubmitResult SigMempoolFail,
      LocalMsgSubmissionServer msg m ())
recvMsgSubmitTx = \msg
msg -> do
        Tracer m (TraceLocalMsgSubmission msgid)
-> TraceLocalMsgSubmission msgid -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalMsgSubmission msgid)
tracer (TraceLocalMsgSubmission msgid -> m ())
-> TraceLocalMsgSubmission msgid -> m ()
forall a b. (a -> b) -> a -> b
$ msgid -> TraceLocalMsgSubmission msgid
forall msgid. msgid -> TraceLocalMsgSubmission msgid
TraceReceivedMsg (msg -> msgid
getMsgId msg
msg)
        -- TODO mempool should return 'SubmitResult'
        m (SubmitResult SigMempoolFail, LocalMsgSubmissionServer msg m ())
-> (msgid
    -> m (SubmitResult SigMempoolFail,
          LocalMsgSubmissionServer msg m ()))
-> Maybe msgid
-> m (SubmitResult SigMempoolFail,
      LocalMsgSubmissionServer msg m ())
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m (SubmitResult SigMempoolFail, LocalMsgSubmissionServer msg m ())
failure msgid
-> m (SubmitResult SigMempoolFail,
      LocalMsgSubmissionServer msg m ())
success (Maybe msgid
 -> m (SubmitResult SigMempoolFail,
       LocalMsgSubmissionServer msg m ()))
-> ([msgid] -> Maybe msgid)
-> [msgid]
-> m (SubmitResult SigMempoolFail,
      LocalMsgSubmissionServer msg m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [msgid] -> Maybe msgid
forall a. [a] -> Maybe a
listToMaybe ([msgid]
 -> m (SubmitResult SigMempoolFail,
       LocalMsgSubmissionServer msg m ()))
-> m [msgid]
-> m (SubmitResult SigMempoolFail,
      LocalMsgSubmissionServer msg m ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [msg] -> m [msgid]
mempoolAddTxs [msg
msg]

    , recvMsgDone :: ()
recvMsgDone = ()
    }


data TraceLocalMsgSubmission msgid =
    TraceReceivedMsg msgid
  -- ^ A transaction was received.
  | TraceSubmitFailure SigMempoolFail
  | TraceSubmitAccept msgid
  deriving Int -> TraceLocalMsgSubmission msgid -> ShowS
[TraceLocalMsgSubmission msgid] -> ShowS
TraceLocalMsgSubmission msgid -> String
(Int -> TraceLocalMsgSubmission msgid -> ShowS)
-> (TraceLocalMsgSubmission msgid -> String)
-> ([TraceLocalMsgSubmission msgid] -> ShowS)
-> Show (TraceLocalMsgSubmission msgid)
forall msgid.
Show msgid =>
Int -> TraceLocalMsgSubmission msgid -> ShowS
forall msgid.
Show msgid =>
[TraceLocalMsgSubmission msgid] -> ShowS
forall msgid. Show msgid => TraceLocalMsgSubmission msgid -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall msgid.
Show msgid =>
Int -> TraceLocalMsgSubmission msgid -> ShowS
showsPrec :: Int -> TraceLocalMsgSubmission msgid -> ShowS
$cshow :: forall msgid. Show msgid => TraceLocalMsgSubmission msgid -> String
show :: TraceLocalMsgSubmission msgid -> String
$cshowList :: forall msgid.
Show msgid =>
[TraceLocalMsgSubmission msgid] -> ShowS
showList :: [TraceLocalMsgSubmission msgid] -> ShowS
Show

instance ToJSON msgid
      => ToJSON (TraceLocalMsgSubmission msgid) where
  toJSON :: TraceLocalMsgSubmission msgid -> Value
toJSON (TraceReceivedMsg msgid
msgid) =
    -- TODO: once we have verbosity levels, we could include the full tx, for
    -- now one can use `TraceSendRecv` tracer for the mini-protocol to see full
    -- msgs.
    [Pair] -> Value
object [ Key
"kind" 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
"TraceReceivedMsg"
           , Key
"sigId" Key -> msgid -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= msgid
msgid
           ]
  toJSON (TraceSubmitFailure SigMempoolFail
reject) =
    [Pair] -> Value
object [ Key
"kind" 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
"TraceSubmitFailure"
           , Key
"reason" Key -> SigMempoolFail -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SigMempoolFail
reject
           ]
  toJSON (TraceSubmitAccept msgid
msgid) =
    [Pair] -> Value
object [ Key
"kind" 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
"TraceSubmitAccept"
           , Key
"sigId" Key -> msgid -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= msgid
msgid
           ]