{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Ouroboros.Consensus.Ledger.Query
(
Query (..)
, answerQuery
, BlockQuery
, BlockSupportsLedgerQuery (..)
, ConfigSupportsNode (..)
, ShowQuery (..)
, QueryVersion (..)
, nodeToClientVersionToQueryVersion
, queryDecodeNodeToClient
, queryEncodeNodeToClient
, queryIsSupportedOnNodeToClientVersion
, querySupportedVersions
, QueryFootprint (..)
, SQueryFootprint (..)
, SomeBlockQuery (..)
) where
import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import Cardano.Slotting.Block (BlockNo (..))
import Cardano.Slotting.Slot (WithOrigin (..))
import Codec.CBOR.Decoding
import Codec.CBOR.Encoding
import Codec.Serialise (Serialise)
import Codec.Serialise.Class (decode, encode)
import Control.Exception (throw)
import Data.Kind (Type)
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust)
import Data.SOP.BasicFunctors
import Data.Singletons
import Data.Typeable (Typeable)
import Ouroboros.Consensus.Block.Abstract (CodecConfig)
import Ouroboros.Consensus.BlockchainTime (SystemStart)
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Config.SupportsNode
import Ouroboros.Consensus.HeaderValidation
( HasAnnTip (..)
, headerStateBlockNo
, headerStatePoint
)
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.Query.Version
import Ouroboros.Consensus.Node.NetworkProtocolVersion
( BlockNodeToClientVersion
, NodeToClientVersion
, SupportedNetworkProtocolVersion (supportedNodeToClientVersions)
)
import Ouroboros.Consensus.Node.Serialisation
( SerialiseBlockQueryResult (..)
, SerialiseNodeToClient (..)
, SerialiseResult (..)
)
import Ouroboros.Consensus.Storage.LedgerDB
import Ouroboros.Consensus.Util (ShowProxy (..), SomeSecond (..))
import Ouroboros.Consensus.Util.DepPair
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Network.Block
( HeaderHash
, Point (..)
, StandardHash
, decodePoint
, encodePoint
)
import Ouroboros.Network.Protocol.LocalStateQuery.Type
data
=
QFNoTables
|
QFLookupTables
|
QFTraverseTables
type instance Sing = SQueryFootprint
type SQueryFootprint :: QueryFootprint -> Type
data a where
SQFNoTables :: SQueryFootprint QFNoTables
SQFLookupTables :: SQueryFootprint QFLookupTables
SQFTraverseTables :: SQueryFootprint QFTraverseTables
instance SingI QFNoTables where
sing :: Sing 'QFNoTables
sing = Sing 'QFNoTables
SQueryFootprint 'QFNoTables
SQFNoTables
instance SingI QFLookupTables where
sing :: Sing 'QFLookupTables
sing = Sing 'QFLookupTables
SQueryFootprint 'QFLookupTables
SQFLookupTables
instance SingI QFTraverseTables where
sing :: Sing 'QFTraverseTables
sing = Sing 'QFTraverseTables
SQueryFootprint 'QFTraverseTables
SQFTraverseTables
type SomeBlockQuery :: (QueryFootprint -> Type -> Type) -> Type
data SomeBlockQuery q
= forall footprint result. SingI footprint => SomeBlockQuery !(q footprint result)
type BlockQuery :: Type -> QueryFootprint -> Type -> Type
data family BlockQuery
class
( forall fp result. Show (BlockQuery blk fp result)
, forall fp. ShowQuery (BlockQuery blk fp)
, SameDepIndex2 (BlockQuery blk)
) =>
BlockSupportsLedgerQuery blk
where
answerPureBlockQuery ::
ExtLedgerCfg blk ->
BlockQuery blk QFNoTables result ->
ExtLedgerState blk EmptyMK ->
result
answerBlockQueryLookup ::
MonadSTM m =>
ExtLedgerCfg blk ->
BlockQuery blk QFLookupTables result ->
ReadOnlyForker' m blk ->
m result
answerBlockQueryTraverse ::
MonadSTM m =>
ExtLedgerCfg blk ->
BlockQuery blk QFTraverseTables result ->
ReadOnlyForker' m blk ->
m result
blockQueryIsSupportedOnVersion ::
BlockQuery blk fp result ->
BlockNodeToClientVersion blk ->
Bool
queryName :: Query blk result -> String
queryName :: forall blk result. Query blk result -> String
queryName Query blk result
query = case Query blk result
query of
BlockQuery BlockQuery blk footprint result
_ -> String
"BlockQuery"
Query blk result
GetSystemStart -> String
"GetSystemStart"
Query blk result
GetChainBlockNo -> String
"GetChainBlockNo"
Query blk result
GetChainPoint -> String
"GetChainPoint"
Query blk result
DebugLedgerConfig -> String
"DebugLedgerConfig"
type Query :: Type -> Type -> Type
data Query blk result where
BlockQuery ::
SingI footprint => BlockQuery blk footprint result -> Query blk result
GetSystemStart :: Query blk SystemStart
GetChainBlockNo :: Query blk (WithOrigin BlockNo)
GetChainPoint :: Query blk (Point blk)
DebugLedgerConfig :: Query blk (LedgerConfig blk)
answerQuery ::
forall blk m result.
(BlockSupportsLedgerQuery blk, ConfigSupportsNode blk, HasAnnTip blk, MonadSTM m) =>
ExtLedgerCfg blk ->
ReadOnlyForker' m blk ->
Query blk result ->
m result
answerQuery :: forall blk (m :: * -> *) result.
(BlockSupportsLedgerQuery blk, ConfigSupportsNode blk,
HasAnnTip blk, MonadSTM m) =>
ExtLedgerCfg blk
-> ReadOnlyForker' m blk -> Query blk result -> m result
answerQuery ExtLedgerCfg blk
config ReadOnlyForker' m blk
forker Query blk result
query = case Query blk result
query of
BlockQuery (BlockQuery blk footprint result
blockQuery :: BlockQuery blk footprint result) ->
case Sing footprint
forall {k} (a :: k). SingI a => Sing a
sing :: Sing footprint of
Sing footprint
SQueryFootprint footprint
SQFNoTables ->
ExtLedgerCfg blk
-> BlockQuery blk 'QFNoTables result
-> ExtLedgerState blk EmptyMK
-> result
forall result.
ExtLedgerCfg blk
-> BlockQuery blk 'QFNoTables result
-> ExtLedgerState blk EmptyMK
-> result
forall blk result.
BlockSupportsLedgerQuery blk =>
ExtLedgerCfg blk
-> BlockQuery blk 'QFNoTables result
-> ExtLedgerState blk EmptyMK
-> result
answerPureBlockQuery ExtLedgerCfg blk
config BlockQuery blk footprint result
BlockQuery blk 'QFNoTables result
blockQuery
(ExtLedgerState blk EmptyMK -> result)
-> m (ExtLedgerState blk EmptyMK) -> m result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (ExtLedgerState blk EmptyMK)
-> m (ExtLedgerState blk EmptyMK)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (ReadOnlyForker' m blk -> STM m (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk -> STM m (l EmptyMK)
roforkerGetLedgerState ReadOnlyForker' m blk
forker)
Sing footprint
SQueryFootprint footprint
SQFLookupTables ->
ExtLedgerCfg blk
-> BlockQuery blk 'QFLookupTables result
-> ReadOnlyForker' m blk
-> m result
forall blk (m :: * -> *) result.
(BlockSupportsLedgerQuery blk, MonadSTM m) =>
ExtLedgerCfg blk
-> BlockQuery blk 'QFLookupTables result
-> ReadOnlyForker' m blk
-> m result
forall (m :: * -> *) result.
MonadSTM m =>
ExtLedgerCfg blk
-> BlockQuery blk 'QFLookupTables result
-> ReadOnlyForker' m blk
-> m result
answerBlockQueryLookup ExtLedgerCfg blk
config BlockQuery blk footprint result
BlockQuery blk 'QFLookupTables result
blockQuery ReadOnlyForker' m blk
forker
Sing footprint
SQueryFootprint footprint
SQFTraverseTables ->
ExtLedgerCfg blk
-> BlockQuery blk 'QFTraverseTables result
-> ReadOnlyForker' m blk
-> m result
forall blk (m :: * -> *) result.
(BlockSupportsLedgerQuery blk, MonadSTM m) =>
ExtLedgerCfg blk
-> BlockQuery blk 'QFTraverseTables result
-> ReadOnlyForker' m blk
-> m result
forall (m :: * -> *) result.
MonadSTM m =>
ExtLedgerCfg blk
-> BlockQuery blk 'QFTraverseTables result
-> ReadOnlyForker' m blk
-> m result
answerBlockQueryTraverse ExtLedgerCfg blk
config BlockQuery blk footprint result
BlockQuery blk 'QFTraverseTables result
blockQuery ReadOnlyForker' m blk
forker
Query blk result
GetSystemStart ->
SystemStart -> m SystemStart
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SystemStart -> m SystemStart) -> SystemStart -> m SystemStart
forall a b. (a -> b) -> a -> b
$ BlockConfig blk -> SystemStart
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> SystemStart
getSystemStart (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
topLevelConfigBlock (ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg ExtLedgerCfg blk
config))
Query blk result
GetChainBlockNo ->
HeaderState blk -> result
HeaderState blk -> WithOrigin BlockNo
forall blk. HeaderState blk -> WithOrigin BlockNo
headerStateBlockNo (HeaderState blk -> result)
-> (ExtLedgerState blk EmptyMK -> HeaderState blk)
-> ExtLedgerState blk EmptyMK
-> result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerState blk EmptyMK -> HeaderState blk
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> HeaderState blk
headerState
(ExtLedgerState blk EmptyMK -> result)
-> m (ExtLedgerState blk EmptyMK) -> m result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (ExtLedgerState blk EmptyMK)
-> m (ExtLedgerState blk EmptyMK)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (ReadOnlyForker' m blk -> STM m (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk -> STM m (l EmptyMK)
roforkerGetLedgerState ReadOnlyForker' m blk
forker)
Query blk result
GetChainPoint ->
HeaderState blk -> result
HeaderState blk -> Point blk
forall blk. HasAnnTip blk => HeaderState blk -> Point blk
headerStatePoint (HeaderState blk -> result)
-> (ExtLedgerState blk EmptyMK -> HeaderState blk)
-> ExtLedgerState blk EmptyMK
-> result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerState blk EmptyMK -> HeaderState blk
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> HeaderState blk
headerState
(ExtLedgerState blk EmptyMK -> result)
-> m (ExtLedgerState blk EmptyMK) -> m result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (ExtLedgerState blk EmptyMK)
-> m (ExtLedgerState blk EmptyMK)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (ReadOnlyForker' m blk -> STM m (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk -> STM m (l EmptyMK)
roforkerGetLedgerState ReadOnlyForker' m blk
forker)
Query blk result
DebugLedgerConfig ->
result -> m result
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (result -> m result) -> result -> m result
forall a b. (a -> b) -> a -> b
$ TopLevelConfig blk -> LedgerCfg (LedgerState blk)
forall blk. TopLevelConfig blk -> LedgerConfig blk
topLevelConfigLedger (ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg ExtLedgerCfg blk
config)
deriving instance
(forall footprint result. Show (BlockQuery blk footprint result)) =>
Show (SomeBlockQuery (BlockQuery blk))
deriving instance
(forall footprint. Show (BlockQuery blk footprint result)) =>
Show (Query blk result)
instance ShowProxy (BlockQuery blk) => ShowProxy (Query blk) where
showProxy :: Proxy (Query blk) -> String
showProxy (Proxy (Query blk)
Proxy :: Proxy (Query blk)) =
String
"Query (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Proxy (BlockQuery blk) -> String
forall {k} (p :: k). ShowProxy p => Proxy p -> String
showProxy (forall {k} (t :: k). Proxy t
forall (t :: QueryFootprint -> * -> *). Proxy t
Proxy @(BlockQuery blk)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
instance
(forall footprint. ShowQuery (BlockQuery blk footprint), StandardHash blk) =>
ShowQuery (Query blk)
where
showResult :: forall result. Query blk result -> result -> String
showResult (BlockQuery BlockQuery blk footprint result
blockQuery) = BlockQuery blk footprint result -> result -> String
forall result. BlockQuery blk footprint result -> result -> String
forall (query :: * -> *) result.
ShowQuery query =>
query result -> result -> String
showResult BlockQuery blk footprint result
blockQuery
showResult Query blk result
GetSystemStart = result -> String
forall a. Show a => a -> String
show
showResult Query blk result
GetChainBlockNo = result -> String
forall a. Show a => a -> String
show
showResult Query blk result
GetChainPoint = result -> String
forall a. Show a => a -> String
show
showResult Query blk result
DebugLedgerConfig = String -> result -> String
forall a b. a -> b -> a
const String
"LedgerConfig{..}"
instance Show (SomeBlockQuery (BlockQuery blk)) => Show (SomeSecond Query blk) where
show :: SomeSecond Query blk -> String
show (SomeSecond (BlockQuery BlockQuery blk footprint b
blockQueryA)) =
String
"Query " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeBlockQuery (BlockQuery blk) -> String
forall a. Show a => a -> String
show (BlockQuery blk footprint b -> SomeBlockQuery (BlockQuery blk)
forall (q :: QueryFootprint -> * -> *)
(footprint :: QueryFootprint) result.
SingI footprint =>
q footprint result -> SomeBlockQuery q
SomeBlockQuery BlockQuery blk footprint b
blockQueryA)
show (SomeSecond Query blk b
GetSystemStart) = String
"Query GetSystemStart"
show (SomeSecond Query blk b
GetChainBlockNo) = String
"Query GetChainBlockNo"
show (SomeSecond Query blk b
GetChainPoint) = String
"Query GetChainPoint"
show (SomeSecond Query blk b
DebugLedgerConfig) = String
"Query DebugLedgerConfig"
queryIsSupportedOnNodeToClientVersion ::
forall blk result.
(SupportedNetworkProtocolVersion blk, BlockSupportsLedgerQuery blk) =>
Query blk result ->
NodeToClientVersion ->
Bool
queryIsSupportedOnNodeToClientVersion :: forall blk result.
(SupportedNetworkProtocolVersion blk,
BlockSupportsLedgerQuery blk) =>
Query blk result -> NodeToClientVersion -> Bool
queryIsSupportedOnNodeToClientVersion Query blk result
q NodeToClientVersion
ntc =
case Proxy blk -> Map NodeToClientVersion (BlockNodeToClientVersion blk)
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> Map NodeToClientVersion (BlockNodeToClientVersion blk)
supportedNodeToClientVersions (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) Map NodeToClientVersion (BlockNodeToClientVersion blk)
-> NodeToClientVersion -> Maybe (BlockNodeToClientVersion blk)
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? NodeToClientVersion
ntc of
Maybe (BlockNodeToClientVersion blk)
Nothing -> Bool
False
Just BlockNodeToClientVersion blk
bv -> Query blk result
-> QueryVersion -> BlockNodeToClientVersion blk -> Bool
forall blk result.
BlockSupportsLedgerQuery blk =>
Query blk result
-> QueryVersion -> BlockNodeToClientVersion blk -> Bool
queryIsSupportedOnVersion Query blk result
q QueryVersion
qv BlockNodeToClientVersion blk
bv
where
qv :: QueryVersion
qv = NodeToClientVersion -> QueryVersion
nodeToClientVersionToQueryVersion NodeToClientVersion
ntc
queryIsSupportedOnVersion ::
BlockSupportsLedgerQuery blk =>
Query blk result ->
QueryVersion ->
BlockNodeToClientVersion blk ->
Bool
queryIsSupportedOnVersion :: forall blk result.
BlockSupportsLedgerQuery blk =>
Query blk result
-> QueryVersion -> BlockNodeToClientVersion blk -> Bool
queryIsSupportedOnVersion Query blk result
q QueryVersion
qv BlockNodeToClientVersion blk
bv = case Query blk result
q of
BlockQuery BlockQuery blk footprint result
q' -> QueryVersion
qv QueryVersion -> QueryVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= QueryVersion
QueryVersion1 Bool -> Bool -> Bool
&& BlockQuery blk footprint result
-> BlockNodeToClientVersion blk -> Bool
forall blk (fp :: QueryFootprint) result.
BlockSupportsLedgerQuery blk =>
BlockQuery blk fp result -> BlockNodeToClientVersion blk -> Bool
forall (fp :: QueryFootprint) result.
BlockQuery blk fp result -> BlockNodeToClientVersion blk -> Bool
blockQueryIsSupportedOnVersion BlockQuery blk footprint result
q' BlockNodeToClientVersion blk
bv
GetSystemStart{} -> QueryVersion
qv QueryVersion -> QueryVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= QueryVersion
QueryVersion1
GetChainBlockNo{} -> QueryVersion
qv QueryVersion -> QueryVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= QueryVersion
QueryVersion2
GetChainPoint{} -> QueryVersion
qv QueryVersion -> QueryVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= QueryVersion
QueryVersion2
DebugLedgerConfig{} -> QueryVersion
qv QueryVersion -> QueryVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= QueryVersion
QueryVersion3
querySupportedVersions ::
forall blk result.
(SupportedNetworkProtocolVersion blk, BlockSupportsLedgerQuery blk) =>
Query blk result ->
[NodeToClientVersion]
querySupportedVersions :: forall blk result.
(SupportedNetworkProtocolVersion blk,
BlockSupportsLedgerQuery blk) =>
Query blk result -> [NodeToClientVersion]
querySupportedVersions Query blk result
q =
[ NodeToClientVersion
v
| NodeToClientVersion
v <- [NodeToClientVersion
forall a. Bounded a => a
minBound .. NodeToClientVersion
forall a. Bounded a => a
maxBound]
, Query blk result -> NodeToClientVersion -> Bool
forall blk result.
(SupportedNetworkProtocolVersion blk,
BlockSupportsLedgerQuery blk) =>
Query blk result -> NodeToClientVersion -> Bool
queryIsSupportedOnNodeToClientVersion Query blk result
q NodeToClientVersion
v
]
data QueryEncoderException blk
=
QueryEncoderUnsupportedQuery
(SomeSecond Query blk)
QueryVersion
(BlockNodeToClientVersion blk)
deriving instance
(Show (SomeSecond Query blk), Show (BlockNodeToClientVersion blk)) =>
Show (QueryEncoderException blk)
instance
(Typeable blk, Show (SomeSecond Query blk), Show (BlockNodeToClientVersion blk)) =>
Exception (QueryEncoderException blk)
instance SameDepIndex (Query blk) => Eq (SomeSecond Query blk) where
SomeSecond Query blk b
l == :: SomeSecond Query blk -> SomeSecond Query blk -> Bool
== SomeSecond Query blk b
r = Maybe (b :~: b) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (b :~: b) -> Bool) -> Maybe (b :~: b) -> Bool
forall a b. (a -> b) -> a -> b
$ Query blk b -> Query blk b -> Maybe (b :~: b)
forall a b. Query blk a -> Query blk b -> Maybe (a :~: b)
forall k (f :: k -> *) (a :: k) (b :: k).
SameDepIndex f =>
f a -> f b -> Maybe (a :~: b)
sameDepIndex Query blk b
l Query blk b
r
instance SameDepIndex2 query => Eq (SomeBlockQuery query) where
SomeBlockQuery query footprint result
l == :: SomeBlockQuery query -> SomeBlockQuery query -> Bool
== SomeBlockQuery query footprint result
r = Maybe ('(footprint, result) :~: '(footprint, result)) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ('(footprint, result) :~: '(footprint, result)) -> Bool)
-> Maybe ('(footprint, result) :~: '(footprint, result)) -> Bool
forall a b. (a -> b) -> a -> b
$ query footprint result
-> query footprint result
-> Maybe ('(footprint, result) :~: '(footprint, result))
forall k1 k2 (f :: k1 -> k2 -> *) (x :: k1) (a :: k2) (y :: k1)
(b :: k2).
SameDepIndex2 f =>
f x a -> f y b -> Maybe ('(x, a) :~: '(y, b))
forall (x :: QueryFootprint) a (y :: QueryFootprint) b.
query x a -> query y b -> Maybe ('(x, a) :~: '(y, b))
sameDepIndex2 query footprint result
l query footprint result
r
instance SameDepIndex2 (BlockQuery blk) => SameDepIndex (Query blk) where
sameDepIndex :: forall a b. Query blk a -> Query blk b -> Maybe (a :~: b)
sameDepIndex (BlockQuery BlockQuery blk footprint a
blockQueryA) (BlockQuery BlockQuery blk footprint b
blockQueryB) =
(\'(footprint, a) :~: '(footprint, b)
Refl -> a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl) (('(footprint, a) :~: '(footprint, b)) -> a :~: b)
-> Maybe ('(footprint, a) :~: '(footprint, b)) -> Maybe (a :~: b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockQuery blk footprint a
-> BlockQuery blk footprint b
-> Maybe ('(footprint, a) :~: '(footprint, b))
forall k1 k2 (f :: k1 -> k2 -> *) (x :: k1) (a :: k2) (y :: k1)
(b :: k2).
SameDepIndex2 f =>
f x a -> f y b -> Maybe ('(x, a) :~: '(y, b))
forall (x :: QueryFootprint) a (y :: QueryFootprint) b.
BlockQuery blk x a
-> BlockQuery blk y b -> Maybe ('(x, a) :~: '(y, b))
sameDepIndex2 BlockQuery blk footprint a
blockQueryA BlockQuery blk footprint b
blockQueryB
sameDepIndex (BlockQuery BlockQuery blk footprint a
_) Query blk b
_ =
Maybe (a :~: b)
forall a. Maybe a
Nothing
sameDepIndex Query blk a
GetSystemStart Query blk b
GetSystemStart =
(a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
sameDepIndex Query blk a
GetSystemStart Query blk b
_ =
Maybe (a :~: b)
forall a. Maybe a
Nothing
sameDepIndex Query blk a
GetChainBlockNo Query blk b
GetChainBlockNo =
(a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
sameDepIndex Query blk a
GetChainBlockNo Query blk b
_ =
Maybe (a :~: b)
forall a. Maybe a
Nothing
sameDepIndex Query blk a
GetChainPoint Query blk b
GetChainPoint =
(a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
sameDepIndex Query blk a
GetChainPoint Query blk b
_ =
Maybe (a :~: b)
forall a. Maybe a
Nothing
sameDepIndex Query blk a
DebugLedgerConfig Query blk b
DebugLedgerConfig =
(a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
sameDepIndex Query blk a
DebugLedgerConfig Query blk b
_ =
Maybe (a :~: b)
forall a. Maybe a
Nothing
deriving newtype instance
SerialiseNodeToClient blk (SomeBlockQuery (query blk)) =>
SerialiseNodeToClient blk ((SomeBlockQuery :.: query) blk)
queryEncodeNodeToClient ::
forall blk.
SerialiseNodeToClient blk (SomeBlockQuery (BlockQuery blk)) =>
Show (SomeSecond Query blk) =>
BlockSupportsLedgerQuery blk =>
Show (BlockNodeToClientVersion blk) =>
Typeable blk =>
CodecConfig blk ->
QueryVersion ->
BlockNodeToClientVersion blk ->
SomeSecond Query blk ->
Encoding
queryEncodeNodeToClient :: forall blk.
(SerialiseNodeToClient blk (SomeBlockQuery (BlockQuery blk)),
Show (SomeSecond Query blk), BlockSupportsLedgerQuery blk,
Show (BlockNodeToClientVersion blk), Typeable blk) =>
CodecConfig blk
-> QueryVersion
-> BlockNodeToClientVersion blk
-> SomeSecond Query blk
-> Encoding
queryEncodeNodeToClient CodecConfig blk
codecConfig QueryVersion
queryVersion BlockNodeToClientVersion blk
blockVersion (SomeSecond Query blk b
query) =
Query blk b -> Encoding -> Encoding
forall result a. Query blk result -> a -> a
requireVersion Query blk b
query (Encoding -> Encoding) -> Encoding -> Encoding
forall a b. (a -> b) -> a -> b
$ case Query blk b
query of
BlockQuery BlockQuery blk footprint b
blockQuery ->
[Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
[ Word -> Encoding
encodeListLen Word
2
, Word8 -> Encoding
encodeWord8 Word8
0
, BlockQuery blk footprint b -> Encoding
forall (footprint :: QueryFootprint) result.
SingI footprint =>
BlockQuery blk footprint result -> Encoding
encodeBlockQuery BlockQuery blk footprint b
blockQuery
]
Query blk b
GetSystemStart ->
[Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
[ Word -> Encoding
encodeListLen Word
1
, Word8 -> Encoding
encodeWord8 Word8
1
]
Query blk b
GetChainBlockNo ->
[Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
[ Word -> Encoding
encodeListLen Word
1
, Word8 -> Encoding
encodeWord8 Word8
2
]
Query blk b
GetChainPoint ->
[Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
[ Word -> Encoding
encodeListLen Word
1
, Word8 -> Encoding
encodeWord8 Word8
3
]
Query blk b
DebugLedgerConfig ->
[Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
[ Word -> Encoding
encodeListLen Word
1
, Word8 -> Encoding
encodeWord8 Word8
4
]
where
requireVersion :: Query blk result -> a -> a
requireVersion :: forall result a. Query blk result -> a -> a
requireVersion Query blk result
q a
a =
if Query blk result
-> QueryVersion -> BlockNodeToClientVersion blk -> Bool
forall blk result.
BlockSupportsLedgerQuery blk =>
Query blk result
-> QueryVersion -> BlockNodeToClientVersion blk -> Bool
queryIsSupportedOnVersion Query blk result
q QueryVersion
queryVersion BlockNodeToClientVersion blk
blockVersion
then a
a
else QueryEncoderException blk -> a
forall a e. (HasCallStack, Exception e) => e -> a
throw (QueryEncoderException blk -> a) -> QueryEncoderException blk -> a
forall a b. (a -> b) -> a -> b
$ SomeSecond Query blk
-> QueryVersion
-> BlockNodeToClientVersion blk
-> QueryEncoderException blk
forall blk.
SomeSecond Query blk
-> QueryVersion
-> BlockNodeToClientVersion blk
-> QueryEncoderException blk
QueryEncoderUnsupportedQuery (Query blk b -> SomeSecond Query blk
forall {k1} {k2} (f :: k1 -> k2 -> *) (a :: k1) (b :: k2).
f a b -> SomeSecond f a
SomeSecond Query blk b
query) QueryVersion
queryVersion BlockNodeToClientVersion blk
blockVersion
encodeBlockQuery ::
SingI footprint =>
BlockQuery blk footprint result ->
Encoding
encodeBlockQuery :: forall (footprint :: QueryFootprint) result.
SingI footprint =>
BlockQuery blk footprint result -> Encoding
encodeBlockQuery BlockQuery blk footprint result
blockQuery =
forall blk a.
SerialiseNodeToClient blk a =>
CodecConfig blk -> BlockNodeToClientVersion blk -> a -> Encoding
encodeNodeToClient
@blk
@(SomeBlockQuery (BlockQuery blk))
CodecConfig blk
codecConfig
BlockNodeToClientVersion blk
blockVersion
(BlockQuery blk footprint result -> SomeBlockQuery (BlockQuery blk)
forall (q :: QueryFootprint -> * -> *)
(footprint :: QueryFootprint) result.
SingI footprint =>
q footprint result -> SomeBlockQuery q
SomeBlockQuery BlockQuery blk footprint result
blockQuery)
queryDecodeNodeToClient ::
forall blk.
SerialiseNodeToClient blk (SomeBlockQuery (BlockQuery blk)) =>
CodecConfig blk ->
QueryVersion ->
BlockNodeToClientVersion blk ->
forall s.
Decoder s (SomeSecond Query blk)
queryDecodeNodeToClient :: forall blk.
SerialiseNodeToClient blk (SomeBlockQuery (BlockQuery blk)) =>
CodecConfig blk
-> QueryVersion
-> BlockNodeToClientVersion blk
-> forall s. Decoder s (SomeSecond Query blk)
queryDecodeNodeToClient CodecConfig blk
codecConfig QueryVersion
queryVersion BlockNodeToClientVersion blk
blockVersion =
case QueryVersion
queryVersion of
QueryVersion
QueryVersion1 -> Decoder s (SomeSecond Query blk)
forall s. Decoder s (SomeSecond Query blk)
handleTopLevelQuery
QueryVersion
QueryVersion2 -> Decoder s (SomeSecond Query blk)
forall s. Decoder s (SomeSecond Query blk)
handleTopLevelQuery
QueryVersion
QueryVersion3 -> Decoder s (SomeSecond Query blk)
forall s. Decoder s (SomeSecond Query blk)
handleTopLevelQuery
where
handleTopLevelQuery :: Decoder s (SomeSecond Query blk)
handleTopLevelQuery :: forall s. Decoder s (SomeSecond Query blk)
handleTopLevelQuery = do
size <- Decoder s Int
forall s. Decoder s Int
decodeListLen
tag <- decodeWord8
case (size, tag) of
(Int
2, Word8
0) -> QueryVersion
-> SomeSecond Query blk -> Decoder s (SomeSecond Query blk)
forall s.
QueryVersion
-> SomeSecond Query blk -> Decoder s (SomeSecond Query blk)
requireVersion QueryVersion
QueryVersion1 (SomeSecond Query blk -> Decoder s (SomeSecond Query blk))
-> Decoder s (SomeSecond Query blk)
-> Decoder s (SomeSecond Query blk)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Decoder s (SomeSecond Query blk)
forall s. Decoder s (SomeSecond Query blk)
decodeBlockQuery
(Int
1, Word8
1) -> QueryVersion
-> SomeSecond Query blk -> Decoder s (SomeSecond Query blk)
forall s.
QueryVersion
-> SomeSecond Query blk -> Decoder s (SomeSecond Query blk)
requireVersion QueryVersion
QueryVersion1 (SomeSecond Query blk -> Decoder s (SomeSecond Query blk))
-> SomeSecond Query blk -> Decoder s (SomeSecond Query blk)
forall a b. (a -> b) -> a -> b
$ Query blk SystemStart -> SomeSecond Query blk
forall {k1} {k2} (f :: k1 -> k2 -> *) (a :: k1) (b :: k2).
f a b -> SomeSecond f a
SomeSecond Query blk SystemStart
forall blk. Query blk SystemStart
GetSystemStart
(Int
1, Word8
2) -> QueryVersion
-> SomeSecond Query blk -> Decoder s (SomeSecond Query blk)
forall s.
QueryVersion
-> SomeSecond Query blk -> Decoder s (SomeSecond Query blk)
requireVersion QueryVersion
QueryVersion2 (SomeSecond Query blk -> Decoder s (SomeSecond Query blk))
-> SomeSecond Query blk -> Decoder s (SomeSecond Query blk)
forall a b. (a -> b) -> a -> b
$ Query blk (WithOrigin BlockNo) -> SomeSecond Query blk
forall {k1} {k2} (f :: k1 -> k2 -> *) (a :: k1) (b :: k2).
f a b -> SomeSecond f a
SomeSecond Query blk (WithOrigin BlockNo)
forall blk. Query blk (WithOrigin BlockNo)
GetChainBlockNo
(Int
1, Word8
3) -> QueryVersion
-> SomeSecond Query blk -> Decoder s (SomeSecond Query blk)
forall s.
QueryVersion
-> SomeSecond Query blk -> Decoder s (SomeSecond Query blk)
requireVersion QueryVersion
QueryVersion2 (SomeSecond Query blk -> Decoder s (SomeSecond Query blk))
-> SomeSecond Query blk -> Decoder s (SomeSecond Query blk)
forall a b. (a -> b) -> a -> b
$ Query blk (Point blk) -> SomeSecond Query blk
forall {k1} {k2} (f :: k1 -> k2 -> *) (a :: k1) (b :: k2).
f a b -> SomeSecond f a
SomeSecond Query blk (Point blk)
forall blk. Query blk (Point blk)
GetChainPoint
(Int
1, Word8
4) -> QueryVersion
-> SomeSecond Query blk -> Decoder s (SomeSecond Query blk)
forall s.
QueryVersion
-> SomeSecond Query blk -> Decoder s (SomeSecond Query blk)
requireVersion QueryVersion
QueryVersion3 (SomeSecond Query blk -> Decoder s (SomeSecond Query blk))
-> SomeSecond Query blk -> Decoder s (SomeSecond Query blk)
forall a b. (a -> b) -> a -> b
$ Query blk (LedgerCfg (LedgerState blk)) -> SomeSecond Query blk
forall {k1} {k2} (f :: k1 -> k2 -> *) (a :: k1) (b :: k2).
f a b -> SomeSecond f a
SomeSecond Query blk (LedgerCfg (LedgerState blk))
forall blk. Query blk (LedgerConfig blk)
DebugLedgerConfig
(Int, Word8)
_ -> String -> Decoder s (SomeSecond Query blk)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s (SomeSecond Query blk))
-> String -> Decoder s (SomeSecond Query blk)
forall a b. (a -> b) -> a -> b
$ String
"Query: invalid size and tag" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Int, Word8) -> String
forall a. Show a => a -> String
show (Int
size, Word8
tag)
requireVersion ::
QueryVersion ->
SomeSecond Query blk ->
Decoder s (SomeSecond Query blk)
requireVersion :: forall s.
QueryVersion
-> SomeSecond Query blk -> Decoder s (SomeSecond Query blk)
requireVersion QueryVersion
expectedVersion SomeSecond Query blk
someSecondQuery =
if QueryVersion
queryVersion QueryVersion -> QueryVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= QueryVersion
expectedVersion
then SomeSecond Query blk -> Decoder s (SomeSecond Query blk)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return SomeSecond Query blk
someSecondQuery
else case SomeSecond Query blk
someSecondQuery of
SomeSecond Query blk b
query -> String -> Decoder s (SomeSecond Query blk)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s (SomeSecond Query blk))
-> String -> Decoder s (SomeSecond Query blk)
forall a b. (a -> b) -> a -> b
$ String
"Query: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Query blk b -> String
forall blk result. Query blk result -> String
queryName Query blk b
query String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" requires at least " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> QueryVersion -> String
forall a. Show a => a -> String
show QueryVersion
expectedVersion
decodeBlockQuery :: Decoder s (SomeSecond Query blk)
decodeBlockQuery :: forall s. Decoder s (SomeSecond Query blk)
decodeBlockQuery = do
SomeBlockQuery blockQuery <-
forall blk a.
SerialiseNodeToClient blk a =>
CodecConfig blk
-> BlockNodeToClientVersion blk -> forall s. Decoder s a
decodeNodeToClient
@blk
@(SomeBlockQuery (BlockQuery blk))
CodecConfig blk
codecConfig
BlockNodeToClientVersion blk
blockVersion
return (SomeSecond (BlockQuery blockQuery))
instance
( SerialiseBlockQueryResult blk BlockQuery
, Serialise (HeaderHash blk)
, SerialiseNodeToClient blk (LedgerConfig blk)
) =>
SerialiseResult blk Query
where
encodeResult :: forall result.
CodecConfig blk
-> BlockNodeToClientVersion blk
-> Query blk result
-> result
-> Encoding
encodeResult CodecConfig blk
codecConfig BlockNodeToClientVersion blk
blockVersion (BlockQuery BlockQuery blk footprint result
blockQuery) result
result =
CodecConfig blk
-> BlockNodeToClientVersion blk
-> BlockQuery blk footprint result
-> result
-> Encoding
forall k blk (query :: * -> k -> * -> *) (fp :: k) result.
SerialiseBlockQueryResult blk query =>
CodecConfig blk
-> BlockNodeToClientVersion blk
-> query blk fp result
-> result
-> Encoding
forall (fp :: QueryFootprint) result.
CodecConfig blk
-> BlockNodeToClientVersion blk
-> BlockQuery blk fp result
-> result
-> Encoding
encodeBlockQueryResult CodecConfig blk
codecConfig BlockNodeToClientVersion blk
blockVersion BlockQuery blk footprint result
blockQuery result
result
encodeResult CodecConfig blk
_ BlockNodeToClientVersion blk
_ Query blk result
GetSystemStart result
result =
result -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR result
result
encodeResult CodecConfig blk
_ BlockNodeToClientVersion blk
_ Query blk result
GetChainBlockNo result
result =
result -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR result
result
encodeResult CodecConfig blk
_ BlockNodeToClientVersion blk
_ Query blk result
GetChainPoint result
result =
(HeaderHash blk -> Encoding) -> Point blk -> Encoding
forall {k} (block :: k).
(HeaderHash block -> Encoding) -> Point block -> Encoding
encodePoint HeaderHash blk -> Encoding
forall a. Serialise a => a -> Encoding
encode result
Point blk
result
encodeResult CodecConfig blk
codecConfig BlockNodeToClientVersion blk
blockVersion Query blk result
DebugLedgerConfig result
result =
CodecConfig blk
-> BlockNodeToClientVersion blk -> result -> Encoding
forall blk a.
SerialiseNodeToClient blk a =>
CodecConfig blk -> BlockNodeToClientVersion blk -> a -> Encoding
encodeNodeToClient CodecConfig blk
codecConfig BlockNodeToClientVersion blk
blockVersion result
result
decodeResult :: forall result.
CodecConfig blk
-> BlockNodeToClientVersion blk
-> Query blk result
-> forall s. Decoder s result
decodeResult CodecConfig blk
codecConfig BlockNodeToClientVersion blk
blockVersion (BlockQuery BlockQuery blk footprint result
query) =
CodecConfig blk
-> BlockNodeToClientVersion blk
-> BlockQuery blk footprint result
-> forall s. Decoder s result
forall k blk (query :: * -> k -> * -> *) (fp :: k) result.
SerialiseBlockQueryResult blk query =>
CodecConfig blk
-> BlockNodeToClientVersion blk
-> query blk fp result
-> forall s. Decoder s result
forall (fp :: QueryFootprint) result.
CodecConfig blk
-> BlockNodeToClientVersion blk
-> BlockQuery blk fp result
-> forall s. Decoder s result
decodeBlockQueryResult CodecConfig blk
codecConfig BlockNodeToClientVersion blk
blockVersion BlockQuery blk footprint result
query
decodeResult CodecConfig blk
_ BlockNodeToClientVersion blk
_ Query blk result
GetSystemStart =
Decoder s result
forall s. Decoder s result
forall a s. FromCBOR a => Decoder s a
fromCBOR
decodeResult CodecConfig blk
_ BlockNodeToClientVersion blk
_ Query blk result
GetChainBlockNo =
Decoder s result
forall s. Decoder s result
forall a s. FromCBOR a => Decoder s a
fromCBOR
decodeResult CodecConfig blk
_ BlockNodeToClientVersion blk
_ Query blk result
GetChainPoint =
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Point blk)
forall {k} (block :: k).
(forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Point block)
decodePoint Decoder s (HeaderHash blk)
forall s. Decoder s (HeaderHash blk)
forall a s. Serialise a => Decoder s a
decode
decodeResult CodecConfig blk
codecConfig BlockNodeToClientVersion blk
blockVersion Query blk result
DebugLedgerConfig =
forall blk a.
SerialiseNodeToClient blk a =>
CodecConfig blk
-> BlockNodeToClientVersion blk -> forall s. Decoder s a
decodeNodeToClient @blk @(LedgerConfig blk) CodecConfig blk
codecConfig BlockNodeToClientVersion blk
blockVersion