Local State Query protocol uses top level Query type instead of Block…

…Query directly

ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/Generators.hs

@@ -31,6 +31,7 @@ import           Test.QuickCheck
 import           Ouroboros.Consensus.Block
 import qualified Ouroboros.Consensus.HardFork.History as History
 import           Ouroboros.Consensus.HeaderValidation
+import           Ouroboros.Consensus.Ledger.Query (Query (..))
 import           Ouroboros.Consensus.Node.NetworkProtocolVersion
 import           Ouroboros.Consensus.Node.Serialisation (Some (..))
 import           Ouroboros.Consensus.TypeFamilyWrappers
@@ -406,6 +407,14 @@ instance c ~ MockCryptoCompatByron
       injAnytimeMary    (Some      query)  = SomeSecond (QueryAnytimeMary      query)
       injHardFork       (Some      query)  = SomeSecond (QueryHardFork         query)
 
+instance Arbitrary (WithVersion (HardForkNodeToClientVersion (CardanoEras c))
+                                (SomeSecond BlockQuery blk))
+      => Arbitrary (WithVersion (HardForkNodeToClientVersion (CardanoEras c))
+                                (SomeSecond Query blk)) where
+  arbitrary = do
+    WithVersion v (SomeSecond someBlockQuery) <- arbitrary
+    return (WithVersion v (SomeSecond (BlockQuery someBlockQuery)))
+
 instance Arbitrary History.EraEnd where
   arbitrary = oneof
       [ History.EraEnd <$> arbitrary

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs

@@ -332,6 +332,7 @@ instance CardanoHardForkConstraints c
       , (NodeToClientV_6, CardanoNodeToClientVersion5)
       , (NodeToClientV_7, CardanoNodeToClientVersion6)
       , (NodeToClientV_8, CardanoNodeToClientVersion6)
+      , (NodeToClientV_9, CardanoNodeToClientVersion6)
       ]
 
   latestReleasedNodeVersion = latestReleasedNodeVersionDefault

ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/Serialisation.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE StandaloneDeriving    #-}
 {-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE UndecidableInstances  #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 

ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Generators.hs

@@ -19,6 +19,7 @@ import           Ouroboros.Network.Block (mkSerialised)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Abstract
+import           Ouroboros.Consensus.Ledger.Query
 import           Ouroboros.Consensus.Ledger.SupportsMempool
 
 import qualified Shelley.Spec.Ledger.API as SL
@@ -180,3 +181,9 @@ instance CanMock era
       query@(SomeSecond q) <- arbitrary
       version <- arbitrary `suchThat` querySupportedVersion q
       return $ WithVersion version query
+
+instance Arbitrary (WithVersion ShelleyNodeToClientVersion (SomeSecond BlockQuery (ShelleyBlock era)))
+      => Arbitrary (WithVersion ShelleyNodeToClientVersion (SomeSecond Query (ShelleyBlock era))) where
+  arbitrary = do
+    WithVersion v (SomeSecond someBlockQuery) <- arbitrary
+    return (WithVersion v (SomeSecond (BlockQuery someBlockQuery)))

ouroboros-consensus-test/src/Test/Util/Orphans/Arbitrary.hs

@@ -34,6 +34,7 @@ import           Ouroboros.Consensus.HardFork.History (Bound (..))
 import           Ouroboros.Consensus.HeaderValidation (TipInfo)
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.SupportsMempool
+import           Ouroboros.Consensus.Ledger.Query
 import           Ouroboros.Consensus.Node.ProtocolInfo
 import           Ouroboros.Consensus.Protocol.Abstract (ChainDepState)
 import           Ouroboros.Consensus.TypeFamilyWrappers
@@ -376,3 +377,13 @@ instance (All SingleEraBlock (x ': xs), IsNonEmpty xs)
       dictLedgerEraInfo ::
            Dict (All (Arbitrary `Compose` LedgerEraInfo)) (x ': xs)
       dictLedgerEraInfo = all_NP $ hcpure proxySingle Dict
+
+{-------------------------------------------------------------------------------
+  Query
+-------------------------------------------------------------------------------}
+
+instance Arbitrary (SomeSecond BlockQuery blk)
+      => Arbitrary (SomeSecond Query blk) where
+  arbitrary = do
+    SomeSecond someBlockQuery <- arbitrary
+    return (SomeSecond (BlockQuery someBlockQuery))

ouroboros-consensus-test/src/Test/Util/Serialisation/Roundtrip.hs

@@ -43,7 +43,7 @@ import           Ouroboros.Network.Block (Serialised (..), fromSerialised,
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.HeaderValidation (AnnTip)
 import           Ouroboros.Consensus.Ledger.Abstract (LedgerState)
-import           Ouroboros.Consensus.Ledger.Query (BlockQuery)
+import           Ouroboros.Consensus.Ledger.Query (Query, BlockQuery, queryDecodeNodeToClient, queryEncodeNodeToClient)
 import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx,
                      GenTxId)
 import           Ouroboros.Consensus.Node.NetworkProtocolVersion
@@ -55,6 +55,7 @@ import           Ouroboros.Consensus.Storage.ChainDB (SerialiseDiskConstraints)
 import           Ouroboros.Consensus.Storage.Serialisation
 import           Ouroboros.Consensus.Util (Dict (..))
 
+
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
 
@@ -111,8 +112,8 @@ roundtrip_all
      , SerialiseNodeToNodeConstraints   blk
      , SerialiseNodeToClientConstraints blk
 
-     , Show (BlockNodeToNodeVersion   blk)
-     , Show (BlockNodeToClientVersion blk)
+    , Show (BlockNodeToNodeVersion   blk)
+    , Show (BlockNodeToClientVersion blk)
 
      , StandardHash blk
      , GetHeader    blk
@@ -133,6 +134,7 @@ roundtrip_all
      , ArbitraryWithVersion (BlockNodeToClientVersion blk) blk
      , ArbitraryWithVersion (BlockNodeToClientVersion blk) (GenTx blk)
      , ArbitraryWithVersion (BlockNodeToClientVersion blk) (ApplyTxErr blk)
+     , ArbitraryWithVersion (BlockNodeToClientVersion blk) (SomeSecond Query blk)
      , ArbitraryWithVersion (BlockNodeToClientVersion blk) (SomeSecond BlockQuery blk)
      , ArbitraryWithVersion (BlockNodeToClientVersion blk) (SomeResult blk)
      )
@@ -313,6 +315,7 @@ roundtrip_SerialiseNodeToClient
      , ArbitraryWithVersion (BlockNodeToClientVersion blk) blk
      , ArbitraryWithVersion (BlockNodeToClientVersion blk) (GenTx blk)
      , ArbitraryWithVersion (BlockNodeToClientVersion blk) (ApplyTxErr blk)
+     , ArbitraryWithVersion (BlockNodeToClientVersion blk) (SomeSecond Query blk)
      , ArbitraryWithVersion (BlockNodeToClientVersion blk) (SomeSecond BlockQuery blk)
      , ArbitraryWithVersion (BlockNodeToClientVersion blk) (SomeResult blk)
 
@@ -327,6 +330,9 @@ roundtrip_SerialiseNodeToClient ccfg =
     , rt (Proxy @(GenTx blk))                 "GenTx"
     , rt (Proxy @(ApplyTxErr blk))            "ApplyTxErr"
     , rt (Proxy @(SomeSecond BlockQuery blk)) "BlockQuery"
+    , rtWith (Proxy @(SomeSecond Query blk))  "Query"
+                                              (queryEncodeNodeToClient ccfg maxBound)
+                                              (queryDecodeNodeToClient ccfg maxBound)
       -- See roundtrip_SerialiseNodeToNode for more info
     , testProperty "roundtrip Serialised blk" $
         \(WithVersion version blk) ->
@@ -365,10 +371,23 @@ roundtrip_SerialiseNodeToClient ccfg =
          , SerialiseNodeToClient blk a
          )
        => Proxy a -> String -> TestTree
-    rt _ name =
+    rt p name = rtWith p name enc dec
+
+    rtWith
+      :: forall a.
+         ( Arbitrary (WithVersion (BlockNodeToClientVersion blk) a)
+         , Eq a
+         , Show a
+         )
+       => Proxy a
+       -> String
+       -> (BlockNodeToClientVersion blk -> a -> Encoding)
+       -> (BlockNodeToClientVersion blk -> forall s. Decoder s a)
+       -> TestTree
+    rtWith _ name enc' dec' =
       testProperty ("roundtrip " <> name) $
         \(WithVersion version a) ->
-          roundtrip @a (enc version) (dec version) a
+          roundtrip @a (enc' version) (dec' version) a
 
 {-------------------------------------------------------------------------------
   Checking envelopes

ouroboros-consensus-test/test-consensus/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs

@@ -48,6 +48,7 @@ import           Test.QuickCheck hiding (Result)
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
 
+import           Ouroboros.Consensus.Ledger.Query (Query (..))
 import           Test.Util.Orphans.IOLike ()
 import           Test.Util.TestBlock
 
@@ -153,16 +154,16 @@ mkClient
   -> LocalStateQueryClient
        TestBlock
        (Point TestBlock)
-       (BlockQuery TestBlock)
+       (Query TestBlock)
        m
        [(Maybe (Point TestBlock), Either AcquireFailure (Point TestBlock))]
-mkClient points = localStateQueryClient [(pt, QueryLedgerTip) | pt <- points]
+mkClient points = localStateQueryClient [(pt, BlockQuery QueryLedgerTip) | pt <- points]
 
 mkServer
   :: IOLike m
   => SecurityParam
   -> Chain TestBlock
-  -> m (LocalStateQueryServer TestBlock (Point TestBlock) (BlockQuery TestBlock) m ())
+  -> m (LocalStateQueryServer TestBlock (Point TestBlock) (Query TestBlock) m ())
 mkServer k chain = do
     lgrDB <- initLgrDB k chain
     return $

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Serialisation/SerialiseNodeToClient.hs

@@ -11,6 +11,7 @@
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE UndecidableInstances  #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 

ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Query.hs

@@ -1,7 +1,11 @@
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE UndecidableInstances  #-}
 module Ouroboros.Consensus.Ledger.Query (
@@ -10,6 +14,10 @@ module Ouroboros.Consensus.Ledger.Query (
   , QueryLedger (..)
   , ShowQuery (..)
   , answerQuery
+  , queryEncodeNodeToClient
+  , queryDecodeNodeToClient
+  , queryEncodeResult
+  , queryDecodeResult
   ) where
 
 import           Data.Kind (Type)
@@ -18,9 +26,15 @@ import           Data.Maybe (isJust)
 import           Ouroboros.Network.Protocol.LocalStateQuery.Type
                      (ShowQuery (..))
 
+import           Cardano.Binary
 import           Ouroboros.Consensus.Ledger.Extended
-import           Ouroboros.Consensus.Util (SomeSecond (..))
+import           Ouroboros.Consensus.Node.NetworkProtocolVersion
+                     (NodeToClientVersion(..), HasNetworkProtocolVersion (..))
+import           Ouroboros.Consensus.Node.Serialisation
+                     (SerialiseNodeToClient (..), SerialiseResult (..))
+import           Ouroboros.Consensus.Util (ShowProxy (..), SomeSecond (..))
 import           Ouroboros.Consensus.Util.DepPair
+import Ouroboros.Consensus.Block.Abstract (CodecConfig)
 
 {-------------------------------------------------------------------------------
   Queries
@@ -30,6 +44,104 @@ import           Ouroboros.Consensus.Util.DepPair
 -- by the result type.
 data Query blk result = BlockQuery (BlockQuery blk result)
 
+instance (ShowProxy (BlockQuery blk)) => ShowProxy (Query blk) where
+  showProxy (Proxy :: Proxy (Query blk)) = "Query (" ++ showProxy (Proxy @(BlockQuery blk)) ++ ")"
+
+instance (ShowQuery (BlockQuery blk)) => ShowQuery (Query blk) where
+  showResult (BlockQuery blockQuery) = showResult blockQuery
+
+instance Eq (SomeSecond BlockQuery blk) => Eq (SomeSecond Query blk) where
+  SomeSecond (BlockQuery blockQueryA) == SomeSecond (BlockQuery blockQueryB)
+    = SomeSecond blockQueryA == SomeSecond blockQueryB
+
+instance Show (SomeSecond BlockQuery blk) => Show (SomeSecond Query blk) where
+  show (SomeSecond (BlockQuery blockQueryA)) = "Query " ++ show (SomeSecond blockQueryA)
+
+queryEncodeNodeToClient ::
+    forall blk. (
+      SerialiseNodeToClient blk (SomeSecond BlockQuery blk)
+    )
+  => CodecConfig blk
+  -> NodeToClientVersion
+  -> BlockNodeToClientVersion blk
+  -> (SomeSecond Query blk)
+  -> Encoding
+queryEncodeNodeToClient codecConfig version blockVersion (SomeSecond query)
+  | not (version >= NodeToClientV_9)
+  = error "encode failure: Serializing Query is not supported"
+  | otherwise
+  = case query of
+    BlockQuery blockQuery ->
+      encodeTag 0 <> encodeNodeToClient
+                      @blk
+                      @(SomeSecond BlockQuery blk)
+                      codecConfig
+                      blockVersion
+                      (SomeSecond blockQuery)
+
+queryDecodeNodeToClient ::
+    forall blk. (
+      SerialiseNodeToClient blk (SomeSecond BlockQuery blk)
+    )
+  => CodecConfig blk
+  -> NodeToClientVersion
+  -> BlockNodeToClientVersion blk
+  -> forall s. Decoder s (SomeSecond Query blk)
+queryDecodeNodeToClient codecConfig version blockVersion
+  | not (version >= NodeToClientV_9)
+  = fail $ "decode failure: Deserializing Query is not supported (on node to client version: " ++ show version ++ ")"
+  | otherwise
+  = do
+    tag <- decodeTag
+    case tag of
+      0 -> do
+        SomeSecond x <- decodeNodeToClient
+            @blk
+            @(SomeSecond BlockQuery blk)
+            codecConfig
+            blockVersion
+        return (SomeSecond (BlockQuery x))
+      _ -> fail $ "SomeSecond Query blk: unknown tag " ++ show tag
+
+queryEncodeResult ::
+     forall blk result. SerialiseResult blk (BlockQuery blk)
+  => CodecConfig blk
+  -> NodeToClientVersion
+  -> BlockNodeToClientVersion blk
+  -> Query blk result
+  -> result
+  -> Encoding
+queryEncodeResult codecConfig version blockNodeToClientVersion query result
+  | not (version >= NodeToClientV_9)
+  = error $ "encode failure: Serializing Query result is not supported (on node to client version: " ++ show version ++ ")"
+  | otherwise
+  = case query of
+      BlockQuery blockQuery ->
+        encodeTag 0
+        <> encodeResult codecConfig blockNodeToClientVersion blockQuery result
+
+queryDecodeResult ::
+     forall blk result. SerialiseResult blk (BlockQuery blk)
+  => CodecConfig blk
+  -> NodeToClientVersion
+  -> BlockNodeToClientVersion blk
+  -> Query blk result
+  -> forall s. Decoder s result
+queryDecodeResult codecConfig version blockNodeToClientVersion query
+  | not (version >= NodeToClientV_9)
+  = error $ "encode failure: Deserializing Query result is not supported (on node to client version: " ++ show version ++ ")"
+  | otherwise
+  = do
+    tag <- decodeTag
+    case query of
+      BlockQuery blockQuery
+        | tag /= 0 -> fail $ "Query blk: Expected tag 0 but got " ++ show tag
+        | otherwise -> decodeResult codecConfig blockNodeToClientVersion blockQuery
+
+instance SameDepIndex (BlockQuery blk) => SameDepIndex (Query blk) where
+  sameDepIndex (BlockQuery blockQueryA) (BlockQuery blockQueryB)
+    = sameDepIndex blockQueryA blockQueryB
+
 deriving instance Show (BlockQuery blk result) => Show (Query blk result)
 
 -- | Answer the given query about the extended ledger state.

ouroboros-consensus/src/Ouroboros/Consensus/MiniProtocol/LocalStateQuery/Server.hs

@@ -21,18 +21,18 @@ localStateQueryServer ::
      -- ^ Get a past ledger
   -> STM m (Point blk)
      -- ^ Get the immutable point
-  -> LocalStateQueryServer blk (Point blk) (BlockQuery blk) m ()
+  -> LocalStateQueryServer blk (Point blk) (Query blk) m ()
 localStateQueryServer cfg getTipPoint getPastLedger getImmutablePoint =
     LocalStateQueryServer $ return idle
   where
-    idle :: ServerStIdle blk (Point blk) (BlockQuery blk) m ()
+    idle :: ServerStIdle blk (Point blk) (Query blk) m ()
     idle = ServerStIdle {
           recvMsgAcquire = handleAcquire
         , recvMsgDone    = return ()
         }
 
     handleAcquire :: Maybe (Point blk)
-                  -> m (ServerStAcquiring blk (Point blk) (BlockQuery blk) m ())
+                  -> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
     handleAcquire mpt = do
         (pt, mPastLedger, immutablePoint) <- atomically $ do
           pt <- maybe getTipPoint pure mpt
@@ -48,7 +48,7 @@ localStateQueryServer cfg getTipPoint getPastLedger getImmutablePoint =
             -> SendMsgFailure AcquireFailurePointNotOnChain idle
 
     acquired :: ExtLedgerState blk
-             -> ServerStAcquired blk (Point blk) (BlockQuery blk) m ()
+             -> ServerStAcquired blk (Point blk) (Query blk) m ()
     acquired ledgerState = ServerStAcquired {
           recvMsgQuery     = handleQuery ledgerState
         , recvMsgReAcquire = handleAcquire
@@ -57,9 +57,9 @@ localStateQueryServer cfg getTipPoint getPastLedger getImmutablePoint =
 
     handleQuery ::
          ExtLedgerState blk
-      -> BlockQuery blk result
-      -> m (ServerStQuerying blk (Point blk) (BlockQuery blk) m () result)
+      -> Query blk result
+      -> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
     handleQuery ledgerState query = return $
         SendMsgResult
-          (answerBlockQuery cfg query ledgerState)
+          (answerQuery cfg query ledgerState)
           (acquired ledgerState)