diff --git a/server/ogmios.cabal b/server/ogmios.cabal index 4297dc6fff..1413d171aa 100644 --- a/server/ogmios.cabal +++ b/server/ogmios.cabal @@ -68,6 +68,7 @@ library Ogmios.Data.Protocol Ogmios.Data.Protocol.ChainSync Ogmios.Data.Protocol.StateQuery + Ogmios.Data.Protocol.TxMonitor Ogmios.Data.Protocol.TxSubmission Ogmios.Options Ogmios.Prelude diff --git a/server/src/Ogmios/Data/Protocol/TxMonitor.hs b/server/src/Ogmios/Data/Protocol/TxMonitor.hs new file mode 100644 index 0000000000..eae26819ca --- /dev/null +++ b/server/src/Ogmios/Data/Protocol/TxMonitor.hs @@ -0,0 +1,355 @@ +-- This Source Code Form is subject to the terms of the Mozilla Public +-- License, v. 2.0. If a copy of the MPL was not distributed with this +-- file, You can obtain one at http://mozilla.org/MPL/2.0/. + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +-- NOTE: +-- This module uses partial record field accessor to automatically derive +-- JSON instances from the generic data-type structure. The partial fields are +-- otherwise unused. +{-# OPTIONS_GHC -fno-warn-partial-fields #-} +{-# OPTIONS_GHC -fno-warn-unused-foralls #-} + +module Ogmios.Data.Protocol.TxMonitor + ( -- * Codecs + TxMonitorCodecs (..) + , mkTxMonitorCodecs + + -- * Messages + , TxMonitorMessage (..) + + -- ** Acquire / AwaitAcquire + , AwaitAcquire (..) + , _encodeAwaitAcquire + , _decodeAwaitAcquire + , AwaitAcquireResponse (..) + , _encodeAwaitAcquireResponse + + -- ** NextTx + , NextTx (..) + , _encodeNextTx + , _decodeNextTx + , NextTxResponse (..) + , _encodeNextTxResponse + + -- ** HasTx + , HasTx (..) + , _encodeHasTx + , _decodeHasTx + , HasTxResponse (..) + , _encodeHasTxResponse + + + -- ** GetSizes + , GetSizes (..) + , _encodeGetSizes + , _decodeGetSizes + , GetSizesResponse (..) + , _encodeGetSizesResponse + + -- ** Releases + , Release (..) + , _encodeRelease + , _decodeRelease + , ReleaseResponse (..) + , _encodeReleaseResponse + + -- * Re-exports + , GenTx + , GenTxId + , MempoolSizeAndCapacity (..) + , SlotNo (..) + ) where + +import Ogmios.Data.Json.Prelude hiding + ( id ) + +import Ogmios.Data.Protocol + () + +import Cardano.Network.Protocol.NodeToClient + ( GenTx, GenTxId ) +import Cardano.Slotting.Slot + ( SlotNo (..) ) +import Ouroboros.Network.Protocol.LocalTxMonitor.Type + ( MempoolSizeAndCapacity (..) ) + +import qualified Codec.Json.Wsp as Wsp +import qualified Data.Aeson.Types as Json + +-- +-- Codecs +-- + +data TxMonitorCodecs block = TxMonitorCodecs + { decodeAwaitAcquire + :: ByteString + -> Maybe (Wsp.Request AwaitAcquire) + , encodeAwaitAcquireResponse + :: Wsp.Response AwaitAcquireResponse + -> Json + , decodeNextTx + :: ByteString + -> Maybe (Wsp.Request NextTx) + , encodeNextTxResponse + :: Wsp.Response (NextTxResponse block) + -> Json + , decodeHasTx + :: ByteString + -> Maybe (Wsp.Request (HasTx block)) + , encodeHasTxResponse + :: Wsp.Response HasTxResponse + -> Json + , decodeGetSizes + :: ByteString + -> Maybe (Wsp.Request GetSizes) + , encodeGetSizesResponse + :: Wsp.Response GetSizesResponse + -> Json + , decodeRelease + :: ByteString + -> Maybe (Wsp.Request Release) + , encodeReleaseResponse + :: Wsp.Response ReleaseResponse + -> Json + } + +mkTxMonitorCodecs + :: (FromJSON (GenTxId block)) + => (GenTx block -> Json) + -> TxMonitorCodecs block +mkTxMonitorCodecs encodeTx = + TxMonitorCodecs + { decodeAwaitAcquire = decodeWith _decodeAwaitAcquire + , encodeAwaitAcquireResponse = _encodeAwaitAcquireResponse + , decodeNextTx = decodeWith _decodeNextTx + , encodeNextTxResponse = _encodeNextTxResponse encodeTx + , decodeHasTx = decodeWith _decodeHasTx + , encodeHasTxResponse = _encodeHasTxResponse + , decodeGetSizes = decodeWith _decodeGetSizes + , encodeGetSizesResponse = _encodeGetSizesResponse + , decodeRelease = decodeWith _decodeRelease + , encodeReleaseResponse = _encodeReleaseResponse + } + +-- +-- Messages +-- + +data TxMonitorMessage block + = MsgAwaitAcquire + AwaitAcquire + (Wsp.ToResponse AwaitAcquireResponse) + Wsp.ToFault + | MsgNextTx + NextTx + (Wsp.ToResponse (NextTxResponse block)) + Wsp.ToFault + | MsgHasTx + (HasTx block) + (Wsp.ToResponse HasTxResponse) + Wsp.ToFault + | MsgGetSizes + GetSizes + (Wsp.ToResponse GetSizesResponse) + Wsp.ToFault + | MsgRelease + Release + (Wsp.ToResponse ReleaseResponse) + Wsp.ToFault + +-- +-- AwaitAcquire +-- + +data AwaitAcquire + = AwaitAcquire + deriving (Generic, Show, Eq) + +_encodeAwaitAcquire + :: Wsp.Request AwaitAcquire + -> Json +_encodeAwaitAcquire = + Wsp.mkRequest Wsp.defaultOptions $ \case + AwaitAcquire -> encodeObject [] + +_decodeAwaitAcquire + :: Json.Value + -> Json.Parser (Wsp.Request AwaitAcquire) +_decodeAwaitAcquire = + Wsp.genericFromJSON Wsp.defaultOptions + +data AwaitAcquireResponse + = AwaitAcquired { slot :: SlotNo } + deriving (Generic, Show, Eq) + +_encodeAwaitAcquireResponse + :: Wsp.Response AwaitAcquireResponse + -> Json +_encodeAwaitAcquireResponse = + Wsp.mkResponse Wsp.defaultOptions proxy $ \case + AwaitAcquired{slot} -> encodeObject + [ ( "AwaitAcquired" + , encodeObject [ ( "slot", encodeSlotNo slot ) ] + ) + ] + where + proxy = Proxy @(Wsp.Request AwaitAcquire) + +-- +-- NextTx +-- + +data NextTx + = NextTx + deriving (Generic, Show, Eq) + +_encodeNextTx + :: Wsp.Request NextTx + -> Json +_encodeNextTx = + Wsp.mkRequest Wsp.defaultOptions $ \case + NextTx -> encodeObject + [ ( "NextTx", encodeObject [] ) + ] + +_decodeNextTx + :: Json.Value + -> Json.Parser (Wsp.Request NextTx) +_decodeNextTx = + Wsp.genericFromJSON Wsp.defaultOptions + +data NextTxResponse block + = NextTxResponse { next :: Maybe (GenTx block) } + deriving (Generic) +deriving instance Show (GenTx block) => Show (NextTxResponse block) +deriving instance Eq (GenTx block) => Eq (NextTxResponse block) + +_encodeNextTxResponse + :: forall block. () + => (GenTx block -> Json) + -> Wsp.Response (NextTxResponse block) + -> Json +_encodeNextTxResponse encodeTx = + Wsp.mkResponse Wsp.defaultOptions proxy $ \case + NextTxResponse{next} -> encodeMaybe encodeTx next + where + proxy = Proxy @(Wsp.Request NextTx) + +-- +-- HasTx +-- +data HasTx block + = HasTx { id :: GenTxId block } + deriving (Generic) +deriving instance Show (GenTxId block) => Show (HasTx block) +deriving instance Eq (GenTxId block) => Eq (HasTx block) + +_encodeHasTx + :: forall block. () + => (GenTxId block -> Json) + -> Wsp.Request (HasTx block) + -> Json +_encodeHasTx encodeTxId = + Wsp.mkRequest Wsp.defaultOptions $ \case + HasTx{id} -> encodeObject + [ ( "HasTx" + , encodeObject [ ( "id", encodeTxId id ) ] + ) + ] + +_decodeHasTx + :: forall block. (FromJSON (GenTxId block)) + => Json.Value + -> Json.Parser (Wsp.Request (HasTx block)) +_decodeHasTx = + Wsp.genericFromJSON Wsp.defaultOptions + +data HasTxResponse + = HasTxResponse { has :: Bool } + deriving (Generic, Show, Eq) + +_encodeHasTxResponse + :: forall block. () + => Wsp.Response HasTxResponse + -> Json +_encodeHasTxResponse = + Wsp.mkResponse Wsp.defaultOptions proxy $ \case + HasTxResponse{has} -> encodeBool has + where + proxy = Proxy @(Wsp.Request (HasTx block)) + +-- +-- GetSizes +-- + +data GetSizes + = GetSizes + deriving (Generic, Show, Eq) + +_encodeGetSizes + :: Wsp.Request GetSizes + -> Json +_encodeGetSizes = + Wsp.mkRequest Wsp.defaultOptions $ \case + GetSizes -> encodeObject [] + +_decodeGetSizes + :: Json.Value + -> Json.Parser (Wsp.Request GetSizes) +_decodeGetSizes = + Wsp.genericFromJSON Wsp.defaultOptions + +data GetSizesResponse + = GetSizesResponse { sizes :: MempoolSizeAndCapacity } + deriving (Generic, Show) + +_encodeGetSizesResponse + :: Wsp.Response GetSizesResponse + -> Json +_encodeGetSizesResponse = + Wsp.mkResponse Wsp.defaultOptions proxy $ \case + GetSizesResponse{sizes} -> encodeObject + [ ( "capacity", encodeWord32 (capacityInBytes sizes) ) + , ( "currentSize", encodeWord32 (sizeInBytes sizes) ) + , ( "numberOfTxs", encodeWord32 (numberOfTxs sizes) ) + ] + where + proxy = Proxy @(Wsp.Request GetSizes) + +-- +-- Release +-- + +data Release + = Release + deriving (Generic, Show, Eq) + +_encodeRelease + :: Wsp.Request Release + -> Json +_encodeRelease = + Wsp.mkRequest Wsp.defaultOptions $ \case + Release -> encodeObject [] + +_decodeRelease + :: Json.Value + -> Json.Parser (Wsp.Request Release) +_decodeRelease = + Wsp.genericFromJSON Wsp.defaultOptions + +data ReleaseResponse + = Released + deriving (Generic, Show) + +_encodeReleaseResponse + :: Wsp.Response ReleaseResponse + -> Json +_encodeReleaseResponse = + Wsp.mkResponse Wsp.defaultOptions proxy $ \case + Released -> encodeText "Released" + where + proxy = Proxy @(Wsp.Request Release)