Merge #1507

1507: Implement the LocalStateQueryServer r=mrBliss a=mrBliss Closes #1366. Co-authored-by: Thomas Winant <[email protected]>
IntersectMBO · Jan 29, 2020 · 738e085 · 738e085
2 parents 86941cb + 0ec858c
commit 738e085
Show file tree

Hide file tree

Showing 34 changed files with 1,886 additions and 101 deletions.
diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -82,6 +82,7 @@ library
                        Ouroboros.Consensus.Ledger.Mock.Stake
                        Ouroboros.Consensus.Ledger.Mock.State
                        Ouroboros.Consensus.Ledger.Mock.UTxO
+                       Ouroboros.Consensus.LocalStateQueryServer
                        Ouroboros.Consensus.Mempool
                        Ouroboros.Consensus.Mempool.API
                        Ouroboros.Consensus.Mempool.Impl
@@ -147,6 +148,7 @@ library
                        Ouroboros.Storage.ChainDB.Impl.ChainSel
                        Ouroboros.Storage.ChainDB.Impl.ImmDB
                        Ouroboros.Storage.ChainDB.Impl.Iterator
+                       Ouroboros.Storage.ChainDB.Impl.LedgerCursor
                        Ouroboros.Storage.ChainDB.Impl.LgrDB
                        Ouroboros.Storage.ChainDB.Impl.Query
                        Ouroboros.Storage.ChainDB.Impl.Reader
@@ -294,6 +296,7 @@ test-suite test-consensus
                     Test.Consensus.ChainSyncClient
                     Test.Consensus.Ledger.Byron
                     Test.Consensus.Ledger.Mock
