Add GetPartialLedgerConfig query

IntersectMBO · Jun 14, 2021 · 860d8a3 · 860d8a3
1 parent a4203fb
commit 860d8a3
Showing 1 changed file with 72 additions and 23 deletions.
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Query.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Query.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes            #-}
@@ -29,6 +30,8 @@ import           Ouroboros.Network.Protocol.LocalStateQuery.Type
                      (ShowQuery (..))
 
 import           Ouroboros.Consensus.Block.Abstract (CodecConfig)
+import           Ouroboros.Consensus.Config (topLevelConfigLedger)
+import           Ouroboros.Consensus.HardFork.Combinator.PartialConfig
 import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Ledger.Query.Version
 import           Ouroboros.Consensus.Node.NetworkProtocolVersion
@@ -44,23 +47,32 @@ import           Ouroboros.Consensus.Util.DepPair
 
 -- | Different queries supported by the ledger for all block types, indexed
 -- by the result type.
-data Query blk result
-  = BlockQuery (BlockQuery blk result)
-  -- ^ This constructor is supported by all @QueryVersion@s. The @BlockQuery@
-  -- argument is versioned by the @BlockNodeToClientVersion blk@.
+data Query blk result where
+  BlockQuery :: BlockQuery blk result -> Query blk result
+  GetPartialLedgerConfig :: Query blk (PartialLedgerConfig blk)
 
 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
+  showResult query result = case query of
+    BlockQuery blockQuery  -> showResult blockQuery result
+    GetPartialLedgerConfig -> "PartialLedgerConfig {..}"
 
 instance Eq (SomeSecond BlockQuery blk) => Eq (SomeSecond Query blk) where
   SomeSecond (BlockQuery blockQueryA) == SomeSecond (BlockQuery blockQueryB)
     = SomeSecond blockQueryA == SomeSecond blockQueryB
+  SomeSecond (BlockQuery _) == SomeSecond _
+    = False
+  SomeSecond GetPartialLedgerConfig == SomeSecond GetPartialLedgerConfig
+    = True
+  SomeSecond GetPartialLedgerConfig == SomeSecond _
+    = False
 
 instance Show (SomeSecond BlockQuery blk) => Show (SomeSecond Query blk) where
-  show (SomeSecond (BlockQuery blockQueryA)) = "Query " ++ show (SomeSecond blockQueryA)
+  show (SomeSecond query) = case query of
+    BlockQuery blockQueryA -> "Query " ++ show (SomeSecond blockQueryA)
+    GetPartialLedgerConfig -> "GetPartialLedgerConfig"
 
 queryEncodeNodeToClient ::
      forall blk. SerialiseNodeToClient blk (SomeSecond BlockQuery blk)
@@ -71,17 +83,16 @@ queryEncodeNodeToClient ::
   -> Encoding
 queryEncodeNodeToClient codecConfig queryVersion blockVersion (SomeSecond query)
   = case queryVersion of
-    TopLevelQueryDisabled -> encodeBlockQuery
-      (case query of
-        BlockQuery blockQuery -> blockQuery
-      )
-  where
-    encodeBlockQuery blockQuery = encodeNodeToClient
-      @blk
-      @(SomeSecond BlockQuery blk)
-      codecConfig
-      blockVersion
-      (SomeSecond blockQuery)
+      TopLevelQueryDisabled -> case query of
+        BlockQuery blockQuery ->
+          encodeTag 0 <> encodeNodeToClient
+                          @blk
+                          @(SomeSecond BlockQuery blk)
+                          codecConfig
+                          blockVersion
+                          (SomeSecond blockQuery)
+        GetPartialLedgerConfig ->
+          encodeTag 1
 
 queryDecodeNodeToClient ::
      forall blk. SerialiseNodeToClient blk (SomeSecond BlockQuery blk)
@@ -101,23 +112,61 @@ queryDecodeNodeToClient codecConfig queryVersion blockVersion
         blockVersion
       return (SomeSecond (BlockQuery blockQuery))
 
-instance SerialiseResult blk (BlockQuery blk) => SerialiseResult blk (Query blk) where
-  encodeResult codecConfig blockVersion (BlockQuery blockQuery) result
-    = encodeResult codecConfig blockVersion blockQuery result
-
-  decodeResult codecConfig blockVersion (BlockQuery query)
-    = decodeResult codecConfig blockVersion query
+instance SerialiseNodeToClient blk (SomeSecond BlockQuery blk) => SerialiseNodeToClient blk (SomeSecond Query blk) where
+  encodeNodeToClient codecConfig blockVersion (SomeSecond query)
+    = case query of
+      BlockQuery blockQuery ->
+        encodeTag 0 <> encodeNodeToClient
+                        @blk
+                        @(SomeSecond BlockQuery blk)
+                        codecConfig
+                        blockVersion
+                        (SomeSecond blockQuery)
+      GetPartialLedgerConfig ->
+        encodeTag 1
+
+  decodeNodeToClient codecConfig blockVersion = do
+    tag <- decodeTag
+    case tag of
+      0 -> do
+        SomeSecond x <- decodeNodeToClient
+            @blk
+            @(SomeSecond BlockQuery blk)
+            codecConfig
+            blockVersion
+        return (SomeSecond (BlockQuery x))
+      1 -> return (SomeSecond GetPartialLedgerConfig)
+      _ -> fail $ "SomeSecond Query blk: unknown tag " ++ show tag
+
+instance ( SerialiseResult blk (BlockQuery blk)
+         , SerialiseNodeToClient blk (PartialLedgerConfig blk)
+         ) => SerialiseResult blk (Query blk) where
+  encodeResult codecConfig blockVersion query result = case query of
+    BlockQuery blockQuery -> encodeResult codecConfig blockVersion blockQuery result
+    GetPartialLedgerConfig -> encodeNodeToClient codecConfig blockVersion result
+
+  decodeResult codecConfig blockVersion query = case query of
+    BlockQuery blockQuery -> decodeResult codecConfig blockVersion blockQuery
+    GetPartialLedgerConfig -> decodeNodeToClient codecConfig blockVersion
 
 instance SameDepIndex (BlockQuery blk) => SameDepIndex (Query blk) where
   sameDepIndex (BlockQuery blockQueryA) (BlockQuery blockQueryB)
     = sameDepIndex blockQueryA blockQueryB
+  sameDepIndex (BlockQuery _) _
+    = Nothing
+  sameDepIndex GetPartialLedgerConfig GetPartialLedgerConfig
+    = Just Refl
+  sameDepIndex GetPartialLedgerConfig _
+    = Nothing
 
 deriving instance Show (BlockQuery blk result) => Show (Query blk result)
 
 -- | Answer the given query about the extended ledger state.
 answerQuery :: QueryLedger blk => ExtLedgerCfg blk -> Query blk result -> ExtLedgerState blk -> result
 answerQuery cfg query st = case query of
   BlockQuery blockQuery -> answerBlockQuery cfg blockQuery st
+  GetPartialLedgerConfig -> undefined "TODO_add_this_to_the_HasPartialLedgerConfig_class"
+    $ topLevelConfigLedger $ getExtLedgerCfg cfg
 
 -- | Different queries supported by the ledger, indexed by the result type.
 data family BlockQuery blk :: Type -> Type