+                    Test.Consensus.LocalStateQueryServer
                     Test.Consensus.Mempool
                     Test.Consensus.Mempool.TestBlock
                     Test.Consensus.Mempool.TestTx

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds               #-}
 {-# LANGUAGE FlexibleContexts        #-}
 {-# LANGUAGE TypeFamilies            #-}
+{-# LANGUAGE TypeOperators           #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 
 -- | Interface to the ledger layer
@@ -13,16 +14,21 @@ module Ouroboros.Consensus.Ledger.Abstract (
   , BlockProtocol
   , ProtocolLedgerView(..)
   , AnachronyFailure(..)
+  , QueryLedger(..)
+  , ShowQuery(..)
   ) where
 
 import           Control.Monad.Except
+import           Data.Type.Equality ((:~:))
 import           GHC.Stack (HasCallStack)
 
 import           Cardano.Prelude (NoUnexpectedThunks)
 
 import           Ouroboros.Network.Block (ChainHash, HasHeader, Point, SlotNo,
                      pointHash, pointSlot)
 import           Ouroboros.Network.Point (WithOrigin)
+import           Ouroboros.Network.Protocol.LocalStateQuery.Type
+                     (ShowQuery (..))
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Protocol.Abstract
@@ -168,3 +174,19 @@ data AnachronyFailure
   = TooFarAhead
   | TooFarBehind
   deriving (Eq,Show)
+
+-- | Query the ledger state.
+--
+-- Used by the LocalStateQuery protocol to allow clients to query the ledger
+-- state.
+class (UpdateLedger blk, ShowQuery (Query blk)) => QueryLedger blk where
+
+  -- | Different queries supported by the ledger, indexed by the result type.
+  data family Query  blk :: * -> *
+
+  -- | Answer the given query about the ledger state.
+  answerQuery :: Query blk result -> LedgerState blk -> result
+
+  -- | Generalisation of value-level equality of two queries.
+  eqQuery :: Query blk result1 -> Query blk result2
+          -> Maybe (result1 :~: result2)
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Ledger.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Ledger.hs
@@ -1,9 +1,11 @@
 {-# LANGUAGE DeriveAnyClass      #-}
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE FlexibleInstances   #-}
-{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving  #-}
 {-# LANGUAGE TypeFamilies        #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -13,10 +15,15 @@ module Ouroboros.Consensus.Ledger.Byron.Ledger (
     -- * Ledger integration
     LedgerConfig(..)
   , LedgerState(..)
+  , Query(..)
   , initByronLedgerState
     -- * Serialisation
   , encodeByronLedgerState
   , decodeByronLedgerState
+  , encodeByronQuery
+  , decodeByronQuery
+  , encodeByronResult
+  , decodeByronResult
     -- * Auxiliary
   , validationErrorImpossible
   ) where
@@ -30,20 +37,24 @@ import           Control.Monad.Except
 import           Data.ByteString (ByteString)
 import           Data.Sequence (Seq)
 import qualified Data.Sequence as Seq.Lazy
+import           Data.Type.Equality ((:~:) (Refl))
 import           GHC.Generics (Generic)
 
 import           Cardano.Prelude (NoUnexpectedThunks)
 
+import           Cardano.Binary (fromCBOR, toCBOR)
 import qualified Cardano.Chain.Block as CC
 import qualified Cardano.Chain.Delegation as Delegation
 import qualified Cardano.Chain.Delegation.Validation.Scheduling as D.Sched
 import qualified Cardano.Chain.Genesis as Gen
-import qualified Cardano.Chain.ValidationMode as CC
+import qualified Cardano.Chain.Update.Validation.Interface as UPI
 import qualified Cardano.Chain.UTxO as CC
+import qualified Cardano.Chain.ValidationMode as CC
 
 import           Ouroboros.Network.Block (Point (..), SlotNo (..), blockSlot)
 import           Ouroboros.Network.Point (WithOrigin (..))
 import qualified Ouroboros.Network.Point as Point
+import           Ouroboros.Network.Protocol.LocalStateQuery.Codec (Some (..))
 
 import           Ouroboros.Consensus.Ledger.Abstract
 import qualified Ouroboros.Consensus.Ledger.Byron.Auxiliary as Aux
@@ -116,6 +127,21 @@ initByronLedgerState genesis mUtxo = ByronLedgerState {
     override Nothing     st = st
     override (Just utxo) st = st { CC.cvsUtxo = utxo }
 
+instance QueryLedger ByronBlock where
+  data Query ByronBlock :: * -> * where
+    GetUpdateInterfaceState :: Query ByronBlock UPI.State
+
+  answerQuery GetUpdateInterfaceState ledgerState =
+    CC.cvsUpdateState (byronLedgerState ledgerState)
+
+  eqQuery GetUpdateInterfaceState GetUpdateInterfaceState = Just Refl
+
+deriving instance Eq (Query ByronBlock result)
+deriving instance Show (Query ByronBlock result)
+
+instance ShowQuery (Query ByronBlock) where
+  showResult GetUpdateInterfaceState = show
+
 instance ConfigContainsGenesis (LedgerConfig ByronBlock) where
   getGenesisConfig = unByronLedgerConfig
 
@@ -310,3 +336,23 @@ decodeByronLedgerState = do
     ByronLedgerState
       <$> decode
       <*> History.decodeDelegationHistory
+
+encodeByronQuery :: Query ByronBlock result -> Encoding
+encodeByronQuery query = case query of
+    GetUpdateInterfaceState -> CBOR.encodeWord8 0
+
+decodeByronQuery :: Decoder s (Some (Query ByronBlock))
+decodeByronQuery = do
+    tag <- CBOR.decodeWord8
+    case tag of
+      0 -> return $ Some GetUpdateInterfaceState
+      _ -> fail $ "decodeByronQuery: invalid tag " <> show tag
+
+encodeByronResult :: Query ByronBlock result -> result -> Encoding
+encodeByronResult query = case query of
+    GetUpdateInterfaceState -> toCBOR
+
+decodeByronResult :: Query ByronBlock result
+                  -> forall s. Decoder s result
+decodeByronResult query = case query of
+    GetUpdateInterfaceState -> fromCBOR
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE ConstraintKinds         #-}
 {-# LANGUAGE DerivingStrategies      #-}
 {-# LANGUAGE DerivingVia             #-}
+{-# LANGUAGE EmptyCase               #-}
+{-# LANGUAGE EmptyDataDeriving       #-}
 {-# LANGUAGE FlexibleContexts        #-}
 {-# LANGUAGE FlexibleInstances       #-}
 {-# LANGUAGE LambdaCase              #-}
@@ -425,6 +427,22 @@ instance Bridge m a => ProtocolLedgerView (DualBlock m a) where
         (dualNodeConfigMain  cfg)
         (dualLedgerStateMain state)
 
+
+{-------------------------------------------------------------------------------
+  Querying the ledger
+-------------------------------------------------------------------------------}
+
+-- | Not used in the tests: no constructors
+instance Bridge m a => QueryLedger (DualBlock m a) where
+  data Query (DualBlock m a) result
+    deriving (Show)
+
+  answerQuery = \case {}
+  eqQuery     = \case {}
+
+instance ShowQuery (Query (DualBlock m a)) where
+  showResult = \case {}
+
 {-------------------------------------------------------------------------------
   Mempool support
 -------------------------------------------------------------------------------}

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block.hs
@@ -1,9 +1,12 @@
 {-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE EmptyCase                  #-}
+{-# LANGUAGE EmptyDataDeriving          #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE NamedFieldPuns             #-}
 {-# LANGUAGE RankNTypes                 #-}
@@ -324,6 +327,21 @@ mkSimpleGenTx tx = SimpleGenTx
     , simpleGenTxId = hash tx
     }
 
+{-------------------------------------------------------------------------------
+  Support for QueryLedger
+-------------------------------------------------------------------------------}
+
+instance (SimpleCrypto c, Typeable ext, SupportedBlock (SimpleBlock c ext))
+      => QueryLedger (SimpleBlock c ext) where
+  data Query (SimpleBlock c ext) result
+    deriving (Show)
+
+  answerQuery = \case {}
+  eqQuery     = \case {}
+
+instance ShowQuery (Query (SimpleBlock c ext)) where
+  showResult = \case {}
+
 {-------------------------------------------------------------------------------
   Crypto needed for simple blocks
 -------------------------------------------------------------------------------}

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/LocalStateQueryServer.hs b/ouroboros-consensus/src/Ouroboros/Consensus/LocalStateQueryServer.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Ouroboros.Consensus.LocalStateQueryServer
+  ( localStateQueryServer
+  ) where
+
+import           Data.Functor ((<&>))
+
+import           Ouroboros.Network.Protocol.LocalStateQuery.Server
+import           Ouroboros.Network.Protocol.LocalStateQuery.Type
+                     (AcquireFailure (..))
+
+import           Ouroboros.Network.Block (Point)
+
+import           Ouroboros.Consensus.Ledger.Abstract (LedgerState (..),
+                     QueryLedger (..))
+import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..))
+import           Ouroboros.Consensus.Util.IOLike
+
+import           Ouroboros.Storage.ChainDB (LedgerCursor (..),
+                     LedgerCursorFailure (..))
+
+localStateQueryServer
+  :: forall m blk. (IOLike m, QueryLedger blk)
+  => m (LedgerCursor m blk)
+  -> LocalStateQueryServer blk (Query blk) m ()
+localStateQueryServer newLedgerCursor =
+    LocalStateQueryServer $ idle <$> newLedgerCursor
+  where
+    idle
+      :: LedgerCursor m blk
+      -> ServerStIdle blk (Query blk) m ()
+    idle ledgerCursor = ServerStIdle
+      { recvMsgAcquire = handleAcquire ledgerCursor
+      , recvMsgDone    = return ()
+      }
+
+    handleAcquire
+      :: LedgerCursor m blk
+      -> Point blk
+      -> m (ServerStAcquiring blk (Query blk) m ())
+    handleAcquire ledgerCursor pt =
+      ledgerCursorMove ledgerCursor pt <&> \case
+        Left failure ->
+          SendMsgFailure (translateFailure failure) (idle ledgerCursor)
+        Right ExtLedgerState { ledgerState } ->
+          SendMsgAcquired (acquired ledgerState ledgerCursor)
+
+    acquired
+      :: LedgerState blk
+      -> LedgerCursor m blk
+      -> ServerStAcquired blk (Query blk) m ()
+    acquired ledgerState ledgerCursor = ServerStAcquired
+      { recvMsgQuery     = handleQuery ledgerState ledgerCursor
+      , recvMsgReAcquire = handleAcquire ledgerCursor
+      , recvMsgRelease   = return $ idle ledgerCursor
+      }
+
+    handleQuery
+      :: LedgerState blk
+      -> LedgerCursor m blk
+      -> Query blk result
+      -> m (ServerStQuerying blk (Query blk) m () result)
+    handleQuery ledgerState ledgerCursor query = return $
+      SendMsgResult
+        (answerQuery query ledgerState)
+        (acquired ledgerState ledgerCursor)
+
+    translateFailure
+      :: LedgerCursorFailure
+      -> AcquireFailure
+    translateFailure = \case
+      PointTooOld     -> AcquireFailurePointTooOld
+      PointNotOnChain -> AcquireFailurePointNotOnChain
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs
@@ -142,7 +142,7 @@ run tracers chainDbTracer diffusionTracers diffusionArguments networkMagic
       onNodeKernel registry nodeKernel
       let networkApps :: NetworkApplication
                            IO ConnectionId
-                           ByteString ByteString ByteString ByteString ByteString
+                           ByteString ByteString ByteString ByteString ByteString ByteString
                            ()
           networkApps = consensusNetworkApps
             nodeKernel

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Abstract.hs
@@ -21,6 +21,7 @@ import           Cardano.Crypto (ProtocolMagicId)
 import           Ouroboros.Network.Block (BlockNo, HeaderHash, SlotNo)
 import           Ouroboros.Network.BlockFetch (SizeInBytes)
 import           Ouroboros.Network.Magic (NetworkMagic)
+import           Ouroboros.Network.Protocol.LocalStateQuery.Codec (Some (..))
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.BlockchainTime (SystemStart)
@@ -38,6 +39,7 @@ import           Ouroboros.Storage.ImmutableDB (BinaryInfo (..), HashInfo)
 class ( ProtocolLedgerView blk
       , ApplyTx blk
       , HasTxId (GenTx blk)
+      , QueryLedger blk
       ) => RunNode blk where
 
   nodeForgeBlock          :: (HasNodeState (BlockProtocol blk) m, MonadRandom m)
@@ -127,6 +129,8 @@ class ( ProtocolLedgerView blk
   nodeEncodeLedgerState   :: NodeConfig (BlockProtocol blk) -> LedgerState blk -> Encoding
   nodeEncodeChainState    :: Proxy blk -> NodeConfig (BlockProtocol blk) -> ChainState (BlockProtocol blk) -> Encoding
   nodeEncodeApplyTxError  :: Proxy blk -> ApplyTxErr blk -> Encoding
+  nodeEncodeQuery         :: Query blk result -> Encoding
+  nodeEncodeResult        :: Query blk result -> result -> Encoding
 
   -- Decoders
   nodeDecodeHeader        :: forall s. NodeConfig (BlockProtocol blk) -> Decoder s (Lazy.ByteString -> Header blk)
@@ -137,3 +141,5 @@ class ( ProtocolLedgerView blk
   nodeDecodeLedgerState   :: forall s. NodeConfig (BlockProtocol blk) -> Decoder s (LedgerState blk)
   nodeDecodeChainState    :: forall s. Proxy blk -> NodeConfig (BlockProtocol blk) -> Decoder s (ChainState (BlockProtocol blk))
   nodeDecodeApplyTxError  :: forall s. Proxy blk -> Decoder s (ApplyTxErr blk)
+  nodeDecodeQuery         :: forall s. Decoder s (Some (Query blk))
+  nodeDecodeResult        :: Query blk result -> forall s. Decoder s result
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs
@@ -94,6 +94,8 @@ instance RunNode ByronBlock where
   nodeEncodeLedgerState     = const encodeByronLedgerState
   nodeEncodeChainState      = \_proxy _cfg -> encodeByronChainState
   nodeEncodeApplyTxError    = const encodeByronApplyTxError
+  nodeEncodeQuery           = encodeByronQuery
+  nodeEncodeResult          = encodeByronResult
 
   nodeDecodeBlock           = decodeByronBlock  . extractEpochSlots
   nodeDecodeHeader          = decodeByronHeader . extractEpochSlots
@@ -105,6 +107,9 @@ instance RunNode ByronBlock where
                                  let k = pbftSecurityParam $ pbftParams cfg
                                  in decodeByronChainState k
   nodeDecodeApplyTxError    = const decodeByronApplyTxError
+  nodeDecodeQuery           = decodeByronQuery
+  nodeDecodeResult          = decodeByronResult
+
 
 extractGenesisData :: NodeConfig ByronConsensusProtocol -> Genesis.GenesisData
 extractGenesisData = Genesis.configGenesisData . getGenesisConfig