From a3d596dcd2b213b1b504624ffcd2a613492bbc37 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Thu, 23 Jan 2020 16:21:16 +0100 Subject: [PATCH 01/11] LocalStateQuery: rename header type variable to block Querying the ledger state can only happen for a ledger state corresponding to a block, not to a ledger. --- .../Network/Protocol/LocalStateQuery/Type.hs | 46 +++++++++---------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Type.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Type.hs index 58ad208bb98..6c84e420782 100644 --- a/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Type.hs +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Type.hs @@ -21,83 +21,83 @@ import Ouroboros.Network.Block (Point, StandardHash) -- | The kind of the local state query protocol, and the types of -- the states in the protocol state machine. -- --- It is parametrised over the type of header (for points), the type of queries +-- It is parametrised over the type of block (for points), the type of queries -- and query results. -- -data LocalStateQuery header query result where +data LocalStateQuery block query result where -- | The client has agency. It can ask to acquire a state or terminate. -- -- There is no timeout in this state. -- - StIdle :: LocalStateQuery header query result + StIdle :: LocalStateQuery block query result -- | The server has agency. it must acquire the state at the requested point -- or report a failure. -- -- There is a timeout in this state. -- - StAcquiring :: LocalStateQuery header query result + StAcquiring :: LocalStateQuery block query result -- | The client has agency. It can request queries against the current state, -- or it can release the state. -- - StAcquired :: LocalStateQuery header query result + StAcquired :: LocalStateQuery block query result -- | The server has agency. It must respond with the query result. -- - StQuerying :: LocalStateQuery header query result + StQuerying :: LocalStateQuery block query result -- | Nobody has agency. The terminal state. -- - StDone :: LocalStateQuery header query result + StDone :: LocalStateQuery block query result -instance Protocol (LocalStateQuery header query result) where +instance Protocol (LocalStateQuery block query result) where -- | The messages in the state query protocol. -- -- The pattern of use is to -- - data Message (LocalStateQuery header query result) from to where + data Message (LocalStateQuery block query result) from to where -- | The client requests that the state as of a particular recent point on -- the server's chain (within K of the tip) be made available to query, -- and waits for confirmation or failure. -- MsgAcquire - :: Point header - -> Message (LocalStateQuery header query result) StIdle StAcquiring + :: Point block + -> Message (LocalStateQuery block query result) StIdle StAcquiring -- | The server can confirm that it has the state at the requested point. -- MsgAcquired - :: Message (LocalStateQuery header query result) StAcquiring StAcquired + :: Message (LocalStateQuery block query result) StAcquiring StAcquired -- | The server can report that it cannot obtain the state for the -- requested point. -- MsgFailure :: AcquireFailure - -> Message (LocalStateQuery header query result) StAcquiring StIdle + -> Message (LocalStateQuery block query result) StAcquiring StIdle -- | The client can perform queries on the current acquired state. -- MsgQuery :: query - -> Message (LocalStateQuery header query result) StAcquired StQuerying + -> Message (LocalStateQuery block query result) StAcquired StQuerying -- | The server must reply with the query results. -- MsgResult :: result - -> Message (LocalStateQuery header query result) StQuerying StAcquired + -> Message (LocalStateQuery block query result) StQuerying StAcquired -- | The client can instruct the server to release the state. This lets -- the server free resources. -- MsgRelease - :: Message (LocalStateQuery header query result) StAcquired StIdle + :: Message (LocalStateQuery block query result) StAcquired StIdle -- | This is like 'MsgAcquire' but for when the client already has a -- state. By moveing to another state directly without a 'MsgRelease' it @@ -108,13 +108,13 @@ instance Protocol (LocalStateQuery header query result) where -- rather than keeping the exiting acquired state. -- MsgReAcquire - :: Point header - -> Message (LocalStateQuery header query result) StAcquired StAcquiring + :: Point block + -> Message (LocalStateQuery block query result) StAcquired StAcquiring -- | The client can terminate the protocol. -- MsgDone - :: Message (LocalStateQuery header query result) StIdle StDone + :: Message (LocalStateQuery block query result) StIdle StDone data ClientHasAgency st where @@ -140,13 +140,13 @@ data AcquireFailure = AcquireFailurePointTooOld | AcquireFailurePointNotOnChain deriving (Eq, Enum, Show) -deriving instance (StandardHash header, Show query, Show result) => - Show (Message (LocalStateQuery header query result) from to) +deriving instance (StandardHash block, Show query, Show result) => + Show (Message (LocalStateQuery block query result) from to) -instance Show (ClientHasAgency (st :: LocalStateQuery header query result)) where +instance Show (ClientHasAgency (st :: LocalStateQuery block query result)) where show TokIdle = "TokIdle" show TokAcquired = "TokAcquired" -instance Show (ServerHasAgency (st :: LocalStateQuery header query result)) where +instance Show (ServerHasAgency (st :: LocalStateQuery block query result)) where show TokAcquiring = "TokAcquiring" show TokQuerying = "TokQuerying" From 27a3a1e19f36f9ca98c04cde2d01df5f9ac23907 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Fri, 24 Jan 2020 13:00:24 +0100 Subject: [PATCH 02/11] Add missing components of Ouroboros.Network.Protocol.LocalStateQuery --- ouroboros-network/ouroboros-network.cabal | 7 + .../Protocol/LocalStateQuery/Direct.hs | 61 ++++ .../Network/Protocol/LocalStateQuery/Test.hs | 334 ++++++++++++++++++ .../Protocol/LocalStateQuery/Client.hs | 138 ++++++++ .../Network/Protocol/LocalStateQuery/Codec.hs | 175 +++++++++ .../Protocol/LocalStateQuery/Examples.hs | 101 ++++++ .../Protocol/LocalStateQuery/Server.hs | 134 +++++++ 7 files changed, 950 insertions(+) create mode 100644 ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/LocalStateQuery/Direct.hs create mode 100644 ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs create mode 100644 ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Client.hs create mode 100644 ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Codec.hs create mode 100644 ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Examples.hs create mode 100644 ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Server.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 128d08c8eff..bb4e9ba3d76 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -94,6 +94,11 @@ library Ouroboros.Network.Protocol.Handshake.Type Ouroboros.Network.Protocol.Handshake.Codec Ouroboros.Network.Protocol.Handshake.Version + Ouroboros.Network.Protocol.LocalStateQuery.Client + Ouroboros.Network.Protocol.LocalStateQuery.Codec + -- LocalStateQuery.Examples module is needed by test-consensus + Ouroboros.Network.Protocol.LocalStateQuery.Examples + Ouroboros.Network.Protocol.LocalStateQuery.Server Ouroboros.Network.Protocol.LocalStateQuery.Type Ouroboros.Network.Protocol.LocalTxMonitor.Type Ouroboros.Network.Protocol.TxSubmission.Type @@ -181,6 +186,8 @@ library ouroboros-protocol-tests Ouroboros.Network.Protocol.ChainSync.ExamplesPipelined Ouroboros.Network.Protocol.ChainSync.Test Ouroboros.Network.Protocol.Handshake.Test + Ouroboros.Network.Protocol.LocalStateQuery.Direct + Ouroboros.Network.Protocol.LocalStateQuery.Test Ouroboros.Network.Protocol.LocalTxSubmission.Direct Ouroboros.Network.Protocol.LocalTxSubmission.Examples Ouroboros.Network.Protocol.LocalTxSubmission.Test diff --git a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/LocalStateQuery/Direct.hs b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/LocalStateQuery/Direct.hs new file mode 100644 index 00000000000..0f582ce03b2 --- /dev/null +++ b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/LocalStateQuery/Direct.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Ouroboros.Network.Protocol.LocalStateQuery.Direct ( + direct + ) where + +import Ouroboros.Network.Protocol.LocalStateQuery.Client +import Ouroboros.Network.Protocol.LocalStateQuery.Server + +direct + :: forall block query result m a b. + Monad m + => LocalStateQueryClient block query result m a + -> LocalStateQueryServer block query result m b + -> m (a, b) +direct (LocalStateQueryClient client) (LocalStateQueryServer mserver) = + mserver >>= directIdle client + where + directIdle + :: ClientStIdle block query result m a + -> ServerStIdle block query result m b + -> m (a, b) + directIdle (SendMsgAcquire pt client') ServerStIdle{recvMsgAcquire} = do + server' <- recvMsgAcquire pt + directAcquiring client' server' + directIdle (SendMsgDone a) ServerStIdle{recvMsgDone} = do + b <- recvMsgDone + return (a, b) + + directAcquiring + :: ClientStAcquiring block query result m a + -> ServerStAcquiring block query result m b + -> m (a, b) + directAcquiring ClientStAcquiring{recvMsgAcquired} (SendMsgAcquired server') = + let client' = recvMsgAcquired + in directAcquired client' server' + directAcquiring ClientStAcquiring{recvMsgFailure} (SendMsgFailure failure server') = do + client' <- recvMsgFailure failure + directIdle client' server' + + directAcquired + :: ClientStAcquired block query result m a + -> ServerStAcquired block query result m b + -> m (a, b) + directAcquired (SendMsgQuery query client') ServerStAcquired{recvMsgQuery} = do + server' <- recvMsgQuery query + directQuerying client' server' + directAcquired (SendMsgReAcquire pt client') ServerStAcquired{recvMsgReAcquire} = do + server' <- recvMsgReAcquire pt + directAcquiring client' server' + directAcquired (SendMsgRelease client') ServerStAcquired{recvMsgRelease} = do + server' <- recvMsgRelease + directIdle client' server' + + directQuerying + :: ClientStQuerying block query result m a + -> ServerStQuerying block query result m b + -> m (a, b) + directQuerying ClientStQuerying{recvMsgResult} (SendMsgResult result server') = do + client' <- recvMsgResult result + directAcquired client' server' diff --git a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs new file mode 100644 index 00000000000..e38911f2794 --- /dev/null +++ b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +module Ouroboros.Network.Protocol.LocalStateQuery.Test (tests) where + +import Data.ByteString.Lazy (ByteString) +import Data.Map (Map) +import qualified Data.Map as Map + +import GHC.Generics (Generic) + +import Control.Monad.Class.MonadAsync (MonadAsync) +import Control.Monad.Class.MonadST (MonadST) +import Control.Monad.Class.MonadThrow (MonadCatch) +import Control.Monad.IOSim +import Control.Monad.ST (runST) +import Control.Tracer (nullTracer) + +import Codec.Serialise (Serialise) +import qualified Codec.Serialise as Serialise (decode, encode) + +import Network.TypedProtocol.Channel +import Network.TypedProtocol.Codec.Cbor hiding (prop_codec) +import Network.TypedProtocol.Driver +import Network.TypedProtocol.Proofs + +import Ouroboros.Network.Channel + +import Ouroboros.Network.Block (ChainHash (..), SlotNo, StandardHash, + pointHash, pointSlot) +import Ouroboros.Network.MockChain.Chain (Point) +import Ouroboros.Network.Point (WithOrigin (..)) +import Ouroboros.Network.Testing.ConcreteBlock (Block) + +import Ouroboros.Network.Protocol.LocalStateQuery.Client +import Ouroboros.Network.Protocol.LocalStateQuery.Codec +import Ouroboros.Network.Protocol.LocalStateQuery.Direct +import Ouroboros.Network.Protocol.LocalStateQuery.Examples +import Ouroboros.Network.Protocol.LocalStateQuery.Server +import Ouroboros.Network.Protocol.LocalStateQuery.Type + +import Test.ChainGenerators () +import Test.Ouroboros.Network.Testing.Utils (prop_codec_cborM, + splits2, splits3) + +import Test.QuickCheck as QC hiding (Result) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Text.Show.Functions () + + +-- +-- Test cases +-- + +tests :: TestTree +tests = + testGroup "Ouroboros.Network.Protocol.LocalStateQuery" + [ testProperty "direct" prop_direct + , testProperty "connect" prop_connect + , testProperty "codec" prop_codec + , testProperty "codec 2-splits" prop_codec_splits2 + , testProperty "codec 3-splits" $ withMaxSuccess 30 + prop_codec_splits3 + , testProperty "codec cbor" prop_codec_cbor + , testProperty "channel ST" prop_channel_ST + , testProperty "channel IO" prop_channel_IO + , testProperty "pipe IO" prop_pipe_IO + ] + + +-- +-- Common types & clients and servers used in the tests in this module. +-- + +data Query + = QuerySlot + | QueryHash + deriving (Eq, Show, Generic, Serialise) + +data Result + = ResultSlot (WithOrigin SlotNo) + | ResultHash (ChainHash Block) + deriving (Eq, Show, Generic, Serialise) + +-- | Information to test an example server and client. +data Setup = Setup + { clientInput :: [(Point Block, [Query])] + -- ^ Input for 'localStateQueryClient' + , serverAcquire :: Point Block -> Either AcquireFailure (Point Block) + -- ^ First input parameter for 'localStateQueryServer' + , serverAnswer :: Point Block -> Query -> Result + -- ^ Second input parameter for 'localStateQueryServer' + , expected :: [(Point Block, Either AcquireFailure [Result])] + -- ^ Expected result for the 'localStateQueryClient'. + } + +mkSetup + :: Map (Point Block) (Maybe AcquireFailure, [Query]) + -- ^ For each point, the given state queries will be executed. In case of + -- the second field is an 'AcquireFailure', the server will fail with + -- that failure. + -- + -- This is the randomly generated input for the 'Setup'. + -> Setup +mkSetup input = Setup { + clientInput = [(pt, qs) | (pt, (_, qs)) <- Map.toList input] + , serverAcquire = \pt -> case Map.lookup pt input of + Just (Just failure, _qs) -> Left failure + Just (Nothing, _qs) -> Right pt + Nothing -> error $ + "a point not in the input was tried to be acquired: " <> show pt + , serverAnswer = answer + , expected = + [ (pt, res) + | (pt, (mbFailure, qs)) <- Map.toList input + , let res = case mbFailure of + Nothing -> Right $ map (answer pt) qs + Just failure -> Left failure + ] + } + where + answer pt q = case q of + QuerySlot -> ResultSlot $ pointSlot pt + QueryHash -> ResultHash $ pointHash pt + + +-- +-- Properties going directly, not via Peer. +-- + +-- | Run a simple local state query client and server, directly on the wrappers, +-- without going via the 'Peer'. +-- +prop_direct :: Map (Point Block) (Maybe AcquireFailure, [Query]) -> Property +prop_direct input = + runSimOrThrow + (direct + (localStateQueryClient clientInput) + (localStateQueryServer serverAcquire serverAnswer)) + === + (expected, ()) + where + Setup { clientInput, serverAcquire, serverAnswer, expected } = mkSetup input + + +-- +-- Properties going via Peer, but without using a channel +-- + +-- | Run a simple local state query client and server, going via the 'Peer' +-- representation, but without going via a channel. +-- +prop_connect :: Map (Point Block) (Maybe AcquireFailure, [Query]) -> Property +prop_connect input = + case runSimOrThrow + (connect + (localStateQueryClientPeer $ + localStateQueryClient clientInput) + (localStateQueryServerPeer $ + localStateQueryServer serverAcquire serverAnswer)) of + + (result, (), TerminalStates TokDone TokDone) -> result === expected + where + Setup { clientInput, serverAcquire, serverAnswer, expected } = mkSetup input + + +-- +-- Properties using a channel +-- + +-- | Run a local state query client and server using connected channels. +-- +prop_channel :: (MonadAsync m, MonadCatch m, MonadST m) + => m (Channel m ByteString, Channel m ByteString) + -> Map (Point Block) (Maybe AcquireFailure, [Query]) + -> m Property +prop_channel createChannels input = + + ((expected, ()) ===) <$> + + runConnectedPeers + createChannels + nullTracer + codec + (localStateQueryClientPeer $ + localStateQueryClient clientInput) + (localStateQueryServerPeer $ + localStateQueryServer serverAcquire serverAnswer) + where + Setup { clientInput, serverAcquire, serverAnswer, expected } = mkSetup input + +-- | Run 'prop_channel' in the simulation monad. +-- +prop_channel_ST :: Map (Point Block) (Maybe AcquireFailure, [Query]) -> Property +prop_channel_ST input = + runSimOrThrow + (prop_channel createConnectedChannels input) + +-- | Run 'prop_channel' in the IO monad. +-- +prop_channel_IO :: Map (Point Block) (Maybe AcquireFailure, [Query]) -> Property +prop_channel_IO input = + ioProperty (prop_channel createConnectedChannels input) + +-- | Run 'prop_channel' in the IO monad using local pipes. +-- +prop_pipe_IO :: Map (Point Block) (Maybe AcquireFailure, [Query]) -> Property +prop_pipe_IO input = + ioProperty (prop_channel createPipeConnectedChannels input) + + +-- +-- Codec properties +-- + +instance Arbitrary AcquireFailure where + arbitrary = elements + [ AcquireFailurePointTooOld + , AcquireFailurePointNotOnChain + ] + +instance Arbitrary Query where + arbitrary = elements [QuerySlot, QueryHash] + +instance Arbitrary Result where + arbitrary = oneof + [ ResultSlot <$> frequency + [ (1, pure Origin) + , (9, At <$> arbitrary) + ] + , ResultHash <$> frequency + [ (1, pure GenesisHash) + , (9, BlockHash <$> arbitrary) + ] + ] + +instance Arbitrary (AnyMessageAndAgency (LocalStateQuery Block Query Result)) where + arbitrary = oneof + [ AnyMessageAndAgency (ClientAgency TokIdle) <$> + (MsgAcquire <$> arbitrary) + + , AnyMessageAndAgency (ServerAgency TokAcquiring) <$> + pure MsgAcquired + + , AnyMessageAndAgency (ServerAgency TokAcquiring) <$> + (MsgFailure <$> arbitrary) + + , AnyMessageAndAgency (ClientAgency TokAcquired) <$> + (MsgQuery <$> arbitrary) + + , AnyMessageAndAgency (ServerAgency TokQuerying) <$> + (MsgResult <$> arbitrary) + + , AnyMessageAndAgency (ClientAgency TokAcquired) <$> + pure MsgRelease + + , AnyMessageAndAgency (ClientAgency TokAcquired) <$> + (MsgReAcquire <$> arbitrary) + + , AnyMessageAndAgency (ClientAgency TokIdle) <$> + pure MsgDone + ] + +instance (StandardHash block, Show query, Show result) => + Show (AnyMessageAndAgency (LocalStateQuery block query result)) where + show (AnyMessageAndAgency _ msg) = show msg + +instance (StandardHash block, Eq query, Eq result) => + Eq (AnyMessage (LocalStateQuery block query result)) where + + (==) (AnyMessage (MsgAcquire pt)) + (AnyMessage (MsgAcquire pt')) = pt == pt' + + (==) (AnyMessage MsgAcquired) + (AnyMessage MsgAcquired) = True + + (==) (AnyMessage (MsgFailure failure)) + (AnyMessage (MsgFailure failure')) = failure == failure' + + (==) (AnyMessage (MsgQuery query)) + (AnyMessage (MsgQuery query')) = query == query' + + (==) (AnyMessage (MsgResult result)) + (AnyMessage (MsgResult result')) = result == result' + + (==) (AnyMessage MsgRelease) + (AnyMessage MsgRelease) = True + + (==) (AnyMessage (MsgReAcquire pt)) + (AnyMessage (MsgReAcquire pt')) = pt == pt' + + (==) (AnyMessage MsgDone) + (AnyMessage MsgDone) = True + + _ == _ = False + + +codec :: MonadST m + => Codec (LocalStateQuery Block Query Result) + DeserialiseFailure + m ByteString +codec = codecLocalStateQuery + Serialise.encode Serialise.decode + Serialise.encode Serialise.decode + Serialise.encode Serialise.decode + +-- | Check the codec round trip property. +-- +prop_codec :: AnyMessageAndAgency (LocalStateQuery Block Query Result) -> Bool +prop_codec msg = + runST (prop_codecM codec msg) + +-- | Check for data chunk boundary problems in the codec using 2 chunks. +-- +prop_codec_splits2 :: AnyMessageAndAgency (LocalStateQuery Block Query Result) -> Bool +prop_codec_splits2 msg = + runST (prop_codec_splitsM splits2 codec msg) + +-- | Check for data chunk boundary problems in the codec using 3 chunks. +-- +prop_codec_splits3 :: AnyMessageAndAgency (LocalStateQuery Block Query Result) -> Bool +prop_codec_splits3 msg = + runST (prop_codec_splitsM splits3 codec msg) + +prop_codec_cbor + :: AnyMessageAndAgency (LocalStateQuery Block Query Result) + -> Bool +prop_codec_cbor msg = + runST (prop_codec_cborM codec msg) diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Client.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Client.hs new file mode 100644 index 00000000000..36c62f19c66 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Client.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Ouroboros.Network.Protocol.LocalStateQuery.Client ( + -- * Protocol type for the client + -- | The protocol states from the point of view of the client. + LocalStateQueryClient(..) + , ClientStIdle(..) + , ClientStAcquiring(..) + , ClientStAcquired(..) + , ClientStQuerying(..) + + -- * Execution as a typed protocol + , localStateQueryClientPeer + ) where + +import Network.TypedProtocol.Core + +import Ouroboros.Network.Block (Point) +import Ouroboros.Network.Protocol.LocalStateQuery.Type + + +newtype LocalStateQueryClient block query result m a = LocalStateQueryClient { + runLocalStateQueryClient :: ClientStIdle block query result m a + } + +-- | In the 'StIdle' protocol state, the client has agency and must send: +-- +-- * a request to acquire a state +-- * a termination messge +-- +data ClientStIdle block query result (m :: * -> *) a where + SendMsgAcquire :: Point block + -> ClientStAcquiring block query result m a + -> ClientStIdle block query result m a + + SendMsgDone :: a + -> ClientStIdle block query result m a + +-- | In the 'StAcquiring' protocol state, the client does not have agency. +-- Instead it is waiting for: +-- +-- * acquired +-- * failure to acquire +-- +-- It must be prepared to handle either. +-- +data ClientStAcquiring block query result m a = ClientStAcquiring { + recvMsgAcquired :: ClientStAcquired block query result m a, + + recvMsgFailure :: AcquireFailure + -> m (ClientStIdle block query result m a) + } + +-- | In the 'StAcquired' protocol state, the client has agency and must send: +-- +-- * a query +-- * a request to (re)acquire another state +-- * a release of the current state +-- +data ClientStAcquired block query result m a where + SendMsgQuery :: query + -> ClientStQuerying block query result m a + -> ClientStAcquired block query result m a + + SendMsgReAcquire :: Point block + -> ClientStAcquiring block query result m a + -> ClientStAcquired block query result m a + + SendMsgRelease :: ClientStIdle block query result m a + -> ClientStAcquired block query result m a + +-- | In the 'StQuerying' protocol state, the client does not have agency. +-- Instead it is waiting for: +-- +-- * a result +-- +data ClientStQuerying block query result m a = ClientStQuerying { + recvMsgResult :: result -> m (ClientStAcquired block query result m a) + } + +-- | Interpret a 'LocalStateQueryClient' action sequence as a 'Peer' on the +-- client side of the 'LocalStateQuery' protocol. +-- +localStateQueryClientPeer + :: forall block query result m a. + Monad m + => LocalStateQueryClient block query result m a + -> Peer (LocalStateQuery block query result) AsClient StIdle m a +localStateQueryClientPeer (LocalStateQueryClient handler) = + handleStIdle handler + where + handleStIdle + :: ClientStIdle block query result m a + -> Peer (LocalStateQuery block query result) AsClient StIdle m a + handleStIdle req = case req of + SendMsgAcquire pt stAcquiring -> + Yield (ClientAgency TokIdle) + (MsgAcquire pt) + (handleStAcquiring stAcquiring) + SendMsgDone a -> + Yield (ClientAgency TokIdle) + MsgDone + (Done TokDone a) + + handleStAcquiring + :: ClientStAcquiring block query result m a + -> Peer (LocalStateQuery block query result) AsClient StAcquiring m a + handleStAcquiring ClientStAcquiring{recvMsgAcquired, recvMsgFailure} = + Await (ServerAgency TokAcquiring) $ \req -> case req of + MsgAcquired -> handleStAcquired recvMsgAcquired + MsgFailure failure -> Effect $ handleStIdle <$> recvMsgFailure failure + + handleStAcquired + :: ClientStAcquired block query result m a + -> Peer (LocalStateQuery block query result) AsClient StAcquired m a + handleStAcquired req = case req of + SendMsgQuery query stQuerying -> + Yield (ClientAgency TokAcquired) + (MsgQuery query) + (handleStQuerying stQuerying) + SendMsgReAcquire pt stAcquiring -> + Yield (ClientAgency TokAcquired) + (MsgReAcquire pt) + (handleStAcquiring stAcquiring) + SendMsgRelease stIdle -> + Yield (ClientAgency TokAcquired) + MsgRelease + (handleStIdle stIdle) + + handleStQuerying + :: ClientStQuerying block query result m a + -> Peer (LocalStateQuery block query result) AsClient StQuerying m a + handleStQuerying ClientStQuerying{recvMsgResult} = + Await (ServerAgency TokQuerying) $ \req -> case req of + MsgResult result -> Effect (handleStAcquired <$> recvMsgResult result) diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Codec.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Codec.hs new file mode 100644 index 00000000000..9f6104040b8 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Codec.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Ouroboros.Network.Protocol.LocalStateQuery.Codec ( + codecLocalStateQuery + , codecLocalStateQueryId + ) where + +import Control.Monad.Class.MonadST + +import qualified Codec.CBOR.Decoding as CBOR +import qualified Codec.CBOR.Encoding as CBOR +import qualified Codec.CBOR.Read as CBOR +import Data.ByteString.Lazy (ByteString) + +import Network.TypedProtocol.Codec.Cbor + +import Ouroboros.Network.Protocol.LocalStateQuery.Type + +import Ouroboros.Network.Block (Point) + +codecLocalStateQuery + :: forall block query result m. + MonadST m + => (Point block -> CBOR.Encoding) + -> (forall s . CBOR.Decoder s (Point block)) + -> (query -> CBOR.Encoding) + -> (forall s . CBOR.Decoder s query) + -> (result -> CBOR.Encoding) + -> (forall s . CBOR.Decoder s result) + -> Codec (LocalStateQuery block query result) CBOR.DeserialiseFailure m ByteString +codecLocalStateQuery encodePoint decodePoint + encodeQuery decodeQuery + encodeResult decodeResult = + mkCodecCborLazyBS encode decode + where + encodeFailure :: AcquireFailure -> CBOR.Encoding + encodeFailure AcquireFailurePointTooOld = CBOR.encodeWord8 0 + encodeFailure AcquireFailurePointNotOnChain = CBOR.encodeWord8 1 + + decodeFailure :: forall s. CBOR.Decoder s AcquireFailure + decodeFailure = do + tag <- CBOR.decodeWord8 + case tag of + 0 -> return AcquireFailurePointTooOld + 1 -> return AcquireFailurePointNotOnChain + _ -> fail $ "decodeFailure: invalid tag " <> show tag + + encode :: forall (pr :: PeerRole) st st'. + PeerHasAgency pr st + -> Message (LocalStateQuery block query result) st st' + -> CBOR.Encoding + encode (ClientAgency TokIdle) (MsgAcquire pt) = + CBOR.encodeListLen 2 + <> CBOR.encodeWord 0 + <> encodePoint pt + + encode (ServerAgency TokAcquiring) MsgAcquired = + CBOR.encodeListLen 1 + <> CBOR.encodeWord 1 + + encode (ServerAgency TokAcquiring) (MsgFailure failure) = + CBOR.encodeListLen 2 + <> CBOR.encodeWord 2 + <> encodeFailure failure + + encode (ClientAgency TokAcquired) (MsgQuery query) = + CBOR.encodeListLen 2 + <> CBOR.encodeWord 3 + <> encodeQuery query + + encode (ServerAgency TokQuerying) (MsgResult result) = + CBOR.encodeListLen 2 + <> CBOR.encodeWord 4 + <> encodeResult result + + encode (ClientAgency TokAcquired) MsgRelease = + CBOR.encodeListLen 1 + <> CBOR.encodeWord 5 + + encode (ClientAgency TokAcquired) (MsgReAcquire pt) = + CBOR.encodeListLen 2 + <> CBOR.encodeWord 6 + <> encodePoint pt + + encode (ClientAgency TokIdle) MsgDone = + CBOR.encodeListLen 1 + <> CBOR.encodeWord 7 + + decode :: forall (pr :: PeerRole) s (st :: LocalStateQuery block query result). + PeerHasAgency pr st + -> CBOR.Decoder s (SomeMessage st) + decode stok = do + len <- CBOR.decodeListLen + key <- CBOR.decodeWord + case (stok, len, key) of + (ClientAgency TokIdle, 2, 0) -> do + pt <- decodePoint + return (SomeMessage (MsgAcquire pt)) + + (ServerAgency TokAcquiring, 1, 1) -> + return (SomeMessage MsgAcquired) + + (ServerAgency TokAcquiring, 2, 2) -> do + failure <- decodeFailure + return (SomeMessage (MsgFailure failure)) + + (ClientAgency TokAcquired, 2, 3) -> do + query <- decodeQuery + return (SomeMessage (MsgQuery query)) + + (ServerAgency TokQuerying, 2, 4) -> do + result <- decodeResult + return (SomeMessage (MsgResult result)) + + (ClientAgency TokAcquired, 1, 5) -> + return (SomeMessage MsgRelease) + + (ClientAgency TokAcquired, 2, 6) -> do + pt <- decodePoint + return (SomeMessage (MsgReAcquire pt)) + + (ClientAgency TokIdle, 1, 7) -> + return (SomeMessage MsgDone) + + (ClientAgency TokIdle, _, _) -> + fail "codecLocalStateQuery.Idle: unexpected key" + (ClientAgency TokAcquired, _, _) -> + fail "codecLocalStateQuery.Acquired: unexpected key" + (ServerAgency TokAcquiring, _, _) -> + fail "codecLocalStateQuery.Acquiring: unexpected key" + (ServerAgency TokQuerying, _, _) -> + fail "codecLocalStateQuery.Querying: unexpected key" + + +-- | An identity 'Codec' for the 'LocalStateQuery' protocol. It does not do +-- any serialisation. It keeps the typed messages, wrapped in 'AnyMessage'. +-- +codecLocalStateQueryId + :: forall block query result m. + Monad m + => Codec (LocalStateQuery block query result) + CodecFailure m + (AnyMessage (LocalStateQuery block query result)) +codecLocalStateQueryId = + Codec encode decode + where + encode :: forall (pr :: PeerRole) st st'. + PeerHasAgency pr st + -> Message (LocalStateQuery block query result) st st' + -> AnyMessage (LocalStateQuery block query result) + encode _ = AnyMessage + + decode :: forall (pr :: PeerRole) st. + PeerHasAgency pr st + -> m (DecodeStep (AnyMessage (LocalStateQuery block query result)) + CodecFailure m (SomeMessage st)) + decode stok = return $ DecodePartial $ \bytes -> case (stok, bytes) of + (ClientAgency TokIdle, Just (AnyMessage msg@(MsgAcquire{}))) -> res msg + (ClientAgency TokIdle, Just (AnyMessage msg@(MsgDone{}))) -> res msg + (ClientAgency TokAcquired, Just (AnyMessage msg@(MsgQuery{}))) -> res msg + (ClientAgency TokAcquired, Just (AnyMessage msg@(MsgReAcquire{}))) -> res msg + (ClientAgency TokAcquired, Just (AnyMessage msg@(MsgRelease{}))) -> res msg + (ServerAgency TokAcquiring, Just (AnyMessage msg@(MsgAcquired{}))) -> res msg + (ServerAgency TokAcquiring, Just (AnyMessage msg@(MsgFailure{}))) -> res msg + (ServerAgency TokQuerying, Just (AnyMessage msg@(MsgResult{}))) -> res msg + (_, Nothing) -> return (DecodeFail CodecFailureOutOfInput) + (_, _) -> return (DecodeFail (CodecFailure failmsg)) + + res :: Message (LocalStateQuery block query result) st st' -> m (DecodeStep bytes failure m (SomeMessage st)) + res msg = return (DecodeDone (SomeMessage msg) Nothing) + failmsg = "codecLocalStateQueryId: no matching message" diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Examples.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Examples.hs new file mode 100644 index 00000000000..0db20696eda --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Examples.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Ouroboros.Network.Protocol.LocalStateQuery.Examples where + +import Ouroboros.Network.Block (Point) + +import Ouroboros.Network.Protocol.LocalStateQuery.Client +import Ouroboros.Network.Protocol.LocalStateQuery.Server +import Ouroboros.Network.Protocol.LocalStateQuery.Type + (AcquireFailure (..)) + + +-- +-- Example client +-- + +-- | An example 'LocalStateQueryClient', which, for each point in the given +-- list, acquires the state for that point, and if that succeeds, returns the +-- results for all the corresponding queries. When the state could not be +-- acquired, the 'AcquireFailure' is returned instead of the query results. +-- +localStateQueryClient + :: forall block query result m. Applicative m + => [(Point block, [query])] + -> LocalStateQueryClient block query result m + [(Point block, Either AcquireFailure [result])] +localStateQueryClient = LocalStateQueryClient . goIdle [] + where + goIdle + :: [(Point block, Either AcquireFailure [result])] -- ^ Accumulator + -> [(Point block, [query])] -- ^ Remainder + -> ClientStIdle block query result m + [(Point block, Either AcquireFailure [result])] + goIdle acc [] = SendMsgDone $ reverse acc + goIdle acc ((pt, qs):ptqss') = SendMsgAcquire pt $ + goAcquiring acc pt qs ptqss' + + goAcquiring + :: [(Point block, Either AcquireFailure [result])] -- ^ Accumulator + -> Point block + -> [query] + -> [(Point block, [query])] -- ^ Remainder + -> ClientStAcquiring block query result m + [(Point block, Either AcquireFailure [result])] + goAcquiring acc pt qs ptqss' = ClientStAcquiring { + recvMsgAcquired = goQuery [] qs $ \rs -> goAcquired ((pt, Right rs):acc) ptqss' + , recvMsgFailure = \failure -> pure $ goIdle ((pt, Left failure):acc) ptqss' + } + + goAcquired + :: [(Point block, Either AcquireFailure [result])] + -> [(Point block, [query])] -- ^ Remainder + -> ClientStAcquired block query result m + [(Point block, Either AcquireFailure [result])] + goAcquired acc [] = SendMsgRelease $ SendMsgDone $ reverse acc + goAcquired acc ((pt, qs):ptqss') = SendMsgReAcquire pt $ + goAcquiring acc pt qs ptqss' + + goQuery + :: forall a. + [result] -- ^ Result accumulator + -> [query] + -> ([result] -> ClientStAcquired block query result m a) + -- ^ Continuation + -> ClientStAcquired block query result m a + goQuery acc [] k = k (reverse acc) + goQuery acc (q:qs') k = SendMsgQuery q $ ClientStQuerying $ \r -> + pure $ goQuery (r:acc) qs' k + +-- +-- Example server +-- + +-- | An example 'LocalStateQueryServer'. The first function is called to +-- acquire a @state@, after which the second will be used to query the state. +-- +localStateQueryServer + :: forall block query result m state. Applicative m + => (Point block -> Either AcquireFailure state) + -> (state -> query -> result) + -> LocalStateQueryServer block query result m () +localStateQueryServer acquire answer = + LocalStateQueryServer $ pure goIdle + where + goIdle :: ServerStIdle block query result m () + goIdle = ServerStIdle { + recvMsgAcquire = goAcquiring + , recvMsgDone = pure () + } + + goAcquiring :: Point block -> m (ServerStAcquiring block query result m ()) + goAcquiring pt = pure $ case acquire pt of + Left failure -> SendMsgFailure failure goIdle + Right state -> SendMsgAcquired $ goAcquired state + + goAcquired :: state -> ServerStAcquired block query result m () + goAcquired state = ServerStAcquired { + recvMsgQuery = \query -> + pure $ SendMsgResult (answer state query) $ goAcquired state + , recvMsgReAcquire = goAcquiring + , recvMsgRelease = pure goIdle + } diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Server.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Server.hs new file mode 100644 index 00000000000..71118579f7f --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Server.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Ouroboros.Network.Protocol.LocalStateQuery.Server ( + -- * Protocol type for the server + -- | The protocol states from the point of view of the server. + LocalStateQueryServer(..) + , ServerStIdle(..) + , ServerStAcquiring(..) + , ServerStAcquired(..) + , ServerStQuerying(..) + + -- * Execution as a typed protocol + , localStateQueryServerPeer + ) where + +import Network.TypedProtocol.Core + +import Ouroboros.Network.Block (Point) +import Ouroboros.Network.Protocol.LocalStateQuery.Type + + +newtype LocalStateQueryServer block query result m a = LocalStateQueryServer { + runLocalStateQueryServer :: m (ServerStIdle block query result m a) + } + +-- | In the 'StIdle' protocol state, the server does not have agency. Instead +-- it is waiting for: +-- +-- * a request to acquire a state +-- * a termination messge +-- +-- It must be prepared to handle either. +-- +data ServerStIdle block query result m a = ServerStIdle { + recvMsgAcquire :: Point block + -> m (ServerStAcquiring block query result m a), + + recvMsgDone :: m a + } + +-- | In the 'StAcquiring' protocol state, the server has agency and must send +-- either: +-- +-- * acquired +-- * failure to acquire +-- +data ServerStAcquiring block query result m a where + SendMsgAcquired :: ServerStAcquired block query result m a + -> ServerStAcquiring block query result m a + + SendMsgFailure :: AcquireFailure + -> ServerStIdle block query result m a + -> ServerStAcquiring block query result m a + +-- | In the 'StAcquired' protocol state, the server does not have agency. Instead +-- it is waiting for: +-- +-- * a query +-- * a request to (re)acquire another state +-- * a release of the current state +-- +-- It must be prepared to handle either. +-- +data ServerStAcquired block query result m a = ServerStAcquired { + recvMsgQuery :: query + -> m (ServerStQuerying block query result m a), + + recvMsgReAcquire :: Point block + -> m (ServerStAcquiring block query result m a), + + recvMsgRelease :: m (ServerStIdle block query result m a) + } + +-- | In the 'StQuerying' protocol state, the server has agency and must send: +-- +-- * a result +-- +data ServerStQuerying block query result m a where + SendMsgResult :: result + -> ServerStAcquired block query result m a + -> ServerStQuerying block query result m a + +-- | Interpret a 'LocalStateQueryServer' action sequence as a 'Peer' on the server +-- side of the 'LocalStateQuery' protocol. +-- +localStateQueryServerPeer + :: forall block query result m a. + Monad m + => LocalStateQueryServer block query result m a + -> Peer (LocalStateQuery block query result) AsServer StIdle m a +localStateQueryServerPeer (LocalStateQueryServer handler) = + Effect $ handleStIdle <$> handler + where + handleStIdle + :: ServerStIdle block query result m a + -> Peer (LocalStateQuery block query result) AsServer StIdle m a + handleStIdle ServerStIdle{recvMsgAcquire, recvMsgDone} = + Await (ClientAgency TokIdle) $ \req -> case req of + MsgAcquire pt -> Effect $ + handleStAcquiring <$> recvMsgAcquire pt + MsgDone -> Effect $ + Done TokDone <$> recvMsgDone + + handleStAcquiring + :: ServerStAcquiring block query result m a + -> Peer (LocalStateQuery block query result) AsServer StAcquiring m a + handleStAcquiring req = case req of + SendMsgAcquired stAcquired -> + Yield (ServerAgency TokAcquiring) + MsgAcquired + (handleStAcquired stAcquired) + SendMsgFailure failure stIdle -> + Yield (ServerAgency TokAcquiring) + (MsgFailure failure) + (handleStIdle stIdle) + + handleStAcquired + :: ServerStAcquired block query result m a + -> Peer (LocalStateQuery block query result) AsServer StAcquired m a + handleStAcquired ServerStAcquired{recvMsgQuery, recvMsgReAcquire, recvMsgRelease} = + Await (ClientAgency TokAcquired) $ \req -> case req of + MsgQuery query -> Effect $ handleStQuerying <$> recvMsgQuery query + MsgReAcquire pt -> Effect $ handleStAcquiring <$> recvMsgReAcquire pt + MsgRelease -> Effect $ handleStIdle <$> recvMsgRelease + + handleStQuerying + :: ServerStQuerying block query result m a + -> Peer (LocalStateQuery block query result) AsServer StQuerying m a + handleStQuerying (SendMsgResult result stAcquired) = + Yield (ServerAgency TokQuerying) + (MsgResult result) + (handleStAcquired stAcquired) From 82d889d0823c0ee127a36c97ed13d3a54d9322af Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Fri, 24 Jan 2020 12:34:40 +0100 Subject: [PATCH 03/11] ChainDB: add LedgerCursor abstraction This new abstraction replaces `getPastLedger` and can, in the future, allow for more efficient rolling forward. For example, when requesting a ledger state 100 blocks after some ledger snapshot we have in memory, we'll need to apply 100 blocks to the ledger. This won't change with the `LedgerCursor` abstraction, but if we then starting rolling forward and requesting the ledger states 101, 102, 103, ... blocks after our in-memory ledger snapshot, we only have to apply one block each time, instead of having to apply 101, 102, 103, ... blocks each time! This optimisation has not yet been implemented, but by introducing the abstraction now, we can later implement it without having to change the API. --- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../src/Ouroboros/Storage/ChainDB/API.hs | 63 ++++++++++++++++--- .../src/Ouroboros/Storage/ChainDB/Impl.hs | 6 +- .../Storage/ChainDB/Impl/LedgerCursor.hs | 54 ++++++++++++++++ .../Ouroboros/Storage/ChainDB/Impl/Query.hs | 6 -- .../Test/Ouroboros/Storage/ChainDB/Mock.hs | 12 +++- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 54 +++++++++++++++- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 4 +- 8 files changed, 175 insertions(+), 25 deletions(-) create mode 100644 ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/LedgerCursor.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 918416c2432..d10ee17f12a 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -147,6 +147,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 diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/API.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/API.hs index 986d62fde28..aec57025914 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/API.hs @@ -40,6 +40,10 @@ module Ouroboros.Storage.ChainDB.API ( , UnknownRange(..) , validBounds , streamAll + -- * Ledger Cursor API + , LedgerCursor(..) + , LedgerCursorFailure(..) + , getPastLedger -- * Invalid block reason , InvalidBlockReason(..) -- * Readers @@ -154,16 +158,6 @@ data ChainDB m blk = ChainDB { -- | Get current ledger , getCurrentLedger :: STM m (ExtLedgerState blk) - -- | Get past ledger - -- - -- This cannot live in STM, because the ledger DB does not store all - -- ledger snapshots, and so getting a past ledger DB may involve reading - -- from disk. - -- - -- Requests for ledger states for points not on the current chain, or for - -- points older than @k@, will return 'Nothing'. - , getPastLedger :: Point blk -> m (Maybe (ExtLedgerState blk)) - -- | Get block at the tip of the chain, if one exists -- -- Returns 'Nothing' if the database is empty. @@ -276,6 +270,10 @@ data ChainDB m blk = ChainDB { -> BlockComponent (ChainDB m blk) b -> m (Reader m blk b) + -- | Get a ledger cursor that is focused on the ledger corresponding to + -- the tip of the current chain (see 'getCurrentLedger'). + , newLedgerCursor :: m (LedgerCursor m blk) + -- | Function to check whether a block is known to be invalid. -- -- Blocks unknown to the ChainDB will result in 'False'. @@ -525,6 +523,51 @@ streamAll chainDB registry = do Left e -> error (show e) Right it -> return $ Just it +{------------------------------------------------------------------------------- + Ledger cursor API +-------------------------------------------------------------------------------} + +-- | A potentially more efficient way to obtain past ledger snapshots. +-- +-- NOTE: a 'LedgerCursor' currently allocates no resources that need explicit +-- cleanup, so there is no @ledgerCursorClose@ operation. +data LedgerCursor m blk = LedgerCursor { + ledgerCursorState :: m (ExtLedgerState blk) + -- ^ The ledger state the cursor is pointing at. + , ledgerCursorMove :: Point blk + -> m (Either LedgerCursorFailure (ExtLedgerState blk)) + -- ^ Move the ledger cursor to the given point. + -- + -- This cannot live in STM, because the ledger DB does not store all + -- ledger snapshots, and so getting a past ledger DB may involve reading + -- from disk. + -- + -- When the cursor could not be moved to the given point, a + -- 'LedgerCursorFailure' is returned, otherwise the request ledger state + -- is returned. + } + +-- | Returned in case 'LedgerCursorMove' failed. +data LedgerCursorFailure + = PointTooOld + -- ^ The given point corresponds to a block older than @k@. + -- + -- It might also /not/ be on the chain. + | PointNotOnChain + -- ^ The given point is not on the chain. + deriving (Eq, Show) + +-- | Utility function to get the ledger state at the given point. +-- +-- Is a combination of 'newLedgerCursor' and 'ledgerCursorMove'. +-- +-- See the docstring of 'newLedgerCursor' for more information. +getPastLedger :: Monad m + => ChainDB m blk -> Point blk -> m (Maybe (ExtLedgerState blk)) +getPastLedger chainDB pt = do + cursor <- newLedgerCursor chainDB + either (const Nothing) Just <$> ledgerCursorMove cursor pt + {------------------------------------------------------------------------------- Invalid block reason -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl.hs index b0de9215d99..fde7e724abf 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl.hs @@ -57,6 +57,7 @@ import qualified Ouroboros.Storage.ChainDB.Impl.Background as Background import qualified Ouroboros.Storage.ChainDB.Impl.ChainSel as ChainSel import qualified Ouroboros.Storage.ChainDB.Impl.ImmDB as ImmDB import qualified Ouroboros.Storage.ChainDB.Impl.Iterator as Iterator +import qualified Ouroboros.Storage.ChainDB.Impl.LedgerCursor as LedgerCursor import qualified Ouroboros.Storage.ChainDB.Impl.LgrDB as LgrDB import qualified Ouroboros.Storage.ChainDB.Impl.Query as Query import qualified Ouroboros.Storage.ChainDB.Impl.Reader as Reader @@ -170,7 +171,6 @@ openDBInternal args launchBgTasks = do { addBlock = getEnv1 h ChainSel.addBlock , getCurrentChain = getEnvSTM h Query.getCurrentChain , getCurrentLedger = getEnvSTM h Query.getCurrentLedger - , getPastLedger = getEnv1 h Query.getPastLedger , getTipBlock = getEnv h Query.getTipBlock , getTipHeader = getEnv h Query.getTipHeader , getTipPoint = getEnvSTM h Query.getTipPoint @@ -180,6 +180,10 @@ openDBInternal args launchBgTasks = do , getMaxSlotNo = getEnvSTM h Query.getMaxSlotNo , stream = Iterator.stream h , newReader = Reader.newReader h (Args.cdbEncodeHeader args) + , newLedgerCursor = getEnv h $ \env' -> + LedgerCursor.newLedgerCursor + (cdbLgrDB env') + (castPoint . AF.anchorPoint <$> Query.getCurrentChain env') , getIsInvalidBlock = getEnvSTM h Query.getIsInvalidBlock , closeDB = Reopen.closeDB h , isOpen = Reopen.isOpen h diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/LedgerCursor.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/LedgerCursor.hs new file mode 100644 index 00000000000..043698ea197 --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/LedgerCursor.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wredundant-constraints #-} +module Ouroboros.Storage.ChainDB.Impl.LedgerCursor + ( newLedgerCursor + ) where + +import Ouroboros.Network.Block (Point, pointSlot) + +import Ouroboros.Consensus.Ledger.Abstract (ProtocolLedgerView) +import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) +import Ouroboros.Consensus.Util.IOLike + +import Ouroboros.Storage.ChainDB.API (LedgerCursor (..), + LedgerCursorFailure (..)) +import Ouroboros.Storage.ChainDB.Impl.LgrDB (LgrDB) +import qualified Ouroboros.Storage.ChainDB.Impl.LgrDB as LgrDB + +newLedgerCursor + :: forall m blk. (IOLike m, ProtocolLedgerView blk) + => LgrDB m blk + -> STM m (Point blk) + -- ^ Get the immutable point + -> m (LedgerCursor m blk) +newLedgerCursor lgrDB getImmutablePoint = + toCursor =<< atomically (LgrDB.getCurrentState lgrDB) + where + toCursor :: ExtLedgerState blk -> m (LedgerCursor m blk) + toCursor ledgerState = do + varLedgerState <- newTVarM ledgerState + return LedgerCursor + { ledgerCursorState = atomically $ readTVar varLedgerState + , ledgerCursorMove = \pt -> + -- TODO optimise this so that the current snapshot can be used + -- when rolling forward. + LgrDB.getPastState lgrDB pt >>= \case + Nothing -> do + -- Look at the immutable point, i.e., the point @k@ blocks + -- back, to figure out why we couldn't get access to the + -- requested ledger. + -- + -- Note that the current chain might have changed since we + -- asked for it, but it's just to provide an error message, so + -- it's not the end of the world if we report the wrong + -- reason. + immutablePoint <- atomically getImmutablePoint + return $ Left $ if pointSlot pt < pointSlot immutablePoint + then PointTooOld + else PointNotOnChain + Just ledgerState' -> do + atomically $ writeTVar varLedgerState ledgerState' + return $ Right ledgerState' + } diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Query.hs index d73bafab218..bb72360f79d 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Query.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Query.hs @@ -8,7 +8,6 @@ module Ouroboros.Storage.ChainDB.Impl.Query ( -- * Queries getCurrentChain , getCurrentLedger - , getPastLedger , getTipBlock , getTipHeader , getTipPoint @@ -37,7 +36,6 @@ import Ouroboros.Network.Block (BlockNo, ChainHash (..), HasHeader, pointSlot) import Ouroboros.Consensus.Block -import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Util.IOLike @@ -84,10 +82,6 @@ getCurrentChain CDB{..} = getCurrentLedger :: IOLike m => ChainDbEnv m blk -> STM m (ExtLedgerState blk) getCurrentLedger CDB{..} = LgrDB.getCurrentState cdbLgrDB -getPastLedger :: (IOLike m, UpdateLedger blk) - => ChainDbEnv m blk -> Point blk -> m (Maybe (ExtLedgerState blk)) -getPastLedger CDB{..} = LgrDB.getPastState cdbLgrDB - getTipBlock :: forall m blk. (IOLike m, HasHeader blk, HasHeader (Header blk)) => ChainDbEnv m blk diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Mock.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Mock.hs index 7beea3707ed..dae88079a43 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Mock.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Mock.hs @@ -26,8 +26,8 @@ import Ouroboros.Consensus.Util.STM (blockUntilJust) import Ouroboros.Storage.ChainDB.API -import Test.Ouroboros.Storage.ChainDB.Model (IteratorId, Model, - ModelSupportsBlock, ReaderId) +import Test.Ouroboros.Storage.ChainDB.Model (IteratorId, + LedgerCursorId, Model, ModelSupportsBlock, ReaderId) import qualified Test.Ouroboros.Storage.ChainDB.Model as Model openDB :: forall m blk. ( @@ -113,13 +113,18 @@ openDB cfg initLedger btime = do (Maybe (ChainUpdate blk b), Model blk) readerInstruction' = Model.readerInstruction rdrId blockComponent + ledgerCursor :: LedgerCursorId -> LedgerCursor m blk + ledgerCursor lcId = LedgerCursor + { ledgerCursorState = query $ Model.ledgerCursorState lcId + , ledgerCursorMove = update . Model.ledgerCursorMove cfg lcId + } + void $ onSlotChange btime $ update_ . Model.advanceCurSlot cfg return ChainDB { addBlock = update_ . Model.addBlock cfg , getCurrentChain = querySTM $ Model.lastK k getHeader , getCurrentLedger = querySTM $ Model.currentLedger - , getPastLedger = query . Model.getPastLedger cfg , getBlockComponent = queryE .: Model.getBlockComponentByPoint , getTipBlock = query $ Model.tipBlock , getTipHeader = query $ (fmap getHeader . Model.tipBlock) @@ -130,6 +135,7 @@ openDB cfg initLedger btime = do , getMaxSlotNo = querySTM $ Model.maxSlotNo , stream = updateE ...: const (\bc from to -> fmap (first (fmap (iterator bc))) . Model.stream k from to) , newReader = update .: const (\bc -> (first (reader bc) . Model.newReader)) + , newLedgerCursor = update $ first ledgerCursor . Model.getLedgerCursor , closeDB = atomically $ modifyTVar db Model.closeDB , isOpen = Model.isOpen <$> readTVar db } diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs index a1d711fb3c5..9fadb56e528 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -17,6 +18,7 @@ module Test.Ouroboros.Storage.ChainDB.Model ( Model -- opaque , IteratorId , CPS.ReaderId + , LedgerCursorId -- * Construction , empty , addBlock @@ -48,6 +50,10 @@ module Test.Ouroboros.Storage.ChainDB.Model ( , readerInstruction , readerForward , readerClose + -- * Ledger Cursors + , getLedgerCursor + , ledgerCursorState + , ledgerCursorMove -- * ModelSupportsBlock , ModelSupportsBlock (..) -- * Exported for testing purposes @@ -83,7 +89,7 @@ import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as Fragment import Ouroboros.Network.Block (BlockNo, pattern BlockPoint, ChainHash (..), pattern GenesisPoint, HasHeader, - HeaderHash, MaxSlotNo (..), Point, SlotNo) + HeaderHash, MaxSlotNo (..), Point, SlotNo, pointSlot) import qualified Ouroboros.Network.Block as Block import Ouroboros.Network.MockChain.Chain (Chain (..), ChainUpdate) import qualified Ouroboros.Network.MockChain.Chain as Chain @@ -103,11 +109,14 @@ import Ouroboros.Consensus.Util.STM (Fingerprint (..), import Ouroboros.Storage.ChainDB.API (BlockComponent (..), ChainDB, ChainDbError (..), InvalidBlockReason (..), - IteratorResult (..), StreamFrom (..), StreamTo (..), - UnknownRange (..), validBounds) + IteratorResult (..), LedgerCursorFailure (..), + StreamFrom (..), StreamTo (..), UnknownRange (..), + validBounds) type IteratorId = Int +type LedgerCursorId = Int + -- | Model of the chain DB data Model blk = Model { blocks :: Map (HeaderHash blk) blk @@ -115,6 +124,7 @@ data Model blk = Model { , currentLedger :: ExtLedgerState blk , initLedger :: ExtLedgerState blk , iterators :: Map IteratorId [blk] + , ledgerCursors :: Map LedgerCursorId (ExtLedgerState blk) , invalid :: WithFingerprint (Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)) , currentSlot :: SlotNo , futureBlocks :: Map SlotNo [blk] @@ -285,6 +295,7 @@ empty initLedger = Model { , currentLedger = initLedger , initLedger = initLedger , iterators = Map.empty + , ledgerCursors = Map.empty , invalid = WithFingerprint Map.empty (Fingerprint 0) , currentSlot = 0 , futureBlocks = Map.empty @@ -355,6 +366,7 @@ addBlock cfg blk m , currentLedger = newLedger , initLedger = initLedger m , iterators = iterators m + , ledgerCursors = ledgerCursors m , invalid = WithFingerprint invalidBlocks' fingerprint' , currentSlot = currentSlot m , futureBlocks = futureBlocks m @@ -526,6 +538,42 @@ readerClose rdrId m | otherwise = m + +{------------------------------------------------------------------------------- + Ledger Cursors +-------------------------------------------------------------------------------} + +getLedgerCursor + :: forall blk. ProtocolLedgerView blk + => Model blk -> (LedgerCursorId, Model blk) +getLedgerCursor m@Model { ledgerCursors = lcs, currentLedger } = + (lcId, m { ledgerCursors = Map.insert lcId currentLedger lcs }) + where + lcId :: LedgerCursorId + lcId = Map.size lcs -- we never delete ledger cursors + +ledgerCursorState :: LedgerCursorId -> Model blk -> ExtLedgerState blk +ledgerCursorState lcId m + | Just ledgerState <- Map.lookup lcId (ledgerCursors m) + = ledgerState + | otherwise + = error $ "unknown ledgerCursor: " <> show lcId + +ledgerCursorMove + :: forall blk. ProtocolLedgerView blk + => NodeConfig (BlockProtocol blk) + -> LedgerCursorId + -> Point blk + -> Model blk + -> (Either LedgerCursorFailure (ExtLedgerState blk), Model blk) +ledgerCursorMove cfg lcId pt m@Model { ledgerCursors = lcs } + | Just ledgerState <- getPastLedger cfg pt m + = (Right ledgerState, m { ledgerCursors = Map.insert lcId ledgerState lcs }) + | pointSlot pt < immutableSlotNo (protocolSecurityParam cfg) m + = (Left PointTooOld, m) + | otherwise + = (Left PointNotOnChain, m) + {------------------------------------------------------------------------------- ModelSupportsBlock -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index 723e5ebdb7a..8ddcf6a953d 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs @@ -298,12 +298,12 @@ run :: forall m blk. (IOLike m, HasHeader blk) -> StrictTVar m Id -> Cmd blk (TestIterator m blk) (TestReader m blk) -> m (Success blk (TestIterator m blk) (TestReader m blk)) -run ChainDB{..} internal registry varCurSlot varNextId = \case +run chainDB@ChainDB{..} internal registry varCurSlot varNextId = \case AddBlock blk -> Unit <$> (advanceAndAdd (blockSlot blk) blk) AddFutureBlock blk s -> Unit <$> (advanceAndAdd s blk) GetCurrentChain -> Chain <$> atomically getCurrentChain GetCurrentLedger -> Ledger <$> atomically getCurrentLedger - GetPastLedger pt -> MbLedger <$> getPastLedger pt + GetPastLedger pt -> MbLedger <$> getPastLedger chainDB pt GetTipBlock -> MbBlock <$> getTipBlock GetTipHeader -> MbHeader <$> getTipHeader GetTipPoint -> Point <$> atomically getTipPoint From f3bb4d59287acd7c2490212e0fda9c756993dfc0 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Mon, 27 Jan 2020 16:37:28 +0100 Subject: [PATCH 04/11] Simplify LedgerState Test.Util.TestBlock It was storing both the last applied point (slot + hash) and hash. We only need to store the former. --- .../test-util/Test/Util/TestBlock.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/ouroboros-consensus/test-util/Test/Util/TestBlock.hs b/ouroboros-consensus/test-util/Test/Util/TestBlock.hs index 7db19b4ad5f..e3f04f3c25f 100644 --- a/ouroboros-consensus/test-util/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/test-util/Test/Util/TestBlock.hs @@ -272,13 +272,13 @@ data TestBlockError instance SupportedBlock TestBlock instance UpdateLedger TestBlock where - data LedgerState TestBlock = + newtype LedgerState TestBlock = TestLedger { -- The ledger state simply consists of the last applied block - lastAppliedPoint :: !(Point TestBlock) - , lastAppliedHash :: !(ChainHash TestBlock) + lastAppliedPoint :: Point TestBlock } - deriving (Show, Eq, Generic, Serialise, NoUnexpectedThunks) + deriving stock (Show, Eq, Generic) + deriving newtype (Serialise, NoUnexpectedThunks) data LedgerConfig TestBlock = LedgerConfig type LedgerError TestBlock = TestBlockError @@ -286,15 +286,14 @@ instance UpdateLedger TestBlock where applyChainTick _ _ = TickedLedgerState applyLedgerBlock _ tb@TestBlock{..} TestLedger{..} - | Block.blockPrevHash tb /= lastAppliedHash - = throwError $ InvalidHash lastAppliedHash (Block.blockPrevHash tb) + | Block.blockPrevHash tb /= Block.pointHash lastAppliedPoint + = throwError $ InvalidHash (Block.pointHash lastAppliedPoint) (Block.blockPrevHash tb) | not tbValid = throwError $ InvalidBlock | otherwise - = return $ TestLedger (Chain.blockPoint tb) (BlockHash (Block.blockHash tb)) + = return $ TestLedger (Chain.blockPoint tb) - reapplyLedgerBlock _ tb _ = - TestLedger (Chain.blockPoint tb) (BlockHash (Block.blockHash tb)) + reapplyLedgerBlock _ tb _ = TestLedger (Chain.blockPoint tb) ledgerTipPoint = lastAppliedPoint @@ -304,7 +303,7 @@ instance ProtocolLedgerView TestBlock where anachronisticProtocolLedgerView _ _ _ = Right () testInitLedger :: LedgerState TestBlock -testInitLedger = TestLedger Block.genesisPoint GenesisHash +testInitLedger = TestLedger Block.genesisPoint testInitExtLedger :: ExtLedgerState TestBlock testInitExtLedger = ExtLedgerState { From a8d2c6c455c6decd810e889b395d029702bf8676 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Fri, 24 Jan 2020 13:21:45 +0100 Subject: [PATCH 05/11] Add the QueryLedger type class and instances This will be used for the LocalStateQuery protocol. --- .../src/Ouroboros/Consensus/Ledger/Abstract.hs | 18 ++++++++++++++++++ .../Ouroboros/Consensus/Ledger/Byron/Ledger.hs | 17 ++++++++++++++++- .../src/Ouroboros/Consensus/Ledger/Dual.hs | 16 ++++++++++++++++ .../Ouroboros/Consensus/Ledger/Mock/Block.hs | 18 ++++++++++++++++++ .../test-util/Test/Util/TestBlock.hs | 13 ++++++++++++- 5 files changed, 80 insertions(+), 2 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs index f3b4abb0d62..aeaa389527e 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs @@ -13,6 +13,7 @@ module Ouroboros.Consensus.Ledger.Abstract ( , BlockProtocol , ProtocolLedgerView(..) , AnachronyFailure(..) + , QueryLedger(..) ) where import Control.Monad.Except @@ -168,3 +169,20 @@ 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 => QueryLedger blk where + + -- | Different queries supported by the ledger + data family Query blk :: * + + -- | The result types for the queries + data family Result blk :: * + -- TODO index Result by Query so that we always get the expected result + -- type? + + -- | Answer the given query about the ledger state. + answerQuery :: Query blk -> LedgerState blk -> Result blk diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Ledger.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Ledger.hs index 9c8cf3eff05..81080331efa 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Ledger.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Ledger.hs @@ -13,6 +13,8 @@ module Ouroboros.Consensus.Ledger.Byron.Ledger ( -- * Ledger integration LedgerConfig(..) , LedgerState(..) + , Query(..) + , Result(..) , initByronLedgerState -- * Serialisation , encodeByronLedgerState @@ -38,8 +40,9 @@ 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 (..)) @@ -116,6 +119,18 @@ initByronLedgerState genesis mUtxo = ByronLedgerState { override Nothing st = st override (Just utxo) st = st { CC.cvsUtxo = utxo } +instance QueryLedger ByronBlock where + data Query ByronBlock + = GetUpdateInterfaceState + deriving (Eq, Show) + + data Result ByronBlock + = UpdateInterfaceState UPI.State + deriving (Eq, Show) + + answerQuery GetUpdateInterfaceState ledgerState = + UpdateInterfaceState (CC.cvsUpdateState (byronLedgerState ledgerState)) + instance ConfigContainsGenesis (LedgerConfig ByronBlock) where getGenesisConfig = unByronLedgerConfig diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs index 88e2d705dd8..6d59b0caab7 100644 --- 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,20 @@ 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) + deriving (Show) + data Result (DualBlock m a) + deriving (Show) + + answerQuery q _ledgerState = case q of {} + {------------------------------------------------------------------------------- Mempool support -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block.hs index 1f58b316811..603930b5098 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -37,6 +38,9 @@ module Ouroboros.Consensus.Ledger.Mock.Block ( -- * 'ApplyTx' (mempool support) , GenTx(..) , mkSimpleGenTx + -- * 'QueryLedger' + , Query(..) + , Result(..) -- * Crypto , SimpleCrypto , SimpleStandardCrypto @@ -324,6 +328,20 @@ 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) = QueryLedgerTip + deriving (Show, Generic, Serialise) + data Result (SimpleBlock c ext) = ResultLedgerTip (Point (SimpleBlock c ext)) + deriving (Show, Generic, Serialise) + + answerQuery QueryLedgerTip (SimpleLedgerState MockState { mockTip }) = + ResultLedgerTip mockTip + {------------------------------------------------------------------------------- Crypto needed for simple blocks -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/test-util/Test/Util/TestBlock.hs b/ouroboros-consensus/test-util/Test/Util/TestBlock.hs index e3f04f3c25f..fd2507305a9 100644 --- a/ouroboros-consensus/test-util/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/test-util/Test/Util/TestBlock.hs @@ -22,6 +22,8 @@ module Test.Util.TestBlock ( , TestBlock(..) , TestBlockError(..) , Header(..) + , Query(..) + , Result(..) , firstBlock , successorBlock , modifyFork @@ -63,7 +65,7 @@ import qualified Data.Tree as Tree import Data.Word import GHC.Generics (Generic) import qualified System.Random as R -import Test.QuickCheck +import Test.QuickCheck hiding (Result) import Cardano.Crypto.DSIGN import Cardano.Prelude (NoUnexpectedThunks) @@ -302,6 +304,15 @@ instance ProtocolLedgerView TestBlock where protocolLedgerView _ _ = () anachronisticProtocolLedgerView _ _ _ = Right () +instance QueryLedger TestBlock where + data Query TestBlock = QueryLedgerTip + deriving (Eq, Show, Generic, Serialise) + data Result TestBlock = ResultLedgerTip (Point TestBlock) + deriving (Eq, Show, Generic, Serialise) + + answerQuery QueryLedgerTip (TestLedger { lastAppliedPoint }) = + ResultLedgerTip lastAppliedPoint + testInitLedger :: LedgerState TestBlock testInitLedger = TestLedger Block.genesisPoint From 799f2c9d9ec6e3c78ed75a9168ac7ec7aa857cb1 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Fri, 24 Jan 2020 13:00:53 +0100 Subject: [PATCH 06/11] Implement LocalStateQueryServer --- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../Consensus/LocalStateQueryServer.hs | 75 +++++++++++++++++++ 2 files changed, 76 insertions(+) create mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/LocalStateQueryServer.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index d10ee17f12a..919592ee3de 100644 --- 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 diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/LocalStateQueryServer.hs b/ouroboros-consensus/src/Ouroboros/Consensus/LocalStateQueryServer.hs new file mode 100644 index 00000000000..f4cc085d78f --- /dev/null +++ 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) (Result blk) m () +localStateQueryServer newLedgerCursor = + LocalStateQueryServer $ idle <$> newLedgerCursor + where + idle + :: LedgerCursor m blk + -> ServerStIdle blk (Query blk) (Result blk) m () + idle ledgerCursor = ServerStIdle + { recvMsgAcquire = handleAcquire ledgerCursor + , recvMsgDone = return () + } + + handleAcquire + :: LedgerCursor m blk + -> Point blk + -> m (ServerStAcquiring blk (Query blk) (Result 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) (Result 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 + -> m (ServerStQuerying blk (Query blk) (Result blk) m ()) + handleQuery ledgerState ledgerCursor query = return $ + SendMsgResult + (answerQuery query ledgerState) + (acquired ledgerState ledgerCursor) + + translateFailure + :: LedgerCursorFailure + -> AcquireFailure + translateFailure = \case + PointTooOld -> AcquireFailurePointTooOld + PointNotOnChain -> AcquireFailurePointNotOnChain From fa02d52b4b125772f30894a0acef4be4e895f4e0 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Mon, 27 Jan 2020 13:55:35 +0100 Subject: [PATCH 07/11] Add en/decoders for Query and Result --- .../Consensus/Ledger/Byron/Ledger.hs | 22 +++++++++++++++++++ .../Ouroboros/Consensus/Node/Run/Abstract.hs | 5 +++++ .../src/Ouroboros/Consensus/Node/Run/Byron.hs | 5 +++++ .../Ouroboros/Consensus/Node/Run/DualByron.hs | 6 +++++ .../src/Ouroboros/Consensus/Node/Run/Mock.hs | 4 ++++ 5 files changed, 42 insertions(+) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Ledger.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Ledger.hs index 81080331efa..93c9df88524 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Ledger.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron/Ledger.hs @@ -19,6 +19,10 @@ module Ouroboros.Consensus.Ledger.Byron.Ledger ( -- * Serialisation , encodeByronLedgerState , decodeByronLedgerState + , encodeByronQuery + , decodeByronQuery + , encodeByronResult + , decodeByronResult -- * Auxiliary , validationErrorImpossible ) where @@ -36,6 +40,7 @@ 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 @@ -325,3 +330,20 @@ decodeByronLedgerState = do ByronLedgerState <$> decode <*> History.decodeDelegationHistory + +encodeByronQuery :: Query ByronBlock -> Encoding +encodeByronQuery query = case query of + GetUpdateInterfaceState -> CBOR.encodeWord8 0 + +decodeByronQuery :: Decoder s (Query ByronBlock) +decodeByronQuery = do + tag <- CBOR.decodeWord8 + case tag of + 0 -> return GetUpdateInterfaceState + _ -> fail $ "decodeByronQuery: invalid tag " <> show tag + +encodeByronResult :: Result ByronBlock -> Encoding +encodeByronResult (UpdateInterfaceState state) = toCBOR state + +decodeByronResult :: Decoder s (Result ByronBlock) +decodeByronResult = UpdateInterfaceState <$> fromCBOR diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Abstract.hs index 82f62794ace..1e4fb5d2fd7 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Abstract.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Abstract.hs @@ -38,6 +38,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 +128,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 -> Encoding + nodeEncodeResult :: Result blk -> Encoding -- Decoders nodeDecodeHeader :: forall s. NodeConfig (BlockProtocol blk) -> Decoder s (Lazy.ByteString -> Header blk) @@ -137,3 +140,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 (Query blk) + nodeDecodeResult :: forall s. Decoder s (Result blk) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Byron.hs index f43c34ab2b5..c69ae0d9250 100644 --- 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 diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/DualByron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/DualByron.hs index 6ce739fa98d..8f2bef83007 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/DualByron.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/DualByron.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -88,6 +90,8 @@ instance RunNode DualByronBlock where nodeEncodeGenTx = encodeDualGenTx encodeByronGenTx nodeEncodeGenTxId = encodeDualGenTxId encodeByronGenTxId nodeEncodeChainState = \_proxy _cfg -> encodeByronChainState + nodeEncodeQuery = \case {} + nodeEncodeResult = \case {} -- Decoders nodeDecodeBlock = decodeDualBlock . decodeByronBlock . extractEpochSlots @@ -100,6 +104,8 @@ instance RunNode DualByronBlock where nodeDecodeChainState = \_proxy cfg -> let k = pbftSecurityParam $ pbftParams cfg in decodeByronChainState k + nodeDecodeQuery = error "DualByron.nodeDecodeQuery" + nodeDecodeResult = error "DualByron.nodeDecodeResult" extractEpochSlots :: NodeConfig DualByronProtocol -> EpochSlots extractEpochSlots = Byron.extractEpochSlots . dualNodeConfigMain diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Mock.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Mock.hs index 31ce8536b74..e65e6cd2f69 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Mock.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Mock.hs @@ -64,6 +64,8 @@ instance ( ProtocolLedgerView (SimpleBlock SimpleMockCrypto ext) nodeEncodeLedgerState = const encode nodeEncodeChainState = const mockEncodeChainState nodeEncodeApplyTxError = const encode + nodeEncodeQuery = encode + nodeEncodeResult = encode nodeDecodeBlock = const (const <$> decode) nodeDecodeHeader = const (const <$> decode) @@ -73,3 +75,5 @@ instance ( ProtocolLedgerView (SimpleBlock SimpleMockCrypto ext) nodeDecodeLedgerState = const decode nodeDecodeChainState = const mockDecodeChainState nodeDecodeApplyTxError = const decode + nodeDecodeQuery = decode + nodeDecodeResult = decode From b68852ba07788c0217c69b2f9a6b8cd871f73ab8 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Mon, 27 Jan 2020 13:50:13 +0100 Subject: [PATCH 08/11] Add roundtrip and golden tests for the serialisation of UPI.State As the `LocalStateQueryServer` will send this over the network in the form of `Result ByronBlock`, we must be careful not to break network compatibility with clients, hence the golden test. --- .../Test/Consensus/Ledger/Byron.hs | 75 +++++++++++++++++- .../test-consensus/golden/cbor/byron/UPIState | Bin 0 -> 137 bytes 2 files changed, 73 insertions(+), 2 deletions(-) create mode 100644 ouroboros-consensus/test-consensus/golden/cbor/byron/UPIState diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs b/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs index e6af6580ee8..79c4f7277dc 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs @@ -24,8 +24,10 @@ import Cardano.Binary (fromCBOR, toCBOR) import Cardano.Chain.Block (ABlockOrBoundary (..)) import qualified Cardano.Chain.Block as CC.Block import Cardano.Chain.Common (KeyHash) -import Cardano.Chain.Slotting (EpochSlots (..)) +import Cardano.Chain.Slotting (EpochNumber, EpochSlots (..), + SlotNumber) import qualified Cardano.Chain.Update as CC.Update +import qualified Cardano.Chain.Update.Validation.Interface as CC.UPI import Cardano.Crypto (ProtocolMagicId (..)) import Ouroboros.Network.Block (HeaderHash, SlotNo) @@ -45,7 +47,7 @@ import Ouroboros.Consensus.Protocol.PBFT.ChainState.HeaderHashBytes import Ouroboros.Storage.ImmutableDB (BinaryInfo (..), HashInfo (..)) -import Test.QuickCheck +import Test.QuickCheck hiding (Result) import Test.QuickCheck.Hedgehog (hedgehog) import Test.Tasty import Test.Tasty.Golden @@ -58,6 +60,7 @@ import qualified Test.Cardano.Chain.Common.Gen as CC import qualified Test.Cardano.Chain.Delegation.Gen as CC import qualified Test.Cardano.Chain.Genesis.Dummy as CC import qualified Test.Cardano.Chain.MempoolPayload.Gen as CC +import qualified Test.Cardano.Chain.Slotting.Gen as CC import qualified Test.Cardano.Chain.Update.Gen as CC import qualified Test.Cardano.Chain.UTxO.Example as CC import qualified Test.Cardano.Chain.UTxO.Gen as CC @@ -76,6 +79,8 @@ tests = testGroup "Byron" , testProperty "roundtrip GenTx" prop_roundtrip_GenTx , testProperty "roundtrip GenTxId" prop_roundtrip_GenTxId , testProperty "roundtrip ApplyTxErr" prop_roundtrip_ApplyTxErr + , testProperty "roundtrip Query" prop_roundtrip_Query + , testProperty "roundtrip Result" prop_roundtrip_Result ] -- TODO LedgerState @@ -94,6 +99,7 @@ tests = testGroup "Byron" , test_golden_ChainState_backwardsCompat_version2 , test_golden_LedgerState , test_golden_GenTxId + , test_golden_UPIState ] , testGroup "Integrity" @@ -172,6 +178,14 @@ prop_roundtrip_ApplyTxErr :: ApplyTxErr ByronBlock -> Property prop_roundtrip_ApplyTxErr = roundtrip encodeByronApplyTxError decodeByronApplyTxError +prop_roundtrip_Query :: Query ByronBlock -> Property +prop_roundtrip_Query = + roundtrip encodeByronQuery decodeByronQuery + +prop_roundtrip_Result :: Result ByronBlock -> Property +prop_roundtrip_Result = + roundtrip encodeByronResult decodeByronResult + {------------------------------------------------------------------------------- BinaryInfo -------------------------------------------------------------------------------} @@ -310,6 +324,16 @@ test_golden_GenTxId = goldenTestCBOR where exampleGenTxId = ByronTxId CC.exampleTxId +test_golden_UPIState :: TestTree +test_golden_UPIState = goldenTestCBOR + "CC.UPI.State" + toCBOR + exampleUPIState + "test-consensus/golden/cbor/byron/UPIState" + where + exampleUPIState = CC.UPI.initialState CC.dummyConfig + + goldenTestCBOR :: String -> (a -> Encoding) -> a -> FilePath -> TestTree goldenTestCBOR name enc a path = goldenVsString name path (return bs) @@ -493,3 +517,50 @@ instance Arbitrary ApplyMempoolPayloadErr where -- , MempoolUpdateProposalErr <$> arbitrary -- , MempoolUpdateVoteErr <$> arbitrary ] + +instance Arbitrary (Query ByronBlock) where + arbitrary = return GetUpdateInterfaceState + +instance Arbitrary EpochNumber where + arbitrary = hedgehog CC.genEpochNumber + +instance Arbitrary SlotNumber where + arbitrary = hedgehog CC.genSlotNumber + +instance Arbitrary CC.Update.UpId where + arbitrary = hedgehog (CC.genUpId protocolMagicId) + +instance Arbitrary CC.Update.ApplicationName where + arbitrary = hedgehog CC.genApplicationName + +instance Arbitrary CC.Update.SystemTag where + arbitrary = hedgehog CC.genSystemTag + +instance Arbitrary CC.Update.InstallerHash where + arbitrary = hedgehog CC.genInstallerHash + +instance Arbitrary CC.Update.ProtocolVersion where + arbitrary = hedgehog CC.genProtocolVersion + +instance Arbitrary CC.Update.ProtocolParameters where + arbitrary = hedgehog CC.genProtocolParameters + +instance Arbitrary CC.Update.SoftwareVersion where + arbitrary = hedgehog CC.genSoftwareVersion + +instance Arbitrary (Result ByronBlock) where + arbitrary = UpdateInterfaceState <$> genUPIState + where + genUPIState :: Gen CC.UPI.State + genUPIState = CC.UPI.State + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> pure mempty -- TODO CandidateProtocolUpdate's constructor is not exported + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> pure mempty -- TODO Endorsement is not exported + <*> arbitrary diff --git a/ouroboros-consensus/test-consensus/golden/cbor/byron/UPIState b/ouroboros-consensus/test-consensus/golden/cbor/byron/UPIState new file mode 100644 index 0000000000000000000000000000000000000000..040cb38c22270f9a05c56df218b2ee0b81655f9f GIT binary patch literal 137 zcmeBXXl7tw=wpzSj*w!IYiR%zk^&5pOnamm7&s;TiWV>c87w{OmH{9J!;33R1wf3b z&jM8r3|!6949rH|Q+ynNVoZvglI}KuBy}r0Y!w)q7;Z=eHvzf5fu;UIVBK7Hvvx2@ R|A&J4{}+J3O-81M1ptqwDGLAq literal 0 HcmV?d00001 From 6b46210a9b6aa27a75011bacc320916adad9e3b3 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Mon, 27 Jan 2020 13:55:50 +0100 Subject: [PATCH 09/11] Add the LocalStateQuery protocol to the node, but don't enable it To actually enable it, we still need to add it to `NodeToClientProtocols`. This means we're not breaking "network compatibility" yet. --- .../src/Ouroboros/Consensus/Node.hs | 2 +- .../src/Ouroboros/Consensus/NodeNetwork.hs | 64 ++++++++++++++++--- .../test-consensus/Test/ThreadNet/Network.hs | 22 +++++-- 3 files changed, 70 insertions(+), 18 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs index 0a6d9733506..e4a2d5bd2d9 100644 --- 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/NodeNetwork.hs b/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs index 26086d7c6f1..f19c3541d80 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs @@ -57,6 +57,9 @@ import Ouroboros.Network.Protocol.ChainSync.ClientPipelined import Ouroboros.Network.Protocol.ChainSync.Codec import Ouroboros.Network.Protocol.ChainSync.Server import Ouroboros.Network.Protocol.ChainSync.Type +import Ouroboros.Network.Protocol.LocalStateQuery.Codec +import Ouroboros.Network.Protocol.LocalStateQuery.Server +import Ouroboros.Network.Protocol.LocalStateQuery.Type import Ouroboros.Network.Protocol.LocalTxSubmission.Codec import Ouroboros.Network.Protocol.LocalTxSubmission.Server import Ouroboros.Network.Protocol.LocalTxSubmission.Type @@ -72,6 +75,7 @@ import Ouroboros.Consensus.BlockFetchServer import Ouroboros.Consensus.ChainSyncClient import Ouroboros.Consensus.ChainSyncServer import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.LocalStateQueryServer import Ouroboros.Consensus.Mempool.API import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Node.Tracers @@ -127,6 +131,9 @@ data ProtocolHandlers m peer blk = ProtocolHandlers { , phLocalTxSubmissionServer :: LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m () + + , phLocalStateQueryServer + :: LocalStateQueryServer blk (Query blk) (Result blk) m () } protocolHandlers @@ -135,6 +142,7 @@ protocolHandlers , ApplyTx blk , HasTxId (GenTx blk) , ProtocolLedgerView blk + , QueryLedger blk ) => NodeArgs m peer blk --TODO eliminate, merge relevant into NodeKernel -> NodeKernel m peer blk @@ -182,6 +190,9 @@ protocolHandlers NodeArgs {btime, maxClockSkew, tracers, maxUnackTxs, chainSyncP localTxSubmissionServer (localTxSubmissionServerTracer tracers) getMempool + , phLocalStateQueryServer = + localStateQueryServer + (ChainDB.newLedgerCursor getChainDB) } @@ -189,7 +200,7 @@ protocolHandlers NodeArgs {btime, maxClockSkew, tracers, maxUnackTxs, chainSyncP -- data ProtocolCodecs blk failure m bytesCS bytesSCS bytesBF bytesSBF bytesTX - bytesLCS bytesLTX = ProtocolCodecs { + bytesLCS bytesLTX bytesLSQ = ProtocolCodecs { pcChainSyncCodec :: Codec (ChainSync (Header blk) (Tip blk)) failure m bytesCS , pcChainSyncCodecSerialised :: Codec (ChainSync (Serialised (Header blk)) (Tip blk)) @@ -204,6 +215,8 @@ data ProtocolCodecs blk failure m failure m bytesLCS , pcLocalTxSubmissionCodec :: Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) failure m bytesLTX + , pcLocalStateQueryCodec :: Codec (LocalStateQuery blk (Query blk) (Result blk)) + failure m bytesLSQ } -- | The real codecs @@ -212,7 +225,7 @@ protocolCodecs :: forall m blk. (IOLike m, RunNode blk) => NodeConfig (BlockProtocol blk) -> ProtocolCodecs blk DeserialiseFailure m ByteString ByteString ByteString ByteString ByteString - ByteString ByteString + ByteString ByteString ByteString protocolCodecs cfg = ProtocolCodecs { pcChainSyncCodec = codecChainSync @@ -262,6 +275,15 @@ protocolCodecs cfg = ProtocolCodecs { nodeDecodeGenTx (nodeEncodeApplyTxError (Proxy @blk)) (nodeDecodeApplyTxError (Proxy @blk)) + + , pcLocalStateQueryCodec = + codecLocalStateQuery + (encodePoint (nodeEncodeHeaderHash (Proxy @blk))) + (decodePoint (nodeDecodeHeaderHash (Proxy @blk))) + nodeEncodeQuery + nodeDecodeQuery + nodeEncodeResult + nodeDecodeResult } -- | Id codecs used in tests. @@ -275,6 +297,7 @@ protocolCodecsId :: Monad m (AnyMessage (TxSubmission (GenTxId blk) (GenTx blk))) (AnyMessage (ChainSync (Serialised blk) (Tip blk))) (AnyMessage (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))) + (AnyMessage (LocalStateQuery blk (Query blk) (Result blk))) protocolCodecsId = ProtocolCodecs { pcChainSyncCodec = codecChainSyncId , pcChainSyncCodecSerialised = codecChainSyncId @@ -283,6 +306,7 @@ protocolCodecsId = ProtocolCodecs { , pcTxSubmissionCodec = codecTxSubmissionId , pcLocalChainSyncCodec = codecChainSyncId , pcLocalTxSubmissionCodec = codecLocalTxSubmissionId + , pcLocalStateQueryCodec = codecLocalStateQueryId } -- | A record of 'Tracer's for the different protocols. @@ -296,6 +320,7 @@ data ProtocolTracers' peer blk failure f = ProtocolTracers { , ptTxSubmissionTracer :: f (TraceLabelPeer peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk)))) , ptLocalChainSyncTracer :: f (TraceLabelPeer peer (TraceSendRecv (ChainSync (Serialised blk) (Tip blk)))) , ptLocalTxSubmissionTracer :: f (TraceLabelPeer peer (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))) + , ptLocalStateQueryTracer :: f (TraceLabelPeer peer (TraceSendRecv (LocalStateQuery blk (Query blk) (Result blk)))) } -- | Use a 'nullTracer' for each protocol. @@ -308,6 +333,7 @@ nullProtocolTracers = ProtocolTracers { , ptTxSubmissionTracer = nullTracer , ptLocalChainSyncTracer = nullTracer , ptLocalTxSubmissionTracer = nullTracer + , ptLocalStateQueryTracer = nullTracer } showProtocolTracers :: ( Show blk @@ -316,6 +342,8 @@ showProtocolTracers :: ( Show blk , Show (GenTx blk) , Show (GenTxId blk) , Show (ApplyTxErr blk) + , Show (Query blk) + , Show (Result blk) , HasHeader blk ) => Tracer m String -> ProtocolTracers m peer blk failure @@ -327,6 +355,7 @@ showProtocolTracers tr = ProtocolTracers { , ptTxSubmissionTracer = showTracing tr , ptLocalChainSyncTracer = showTracing tr , ptLocalTxSubmissionTracer = showTracing tr + , ptLocalStateQueryTracer = showTracing tr } -- | Consensus provides a chains sync, block fetch applications. This data @@ -337,7 +366,7 @@ showProtocolTracers tr = ProtocolTracers { -- data NetworkApplication m peer bytesCS bytesBF bytesTX - bytesLCS bytesLTX a = NetworkApplication { + bytesLCS bytesLTX bytesLSQ a = NetworkApplication { -- | Start a chain sync client that communicates with the given upstream -- node. naChainSyncClient :: peer -> Channel m bytesCS -> m a @@ -364,6 +393,9 @@ data NetworkApplication m peer -- | Start a local transaction submission server. , naLocalTxSubmissionServer :: peer -> Channel m bytesLTX -> m a + + -- | Start a local state query server. + , naLocalStateQueryServer :: peer -> Channel m bytesLSQ -> m a } @@ -371,7 +403,7 @@ data NetworkApplication m peer -- for the 'NodeToNodeProtocols'. -- initiatorNetworkApplication - :: NetworkApplication m peer bytes bytes bytes bytes bytes a + :: NetworkApplication m peer bytes bytes bytes bytes bytes bytes a -> OuroborosApplication 'InitiatorApp peer NodeToNodeProtocols m bytes a Void initiatorNetworkApplication NetworkApplication {..} = OuroborosInitiatorApplication $ \them ptcl -> case ptcl of @@ -383,7 +415,7 @@ initiatorNetworkApplication NetworkApplication {..} = -- for the 'NodeToNodeProtocols'. -- responderNetworkApplication - :: NetworkApplication m peer bytes bytes bytes bytes bytes a + :: NetworkApplication m peer bytes bytes bytes bytes bytes bytes a -> OuroborosApplication 'ResponderApp peer NodeToNodeProtocols m bytes Void a responderNetworkApplication NetworkApplication {..} = OuroborosResponderApplication $ \them ptcl -> case ptcl of @@ -395,7 +427,7 @@ responderNetworkApplication NetworkApplication {..} = -- for the 'NodeToClientProtocols'. -- localResponderNetworkApplication - :: NetworkApplication m peer bytes bytes bytes bytes bytes a + :: NetworkApplication m peer bytes bytes bytes bytes bytes bytes a -> OuroborosApplication 'ResponderApp peer NodeToClientProtocols m bytes Void a localResponderNetworkApplication NetworkApplication {..} = OuroborosResponderApplication $ \peer ptcl -> case ptcl of @@ -408,7 +440,7 @@ localResponderNetworkApplication NetworkApplication {..} = -- 'NodeToNodeVersions'. -- consensusNetworkApps - :: forall m peer blk failure bytesCS bytesBF bytesTX bytesLCS bytesLTX. + :: forall m peer blk failure bytesCS bytesBF bytesTX bytesLCS bytesLTX bytesLSQ. ( IOLike m , Ord peer , Exception failure @@ -416,9 +448,9 @@ consensusNetworkApps ) => NodeKernel m peer blk -> ProtocolTracers m peer blk failure - -> ProtocolCodecs blk failure m bytesCS bytesCS bytesBF bytesBF bytesTX bytesLCS bytesLTX + -> ProtocolCodecs blk failure m bytesCS bytesCS bytesBF bytesBF bytesTX bytesLCS bytesLTX bytesLSQ -> ProtocolHandlers m peer blk - -> NetworkApplication m peer bytesCS bytesBF bytesTX bytesLCS bytesLTX () + -> NetworkApplication m peer bytesCS bytesBF bytesTX bytesLCS bytesLTX bytesLSQ () consensusNetworkApps kernel ProtocolTracers {..} ProtocolCodecs {..} ProtocolHandlers {..} = NetworkApplication { naChainSyncClient, @@ -428,7 +460,8 @@ consensusNetworkApps kernel ProtocolTracers {..} ProtocolCodecs {..} ProtocolHan naTxSubmissionClient, naTxSubmissionServer, naLocalChainSyncServer, - naLocalTxSubmissionServer + naLocalTxSubmissionServer, + naLocalStateQueryServer } where naChainSyncClient @@ -537,6 +570,17 @@ consensusNetworkApps kernel ProtocolTracers {..} ProtocolCodecs {..} ProtocolHan channel (localTxSubmissionServerPeer (pure phLocalTxSubmissionServer)) + naLocalStateQueryServer + :: peer + -> Channel m bytesLSQ + -> m () + naLocalStateQueryServer them channel = + runPeer + (contramap (TraceLabelPeer them) ptLocalStateQueryTracer) + pcLocalStateQueryCodec + channel + (localStateQueryServerPeer phLocalStateQueryServer) + chainDbView :: IOLike m => ChainDB m blk -> ChainDbView m blk chainDbView chainDB = ChainDbView { getCurrentChain = ChainDB.getCurrentChain chainDB diff --git a/ouroboros-consensus/test-consensus/Test/ThreadNet/Network.hs b/ouroboros-consensus/test-consensus/Test/ThreadNet/Network.hs index 9ab1291b643..42f88f05240 100644 --- a/ouroboros-consensus/test-consensus/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus/test-consensus/Test/ThreadNet/Network.hs @@ -62,6 +62,7 @@ import qualified Ouroboros.Network.BlockFetch.Client as BFClient import Ouroboros.Network.Protocol.ChainSync.PipelineDecision (pipelineDecisionLowHighMark) import Ouroboros.Network.Protocol.ChainSync.Type +import Ouroboros.Network.Protocol.LocalStateQuery.Type import Ouroboros.Network.Protocol.LocalTxSubmission.Type import Ouroboros.Network.Protocol.TxSubmission.Type import qualified Ouroboros.Network.TxSubmission.Inbound as TxInbound @@ -667,6 +668,7 @@ runThreadNetwork ThreadNetworkArgs (AnyMessage (TxSubmission (GenTxId blk) (GenTx blk))) (AnyMessage (ChainSync (Serialised blk) (Tip blk))) (AnyMessage (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))) + (AnyMessage (LocalStateQuery blk (Query blk) (Result blk))) customProtocolCodecs cfg = ProtocolCodecs { pcChainSyncCodec = mapFailureCodec CodecBytesFailure $ @@ -689,6 +691,9 @@ runThreadNetwork ThreadNetworkArgs , pcLocalTxSubmissionCodec = mapFailureCodec CodecIdFailure $ pcLocalTxSubmissionCodec protocolCodecsId + , pcLocalStateQueryCodec = + mapFailureCodec CodecIdFailure $ + pcLocalStateQueryCodec protocolCodecsId } where binaryProtocolCodecs = protocolCodecs cfg @@ -824,14 +829,14 @@ directedEdgeInner edgeStatusVar atomically $ writeTVar edgeStatusVar EUp let miniProtocol :: - (forall unused1 unused2. - LimitedApp' m NodeId blk unused1 unused2 + (forall unused1 unused2 unused3. + LimitedApp' m NodeId blk unused1 unused2 unused3 -> NodeId -> Channel m msg -> m ()) -- ^ client action to run on node1 - -> (forall unused1 unused2. - LimitedApp' m NodeId blk unused1 unused2 + -> (forall unused1 unused2 unused3. + LimitedApp' m NodeId blk unused1 unused2 unused3 -> NodeId -> Channel m msg -> m ()) @@ -1056,6 +1061,8 @@ type TracingConstraints blk = , Show (Header blk) , Show (GenTx blk) , Show (GenTxId blk) + , Show (Query blk) + , Show (Result blk) ) {------------------------------------------------------------------------------- @@ -1083,13 +1090,13 @@ withAsyncsWaitAny = go [] . NE.toList -- -- Used internal to this module, essentially as an abbreviation. data LimitedApp m peer blk = - forall unused1 unused2. - LimitedApp (LimitedApp' m peer blk unused1 unused2) + forall unused1 unused2 unused3. + LimitedApp (LimitedApp' m peer blk unused1 unused2 unused3) -- | Argument of 'LimitedApp' data constructor -- -- Used internal to this module, essentially as an abbreviation. -type LimitedApp' m peer blk unused1 unused2 = +type LimitedApp' m peer blk unused1 unused2 unused3 = NetworkApplication m peer -- The 'ChainSync' and 'BlockFetch' protocols use @'Serialised' x@ for -- the servers and @x@ for the clients. Since both have to match to be @@ -1101,6 +1108,7 @@ type LimitedApp' m peer blk unused1 unused2 = (AnyMessage (TxSubmission (GenTxId blk) (GenTx blk))) unused1 -- the local node-to-client channel types unused2 + unused3 () {------------------------------------------------------------------------------- From d45fc6716a46b05041b796c13a152433f1453fb5 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Tue, 28 Jan 2020 08:32:15 +0100 Subject: [PATCH 10/11] Test the LocalStateQueryServer --- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../Ouroboros/Storage/ChainDB/Impl/LgrDB.hs | 10 + ouroboros-consensus/test-consensus/Main.hs | 2 + .../Test/Consensus/LocalStateQueryServer.hs | 256 ++++++++++++++++++ 4 files changed, 269 insertions(+) create mode 100644 ouroboros-consensus/test-consensus/Test/Consensus/LocalStateQueryServer.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 919592ee3de..76b2c793091 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -296,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/Storage/ChainDB/Impl/LgrDB.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/LgrDB.hs index b66cab9a3ec..8240b39009b 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/LgrDB.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/LgrDB.hs @@ -48,6 +48,8 @@ module Ouroboros.Storage.ChainDB.Impl.LgrDB ( , LedgerDB.SwitchResult (..) , TraceEvent (..) , TraceReplayEvent (..) + -- * Exported for testing purposes + , mkLgrDB ) where import Codec.Serialise.Decoding (Decoder) @@ -268,6 +270,14 @@ initFromDisk args@LgrDbArgs{..} replayTracer lgrDbConf immDB = wrapFailure args (streamAPI immDB) return db +-- | For testing purposes +mkLgrDB :: Conf m blk + -> StrictTVar m (LedgerDB blk) + -> StrictTVar m (Set (Point blk)) + -> LgrDbArgs m blk + -> LgrDB m blk +mkLgrDB conf varDB varPrevApplied args = LgrDB {..} + {------------------------------------------------------------------------------- TraceReplayEvent decorator -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/test-consensus/Main.hs b/ouroboros-consensus/test-consensus/Main.hs index 1402428b7f9..d61cb32b6c0 100644 --- a/ouroboros-consensus/test-consensus/Main.hs +++ b/ouroboros-consensus/test-consensus/Main.hs @@ -7,6 +7,7 @@ import qualified Test.Consensus.BlockchainTime.WallClock (tests) import qualified Test.Consensus.ChainSyncClient (tests) import qualified Test.Consensus.Ledger.Byron (tests) import qualified Test.Consensus.Ledger.Mock (tests) +import qualified Test.Consensus.LocalStateQueryServer (tests) import qualified Test.Consensus.Mempool (tests) import qualified Test.Consensus.Node (tests) import qualified Test.Consensus.Protocol.PBFT (tests) @@ -32,6 +33,7 @@ tests = , Test.Consensus.ChainSyncClient.tests , Test.Consensus.Ledger.Byron.tests , Test.Consensus.Ledger.Mock.tests + , Test.Consensus.LocalStateQueryServer.tests , Test.Consensus.Mempool.tests , Test.Consensus.Node.tests , Test.Consensus.Protocol.PBFT.tests diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/LocalStateQueryServer.hs b/ouroboros-consensus/test-consensus/Test/Consensus/LocalStateQueryServer.hs new file mode 100644 index 00000000000..df70a1b272c --- /dev/null +++ b/ouroboros-consensus/test-consensus/Test/Consensus/LocalStateQueryServer.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +module Test.Consensus.LocalStateQueryServer where + +import Control.Monad.Except (runExcept) +import Control.Tracer (nullTracer) +import Data.Map (Map) +import qualified Data.Map as Map + +import Control.Monad.IOSim (runSimOrThrow) + +import Cardano.Crypto.DSIGN.Mock + +import Network.TypedProtocol.Proofs (connect) +import Ouroboros.Network.Block (Point (..), SlotNo, blockPoint, + pointSlot) +import Ouroboros.Network.MockChain.Chain (Chain (..)) +import qualified Ouroboros.Network.MockChain.Chain as Chain +import Ouroboros.Network.Point (WithOrigin (..)) +import Ouroboros.Network.Protocol.LocalStateQuery.Client +import Ouroboros.Network.Protocol.LocalStateQuery.Examples + (localStateQueryClient) +import Ouroboros.Network.Protocol.LocalStateQuery.Server +import Ouroboros.Network.Protocol.LocalStateQuery.Type + (AcquireFailure (..)) + +import Ouroboros.Consensus.Block (BlockProtocol, getHeader) +import Ouroboros.Consensus.BlockchainTime.SlotLength + (slotLengthFromSec) +import Ouroboros.Consensus.BlockchainTime.SlotLengths + (singletonSlotLengths) +import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.LocalStateQueryServer +import Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..)) +import Ouroboros.Consensus.NodeId +import Ouroboros.Consensus.Protocol.Abstract (NodeConfig, + SecurityParam (..)) +import Ouroboros.Consensus.Protocol.BFT +import Ouroboros.Consensus.Util ((.:)) +import Ouroboros.Consensus.Util.IOLike + +import qualified Ouroboros.Storage.ChainDB.Impl.LedgerCursor as LedgerCursor +import Ouroboros.Storage.ChainDB.Impl.LgrDB (LedgerDbParams (..), + LgrDB, LgrDbArgs (..), mkLgrDB) +import qualified Ouroboros.Storage.ChainDB.Impl.LgrDB as LgrDB +import Ouroboros.Storage.LedgerDB.Conf (LedgerDbConf (..)) +import qualified Ouroboros.Storage.LedgerDB.InMemory as LgrDB + (ledgerDbFromGenesis) + +import Test.QuickCheck hiding (Result) +import Test.Tasty +import Test.Tasty.QuickCheck + +import Test.Util.Orphans.IOLike () +import Test.Util.TestBlock + + +{------------------------------------------------------------------------------- + Top-level tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "LocalStateQueryServer" + [ testProperty "localStateQueryServer" prop_localStateQueryServer + ] + +{------------------------------------------------------------------------------- + Main property +-------------------------------------------------------------------------------} + +-- | Plan: +-- * Preseed the LgrDB of the server with the preferred chain of the +-- 'BlockTree'. +-- * Acquire for each block in the 'BlockTree', including the ones not on the +-- chain, a state and send the 'QueryLedgerTip'. Collect these results. +-- * Check that when acquiring failed, it rightfully failed. Otherwise, check +-- whether the returned tip matches the block. +prop_localStateQueryServer + :: SecurityParam + -> BlockTree + -> Permutation + -> Property +prop_localStateQueryServer k bt p = checkOutcome k chain actualOutcome + where + chain :: Chain TestBlock + chain = treePreferredChain (testCfg k) bt + + points :: [Point TestBlock] + points = blockPoint <$> permute p (treeToBlocks bt) + + actualOutcome = runSimOrThrow $ do + let client = mkClient points + server <- mkServer k chain + (\(a, _, _) -> a) <$> + connect + (localStateQueryClientPeer client) + (localStateQueryServerPeer server) + +{------------------------------------------------------------------------------- + Test setup +-------------------------------------------------------------------------------} + +-- | Checks whether the given outcome is correct: in case of an +-- 'AcquireFailure', we check whether it was warranted. Otherwise we check +-- whether the results are correct. +-- +-- NOTE: when we don't get an 'AcquireFailure', even though we expected it, we +-- accept it. This is because the LgrDB may contain snapshots for blocks on +-- the current chain older than @k@, but we do not want to imitate such +-- implementation details. +-- +-- Additionally, this function labels the test results. +checkOutcome + :: SecurityParam + -> Chain TestBlock + -> [(Point TestBlock, Either AcquireFailure [Result TestBlock])] + -> Property +checkOutcome k chain = conjoin . map (uncurry checkResult) + where + immutableSlot :: WithOrigin SlotNo + immutableSlot = Chain.headSlot $ + Chain.drop (fromIntegral (maxRollbacks k)) chain + + checkResult + :: Point TestBlock + -> Either AcquireFailure [Result TestBlock] + -> Property + checkResult pt = \case + Right results + -> tabulate "Acquired" ["Success"] $ results === [ResultLedgerTip pt] + Left AcquireFailurePointNotOnChain + | Chain.pointOnChain pt chain + -> counterexample + ("Point " <> show pt <> + " on chain, but got AcquireFailurePointNotOnChain") + (property False) + | otherwise + -> tabulate "Acquired" ["AcquireFailurePointNotOnChain"] $ property True + Left AcquireFailurePointTooOld + | pointSlot pt >= immutableSlot + -> counterexample + ("Point " <> show pt <> + " newer than the immutable tip, but got AcquireFailurePointTooOld") + (property False) + | otherwise + -> tabulate "Acquired" ["AcquireFailurePointTooOld"] $ property True + +mkClient + :: Monad m + => [Point TestBlock] + -> LocalStateQueryClient + TestBlock + (Query TestBlock) + (Result TestBlock) + m + [(Point TestBlock, Either AcquireFailure [Result TestBlock])] +mkClient points = localStateQueryClient [(pt, [QueryLedgerTip]) | pt <- points] + +mkServer + :: IOLike m + => SecurityParam + -> Chain TestBlock + -> m (LocalStateQueryServer TestBlock (Query TestBlock) (Result TestBlock) m ()) +mkServer k chain = do + lgrDB <- initLgrDB k chain + return $ localStateQueryServer $ LedgerCursor.newLedgerCursor lgrDB getImmutablePoint + where + getImmutablePoint = return $ Chain.headPoint $ + Chain.drop (fromIntegral (maxRollbacks k)) chain + +-- | Initialise a 'LgrDB' with the given chain. +initLgrDB + :: forall m. IOLike m + => SecurityParam + -> Chain TestBlock + -> m (LgrDB m TestBlock) +initLgrDB k chain = do + varDB <- newTVarM genesisLedgerDB + varPrevApplied <- newTVarM mempty + let lgrDB = mkLgrDB conf varDB varPrevApplied args + LgrDB.validate lgrDB genesisLedgerDB 0 + (map getHeader (Chain.toOldestFirst chain)) >>= \case + LgrDB.MaximumRollbackExceeded {} -> + error "rollback was 0" + LgrDB.RollbackSuccessful (LgrDB.InvalidBlock {}) -> + error "there were no invalid blocks" + LgrDB.RollbackSuccessful (LgrDB.ValidBlocks ledgerDB') -> do + atomically $ LgrDB.setCurrent lgrDB ledgerDB' + return lgrDB + where + blockMapping :: Map (Point TestBlock) TestBlock + blockMapping = Map.fromList + [(blockPoint b, b) | b <- Chain.toOldestFirst chain] + + params :: LedgerDbParams + params = LedgerDbParams + { ledgerDbSnapEvery = maxRollbacks k + , ledgerDbSecurityParam = k + } + + cfg = testCfg k + + conf = LedgerDbConf + { ldbConfGenesis = return testInitExtLedger + , ldbConfApply = runExcept .: + applyExtLedgerState BlockNotPreviouslyApplied cfg + , ldbConfReapply = (mustBeRight . runExcept) .: + applyExtLedgerState BlockPreviouslyApplied cfg + , ldbConfResolve = return . (blockMapping Map.!) + } + + mustBeRight (Left e) = error $ "impossible: " <> show e + mustBeRight (Right a) = a + + genesisLedgerDB = LgrDB.ledgerDbFromGenesis params testInitExtLedger + + args = LgrDbArgs + { lgrNodeConfig = cfg + , lgrHasFS = error "lgrHasFS" + , lgrDecodeLedger = error "lgrDecodeLedger" + , lgrDecodeChainState = error "lgrDecodeChainState" + , lgrDecodeHash = error "lgrDecodeHash" + , lgrEncodeLedger = error "lgrEncodeLedger" + , lgrEncodeChainState = error "lgrEncodeChainState" + , lgrEncodeHash = error "lgrEncodeHash" + , lgrParams = params + , lgrDiskPolicy = error "lgrDiskPolicy" + , lgrGenesis = return testInitExtLedger + , lgrTracer = nullTracer + , lgrTraceLedger = nullTracer + } + +testCfg :: SecurityParam -> NodeConfig (BlockProtocol TestBlock) +testCfg securityParam = BftNodeConfig + { bftParams = BftParams { bftSecurityParam = securityParam + , bftNumNodes = NumCoreNodes 1 + , bftSlotLengths = singletonSlotLengths $ + slotLengthFromSec 20 + } + , bftNodeId = CoreId (CoreNodeId 0) + , bftSignKey = SignKeyMockDSIGN 0 + , bftVerKeys = Map.singleton (CoreId (CoreNodeId 0)) (VerKeyMockDSIGN 0) + } + + +{------------------------------------------------------------------------------- + Orphans +-------------------------------------------------------------------------------} + +instance Arbitrary SecurityParam where + arbitrary = SecurityParam <$> choose (1, 100) + shrink (SecurityParam k) = [SecurityParam k' | k' <- shrink k, k' > 0] From 0ec858c3263e40c1d044c848915a41c1a81a5382 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Tue, 28 Jan 2020 18:43:22 +0100 Subject: [PATCH 11/11] Turn Query into a GADT The protocol will now guarantee that the response to a Query has the right type. --- .../Ouroboros/Consensus/Ledger/Abstract.hs | 22 +-- .../Consensus/Ledger/Byron/Ledger.hs | 43 +++--- .../src/Ouroboros/Consensus/Ledger/Dual.hs | 10 +- .../Ouroboros/Consensus/Ledger/Mock/Block.hs | 18 +-- .../Consensus/LocalStateQueryServer.hs | 12 +- .../Ouroboros/Consensus/Node/Run/Abstract.hs | 9 +- .../Ouroboros/Consensus/Node/Run/DualByron.hs | 2 +- .../src/Ouroboros/Consensus/Node/Run/Mock.hs | 10 +- .../src/Ouroboros/Consensus/NodeNetwork.hs | 16 +-- .../Test/Consensus/Ledger/Byron.hs | 58 +++++--- .../Test/Consensus/LocalStateQueryServer.hs | 15 +- .../test-consensus/Test/ThreadNet/Network.hs | 5 +- .../test-util/Test/Util/TestBlock.hs | 19 ++- .../Protocol/LocalStateQuery/Direct.hs | 22 +-- .../Network/Protocol/LocalStateQuery/Test.hs | 136 +++++++++--------- .../Protocol/LocalStateQuery/Client.hs | 69 ++++----- .../Network/Protocol/LocalStateQuery/Codec.hs | 83 ++++++----- .../Protocol/LocalStateQuery/Examples.hs | 69 +++++---- .../Protocol/LocalStateQuery/Server.hs | 75 +++++----- .../Network/Protocol/LocalStateQuery/Type.hs | 117 ++++++++++----- 20 files changed, 454 insertions(+), 356 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Abstract.hs index aeaa389527e..414639077eb 100644 --- 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 @@ -14,9 +15,11 @@ module Ouroboros.Consensus.Ledger.Abstract ( , ProtocolLedgerView(..) , AnachronyFailure(..) , QueryLedger(..) + , ShowQuery(..) ) where import Control.Monad.Except +import Data.Type.Equality ((:~:)) import GHC.Stack (HasCallStack) import Cardano.Prelude (NoUnexpectedThunks) @@ -24,6 +27,8 @@ 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 @@ -174,15 +179,14 @@ data AnachronyFailure -- -- Used by the LocalStateQuery protocol to allow clients to query the ledger -- state. -class UpdateLedger blk => QueryLedger blk where +class (UpdateLedger blk, ShowQuery (Query blk)) => QueryLedger blk where - -- | Different queries supported by the ledger - data family Query blk :: * - - -- | The result types for the queries - data family Result blk :: * - -- TODO index Result by Query so that we always get the expected result - -- type? + -- | 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 -> LedgerState blk -> Result blk + 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 index 93c9df88524..bd2be1d9a23 100644 --- 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 #-} @@ -14,7 +16,6 @@ module Ouroboros.Consensus.Ledger.Byron.Ledger ( LedgerConfig(..) , LedgerState(..) , Query(..) - , Result(..) , initByronLedgerState -- * Serialisation , encodeByronLedgerState @@ -36,6 +37,7 @@ 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) @@ -52,6 +54,7 @@ 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 @@ -125,16 +128,19 @@ initByronLedgerState genesis mUtxo = ByronLedgerState { override (Just utxo) st = st { CC.cvsUtxo = utxo } instance QueryLedger ByronBlock where - data Query ByronBlock - = GetUpdateInterfaceState - deriving (Eq, Show) - - data Result ByronBlock - = UpdateInterfaceState UPI.State - deriving (Eq, Show) + data Query ByronBlock :: * -> * where + GetUpdateInterfaceState :: Query ByronBlock UPI.State answerQuery GetUpdateInterfaceState ledgerState = - UpdateInterfaceState (CC.cvsUpdateState (byronLedgerState 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 @@ -331,19 +337,22 @@ decodeByronLedgerState = do <$> decode <*> History.decodeDelegationHistory -encodeByronQuery :: Query ByronBlock -> Encoding +encodeByronQuery :: Query ByronBlock result -> Encoding encodeByronQuery query = case query of GetUpdateInterfaceState -> CBOR.encodeWord8 0 -decodeByronQuery :: Decoder s (Query ByronBlock) +decodeByronQuery :: Decoder s (Some (Query ByronBlock)) decodeByronQuery = do tag <- CBOR.decodeWord8 case tag of - 0 -> return GetUpdateInterfaceState + 0 -> return $ Some GetUpdateInterfaceState _ -> fail $ "decodeByronQuery: invalid tag " <> show tag -encodeByronResult :: Result ByronBlock -> Encoding -encodeByronResult (UpdateInterfaceState state) = toCBOR state +encodeByronResult :: Query ByronBlock result -> result -> Encoding +encodeByronResult query = case query of + GetUpdateInterfaceState -> toCBOR -decodeByronResult :: Decoder s (Result ByronBlock) -decodeByronResult = UpdateInterfaceState <$> fromCBOR +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 index 6d59b0caab7..376899f367d 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs @@ -434,12 +434,14 @@ instance Bridge m a => ProtocolLedgerView (DualBlock m a) where -- | Not used in the tests: no constructors instance Bridge m a => QueryLedger (DualBlock m a) where - data Query (DualBlock m a) - deriving (Show) - data Result (DualBlock m a) + data Query (DualBlock m a) result deriving (Show) - answerQuery q _ledgerState = case q of {} + 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 index 603930b5098..5df9e9a9537 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block.hs @@ -2,9 +2,11 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE EmptyCase #-} +{-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} @@ -38,9 +40,6 @@ module Ouroboros.Consensus.Ledger.Mock.Block ( -- * 'ApplyTx' (mempool support) , GenTx(..) , mkSimpleGenTx - -- * 'QueryLedger' - , Query(..) - , Result(..) -- * Crypto , SimpleCrypto , SimpleStandardCrypto @@ -334,13 +333,14 @@ mkSimpleGenTx tx = SimpleGenTx instance (SimpleCrypto c, Typeable ext, SupportedBlock (SimpleBlock c ext)) => QueryLedger (SimpleBlock c ext) where - data Query (SimpleBlock c ext) = QueryLedgerTip - deriving (Show, Generic, Serialise) - data Result (SimpleBlock c ext) = ResultLedgerTip (Point (SimpleBlock c ext)) - deriving (Show, Generic, Serialise) + data Query (SimpleBlock c ext) result + deriving (Show) + + answerQuery = \case {} + eqQuery = \case {} - answerQuery QueryLedgerTip (SimpleLedgerState MockState { mockTip }) = - ResultLedgerTip mockTip +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 index f4cc085d78f..706a28e96f6 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/LocalStateQueryServer.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/LocalStateQueryServer.hs @@ -24,13 +24,13 @@ import Ouroboros.Storage.ChainDB (LedgerCursor (..), localStateQueryServer :: forall m blk. (IOLike m, QueryLedger blk) => m (LedgerCursor m blk) - -> LocalStateQueryServer blk (Query blk) (Result blk) m () + -> LocalStateQueryServer blk (Query blk) m () localStateQueryServer newLedgerCursor = LocalStateQueryServer $ idle <$> newLedgerCursor where idle :: LedgerCursor m blk - -> ServerStIdle blk (Query blk) (Result blk) m () + -> ServerStIdle blk (Query blk) m () idle ledgerCursor = ServerStIdle { recvMsgAcquire = handleAcquire ledgerCursor , recvMsgDone = return () @@ -39,7 +39,7 @@ localStateQueryServer newLedgerCursor = handleAcquire :: LedgerCursor m blk -> Point blk - -> m (ServerStAcquiring blk (Query blk) (Result blk) m ()) + -> m (ServerStAcquiring blk (Query blk) m ()) handleAcquire ledgerCursor pt = ledgerCursorMove ledgerCursor pt <&> \case Left failure -> @@ -50,7 +50,7 @@ localStateQueryServer newLedgerCursor = acquired :: LedgerState blk -> LedgerCursor m blk - -> ServerStAcquired blk (Query blk) (Result blk) m () + -> ServerStAcquired blk (Query blk) m () acquired ledgerState ledgerCursor = ServerStAcquired { recvMsgQuery = handleQuery ledgerState ledgerCursor , recvMsgReAcquire = handleAcquire ledgerCursor @@ -60,8 +60,8 @@ localStateQueryServer newLedgerCursor = handleQuery :: LedgerState blk -> LedgerCursor m blk - -> Query blk - -> m (ServerStQuerying blk (Query blk) (Result blk) m ()) + -> Query blk result + -> m (ServerStQuerying blk (Query blk) m () result) handleQuery ledgerState ledgerCursor query = return $ SendMsgResult (answerQuery query ledgerState) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Abstract.hs index 1e4fb5d2fd7..dbce47a9d23 100644 --- 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) @@ -128,8 +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 -> Encoding - nodeEncodeResult :: Result 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) @@ -140,5 +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 (Query blk) - nodeDecodeResult :: forall s. Decoder s (Result 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/DualByron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/DualByron.hs index 8f2bef83007..198c59ad477 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/DualByron.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/DualByron.hs @@ -105,7 +105,7 @@ instance RunNode DualByronBlock where let k = pbftSecurityParam $ pbftParams cfg in decodeByronChainState k nodeDecodeQuery = error "DualByron.nodeDecodeQuery" - nodeDecodeResult = error "DualByron.nodeDecodeResult" + nodeDecodeResult = \case {} extractEpochSlots :: NodeConfig DualByronProtocol -> EpochSlots extractEpochSlots = Byron.extractEpochSlots . dualNodeConfigMain diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Mock.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Mock.hs index e65e6cd2f69..3b334e5f2ab 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Mock.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Mock.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -64,8 +66,8 @@ instance ( ProtocolLedgerView (SimpleBlock SimpleMockCrypto ext) nodeEncodeLedgerState = const encode nodeEncodeChainState = const mockEncodeChainState nodeEncodeApplyTxError = const encode - nodeEncodeQuery = encode - nodeEncodeResult = encode + nodeEncodeQuery = \case {} + nodeEncodeResult = \case {} nodeDecodeBlock = const (const <$> decode) nodeDecodeHeader = const (const <$> decode) @@ -75,5 +77,5 @@ instance ( ProtocolLedgerView (SimpleBlock SimpleMockCrypto ext) nodeDecodeLedgerState = const decode nodeDecodeChainState = const mockDecodeChainState nodeDecodeApplyTxError = const decode - nodeDecodeQuery = decode - nodeDecodeResult = decode + nodeDecodeQuery = error "Mock.nodeDecodeQuery" + nodeDecodeResult = \case {} diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs b/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs index f19c3541d80..2b1311c48b8 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -133,7 +134,7 @@ data ProtocolHandlers m peer blk = ProtocolHandlers { :: LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m () , phLocalStateQueryServer - :: LocalStateQueryServer blk (Query blk) (Result blk) m () + :: LocalStateQueryServer blk (Query blk) m () } protocolHandlers @@ -215,7 +216,7 @@ data ProtocolCodecs blk failure m failure m bytesLCS , pcLocalTxSubmissionCodec :: Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) failure m bytesLTX - , pcLocalStateQueryCodec :: Codec (LocalStateQuery blk (Query blk) (Result blk)) + , pcLocalStateQueryCodec :: Codec (LocalStateQuery blk (Query blk)) failure m bytesLSQ } @@ -288,7 +289,7 @@ protocolCodecs cfg = ProtocolCodecs { -- | Id codecs used in tests. -- -protocolCodecsId :: Monad m +protocolCodecsId :: (Monad m, QueryLedger blk) => ProtocolCodecs blk CodecFailure m (AnyMessage (ChainSync (Header blk) (Tip blk))) (AnyMessage (ChainSync (Serialised (Header blk)) (Tip blk))) @@ -297,7 +298,7 @@ protocolCodecsId :: Monad m (AnyMessage (TxSubmission (GenTxId blk) (GenTx blk))) (AnyMessage (ChainSync (Serialised blk) (Tip blk))) (AnyMessage (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))) - (AnyMessage (LocalStateQuery blk (Query blk) (Result blk))) + (AnyMessage (LocalStateQuery blk (Query blk))) protocolCodecsId = ProtocolCodecs { pcChainSyncCodec = codecChainSyncId , pcChainSyncCodecSerialised = codecChainSyncId @@ -306,7 +307,7 @@ protocolCodecsId = ProtocolCodecs { , pcTxSubmissionCodec = codecTxSubmissionId , pcLocalChainSyncCodec = codecChainSyncId , pcLocalTxSubmissionCodec = codecLocalTxSubmissionId - , pcLocalStateQueryCodec = codecLocalStateQueryId + , pcLocalStateQueryCodec = codecLocalStateQueryId eqQuery } -- | A record of 'Tracer's for the different protocols. @@ -320,7 +321,7 @@ data ProtocolTracers' peer blk failure f = ProtocolTracers { , ptTxSubmissionTracer :: f (TraceLabelPeer peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk)))) , ptLocalChainSyncTracer :: f (TraceLabelPeer peer (TraceSendRecv (ChainSync (Serialised blk) (Tip blk)))) , ptLocalTxSubmissionTracer :: f (TraceLabelPeer peer (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))) - , ptLocalStateQueryTracer :: f (TraceLabelPeer peer (TraceSendRecv (LocalStateQuery blk (Query blk) (Result blk)))) + , ptLocalStateQueryTracer :: f (TraceLabelPeer peer (TraceSendRecv (LocalStateQuery blk (Query blk)))) } -- | Use a 'nullTracer' for each protocol. @@ -342,8 +343,7 @@ showProtocolTracers :: ( Show blk , Show (GenTx blk) , Show (GenTxId blk) , Show (ApplyTxErr blk) - , Show (Query blk) - , Show (Result blk) + , ShowQuery (Query blk) , HasHeader blk ) => Tracer m String -> ProtocolTracers m peer blk failure diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs b/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs index 79c4f7277dc..5614a118daf 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/Ledger/Byron.hs @@ -1,11 +1,14 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} module Test.Consensus.Ledger.Byron (tests) where @@ -32,6 +35,7 @@ import Cardano.Crypto (ProtocolMagicId (..)) import Ouroboros.Network.Block (HeaderHash, SlotNo) import Ouroboros.Network.Point (WithOrigin (At)) +import Ouroboros.Network.Protocol.LocalStateQuery.Codec (Some (..)) import Ouroboros.Consensus.Block (BlockProtocol, Header) import Ouroboros.Consensus.Ledger.Byron @@ -178,13 +182,17 @@ prop_roundtrip_ApplyTxErr :: ApplyTxErr ByronBlock -> Property prop_roundtrip_ApplyTxErr = roundtrip encodeByronApplyTxError decodeByronApplyTxError -prop_roundtrip_Query :: Query ByronBlock -> Property +prop_roundtrip_Query :: Some (Query ByronBlock) -> Property prop_roundtrip_Query = - roundtrip encodeByronQuery decodeByronQuery + roundtrip + (\case { Some query -> encodeByronQuery query }) + decodeByronQuery -prop_roundtrip_Result :: Result ByronBlock -> Property +prop_roundtrip_Result :: CC.UPI.State -> Property prop_roundtrip_Result = - roundtrip encodeByronResult decodeByronResult + roundtrip + (encodeByronResult GetUpdateInterfaceState) + (decodeByronResult GetUpdateInterfaceState) {------------------------------------------------------------------------------- BinaryInfo @@ -518,8 +526,8 @@ instance Arbitrary ApplyMempoolPayloadErr where -- , MempoolUpdateVoteErr <$> arbitrary ] -instance Arbitrary (Query ByronBlock) where - arbitrary = return GetUpdateInterfaceState +instance Arbitrary (Some (Query ByronBlock)) where + arbitrary = pure $ Some GetUpdateInterfaceState instance Arbitrary EpochNumber where arbitrary = hedgehog CC.genEpochNumber @@ -548,19 +556,25 @@ instance Arbitrary CC.Update.ProtocolParameters where instance Arbitrary CC.Update.SoftwareVersion where arbitrary = hedgehog CC.genSoftwareVersion -instance Arbitrary (Result ByronBlock) where - arbitrary = UpdateInterfaceState <$> genUPIState - where - genUPIState :: Gen CC.UPI.State - genUPIState = CC.UPI.State - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> pure mempty -- TODO CandidateProtocolUpdate's constructor is not exported - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> pure mempty -- TODO Endorsement is not exported - <*> arbitrary +instance Arbitrary CC.UPI.State where + arbitrary = CC.UPI.State + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> pure mempty -- TODO CandidateProtocolUpdate's constructor is not exported + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> pure mempty -- TODO Endorsement is not exported + <*> arbitrary + +{------------------------------------------------------------------------------- + Orphans +-------------------------------------------------------------------------------} + +instance Eq (Some (Query ByronBlock)) where + Some GetUpdateInterfaceState == Some GetUpdateInterfaceState = True + +deriving instance Show (Some (Query ByronBlock)) diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/LocalStateQueryServer.hs b/ouroboros-consensus/test-consensus/Test/Consensus/LocalStateQueryServer.hs index df70a1b272c..7c338647fde 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/LocalStateQueryServer.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/LocalStateQueryServer.hs @@ -117,7 +117,7 @@ prop_localStateQueryServer k bt p = checkOutcome k chain actualOutcome checkOutcome :: SecurityParam -> Chain TestBlock - -> [(Point TestBlock, Either AcquireFailure [Result TestBlock])] + -> [(Point TestBlock, Either AcquireFailure (Point TestBlock))] -> Property checkOutcome k chain = conjoin . map (uncurry checkResult) where @@ -127,11 +127,11 @@ checkOutcome k chain = conjoin . map (uncurry checkResult) checkResult :: Point TestBlock - -> Either AcquireFailure [Result TestBlock] + -> Either AcquireFailure (Point TestBlock) -> Property checkResult pt = \case - Right results - -> tabulate "Acquired" ["Success"] $ results === [ResultLedgerTip pt] + Right result + -> tabulate "Acquired" ["Success"] $ result === pt Left AcquireFailurePointNotOnChain | Chain.pointOnChain pt chain -> counterexample @@ -155,16 +155,15 @@ mkClient -> LocalStateQueryClient TestBlock (Query TestBlock) - (Result TestBlock) m - [(Point TestBlock, Either AcquireFailure [Result TestBlock])] -mkClient points = localStateQueryClient [(pt, [QueryLedgerTip]) | pt <- points] + [(Point TestBlock, Either AcquireFailure (Point TestBlock))] +mkClient points = localStateQueryClient [(pt, QueryLedgerTip) | pt <- points] mkServer :: IOLike m => SecurityParam -> Chain TestBlock - -> m (LocalStateQueryServer TestBlock (Query TestBlock) (Result TestBlock) m ()) + -> m (LocalStateQueryServer TestBlock (Query TestBlock) m ()) mkServer k chain = do lgrDB <- initLgrDB k chain return $ localStateQueryServer $ LedgerCursor.newLedgerCursor lgrDB getImmutablePoint diff --git a/ouroboros-consensus/test-consensus/Test/ThreadNet/Network.hs b/ouroboros-consensus/test-consensus/Test/ThreadNet/Network.hs index 42f88f05240..99074a69e96 100644 --- a/ouroboros-consensus/test-consensus/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus/test-consensus/Test/ThreadNet/Network.hs @@ -668,7 +668,7 @@ runThreadNetwork ThreadNetworkArgs (AnyMessage (TxSubmission (GenTxId blk) (GenTx blk))) (AnyMessage (ChainSync (Serialised blk) (Tip blk))) (AnyMessage (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))) - (AnyMessage (LocalStateQuery blk (Query blk) (Result blk))) + (AnyMessage (LocalStateQuery blk (Query blk))) customProtocolCodecs cfg = ProtocolCodecs { pcChainSyncCodec = mapFailureCodec CodecBytesFailure $ @@ -1061,8 +1061,7 @@ type TracingConstraints blk = , Show (Header blk) , Show (GenTx blk) , Show (GenTxId blk) - , Show (Query blk) - , Show (Result blk) + , ShowQuery (Query blk) ) {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/test-util/Test/Util/TestBlock.hs b/ouroboros-consensus/test-util/Test/Util/TestBlock.hs index fd2507305a9..9e6659d735c 100644 --- a/ouroboros-consensus/test-util/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/test-util/Test/Util/TestBlock.hs @@ -4,12 +4,14 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -- | Minimal instantiation of the consensus layer to be able to run the ChainDB @@ -23,7 +25,6 @@ module Test.Util.TestBlock ( , TestBlockError(..) , Header(..) , Query(..) - , Result(..) , firstBlock , successorBlock , modifyFork @@ -62,6 +63,7 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Tree (Tree (..)) import qualified Data.Tree as Tree +import Data.Type.Equality ((:~:) (Refl)) import Data.Word import GHC.Generics (Generic) import qualified System.Random as R @@ -305,13 +307,18 @@ instance ProtocolLedgerView TestBlock where anachronisticProtocolLedgerView _ _ _ = Right () instance QueryLedger TestBlock where - data Query TestBlock = QueryLedgerTip - deriving (Eq, Show, Generic, Serialise) - data Result TestBlock = ResultLedgerTip (Point TestBlock) - deriving (Eq, Show, Generic, Serialise) + data Query TestBlock result where + QueryLedgerTip :: Query TestBlock (Point TestBlock) answerQuery QueryLedgerTip (TestLedger { lastAppliedPoint }) = - ResultLedgerTip lastAppliedPoint + lastAppliedPoint + eqQuery QueryLedgerTip QueryLedgerTip = Just Refl + +deriving instance Eq (Query TestBlock result) +deriving instance Show (Query TestBlock result) + +instance ShowQuery (Query TestBlock) where + showResult QueryLedgerTip = show testInitLedger :: LedgerState TestBlock testInitLedger = TestLedger Block.genesisPoint diff --git a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/LocalStateQuery/Direct.hs b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/LocalStateQuery/Direct.hs index 0f582ce03b2..45bce77d076 100644 --- a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/LocalStateQuery/Direct.hs +++ b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/LocalStateQuery/Direct.hs @@ -8,17 +8,17 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Client import Ouroboros.Network.Protocol.LocalStateQuery.Server direct - :: forall block query result m a b. + :: forall block query m a b. Monad m - => LocalStateQueryClient block query result m a - -> LocalStateQueryServer block query result m b + => LocalStateQueryClient block query m a + -> LocalStateQueryServer block query m b -> m (a, b) direct (LocalStateQueryClient client) (LocalStateQueryServer mserver) = mserver >>= directIdle client where directIdle - :: ClientStIdle block query result m a - -> ServerStIdle block query result m b + :: ClientStIdle block query m a + -> ServerStIdle block query m b -> m (a, b) directIdle (SendMsgAcquire pt client') ServerStIdle{recvMsgAcquire} = do server' <- recvMsgAcquire pt @@ -28,8 +28,8 @@ direct (LocalStateQueryClient client) (LocalStateQueryServer mserver) = return (a, b) directAcquiring - :: ClientStAcquiring block query result m a - -> ServerStAcquiring block query result m b + :: ClientStAcquiring block query m a + -> ServerStAcquiring block query m b -> m (a, b) directAcquiring ClientStAcquiring{recvMsgAcquired} (SendMsgAcquired server') = let client' = recvMsgAcquired @@ -39,8 +39,8 @@ direct (LocalStateQueryClient client) (LocalStateQueryServer mserver) = directIdle client' server' directAcquired - :: ClientStAcquired block query result m a - -> ServerStAcquired block query result m b + :: ClientStAcquired block query m a + -> ServerStAcquired block query m b -> m (a, b) directAcquired (SendMsgQuery query client') ServerStAcquired{recvMsgQuery} = do server' <- recvMsgQuery query @@ -53,8 +53,8 @@ direct (LocalStateQueryClient client) (LocalStateQueryServer mserver) = directIdle client' server' directQuerying - :: ClientStQuerying block query result m a - -> ServerStQuerying block query result m b + :: ClientStQuerying block query m a result + -> ServerStQuerying block query m b result -> m (a, b) directQuerying ClientStQuerying{recvMsgResult} (SendMsgResult result server') = do client' <- recvMsgResult result diff --git a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs index e38911f2794..339527731d3 100644 --- a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs +++ b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs @@ -1,18 +1,19 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Network.Protocol.LocalStateQuery.Test (tests) where +import qualified Codec.CBOR.Decoding as CBOR +import qualified Codec.CBOR.Encoding as CBOR import Data.ByteString.Lazy (ByteString) import Data.Map (Map) import qualified Data.Map as Map -import GHC.Generics (Generic) - import Control.Monad.Class.MonadAsync (MonadAsync) import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadThrow (MonadCatch) @@ -20,7 +21,6 @@ import Control.Monad.IOSim import Control.Monad.ST (runST) import Control.Tracer (nullTracer) -import Codec.Serialise (Serialise) import qualified Codec.Serialise as Serialise (decode, encode) import Network.TypedProtocol.Channel @@ -30,10 +30,7 @@ import Network.TypedProtocol.Proofs import Ouroboros.Network.Channel -import Ouroboros.Network.Block (ChainHash (..), SlotNo, StandardHash, - pointHash, pointSlot) import Ouroboros.Network.MockChain.Chain (Point) -import Ouroboros.Network.Point (WithOrigin (..)) import Ouroboros.Network.Testing.ConcreteBlock (Block) import Ouroboros.Network.Protocol.LocalStateQuery.Client @@ -77,30 +74,25 @@ tests = -- Common types & clients and servers used in the tests in this module. -- -data Query - = QuerySlot - | QueryHash - deriving (Eq, Show, Generic, Serialise) +data Query result where + QueryPoint :: Query (Point Block) -data Result - = ResultSlot (WithOrigin SlotNo) - | ResultHash (ChainHash Block) - deriving (Eq, Show, Generic, Serialise) +deriving instance Show (Query result) -- | Information to test an example server and client. data Setup = Setup - { clientInput :: [(Point Block, [Query])] + { clientInput :: [(Point Block, Query (Point Block))] -- ^ Input for 'localStateQueryClient' , serverAcquire :: Point Block -> Either AcquireFailure (Point Block) -- ^ First input parameter for 'localStateQueryServer' - , serverAnswer :: Point Block -> Query -> Result + , serverAnswer :: forall result. Point Block -> Query result -> result -- ^ Second input parameter for 'localStateQueryServer' - , expected :: [(Point Block, Either AcquireFailure [Result])] + , expected :: [(Point Block, Either AcquireFailure (Point Block))] -- ^ Expected result for the 'localStateQueryClient'. } mkSetup - :: Map (Point Block) (Maybe AcquireFailure, [Query]) + :: Map (Point Block) (Maybe AcquireFailure, Query (Point Block)) -- ^ For each point, the given state queries will be executed. In case of -- the second field is an 'AcquireFailure', the server will fail with -- that failure. @@ -108,7 +100,7 @@ mkSetup -- This is the randomly generated input for the 'Setup'. -> Setup mkSetup input = Setup { - clientInput = [(pt, qs) | (pt, (_, qs)) <- Map.toList input] + clientInput = [(pt, q) | (pt, (_, q)) <- Map.toList input] , serverAcquire = \pt -> case Map.lookup pt input of Just (Just failure, _qs) -> Left failure Just (Nothing, _qs) -> Right pt @@ -117,16 +109,16 @@ mkSetup input = Setup { , serverAnswer = answer , expected = [ (pt, res) - | (pt, (mbFailure, qs)) <- Map.toList input + | (pt, (mbFailure, q)) <- Map.toList input , let res = case mbFailure of - Nothing -> Right $ map (answer pt) qs + Nothing -> Right $ answer pt q Just failure -> Left failure ] } where + answer :: Point Block -> Query result -> result answer pt q = case q of - QuerySlot -> ResultSlot $ pointSlot pt - QueryHash -> ResultHash $ pointHash pt + QueryPoint -> pt -- @@ -136,7 +128,8 @@ mkSetup input = Setup { -- | Run a simple local state query client and server, directly on the wrappers, -- without going via the 'Peer'. -- -prop_direct :: Map (Point Block) (Maybe AcquireFailure, [Query]) -> Property +prop_direct :: Map (Point Block) (Maybe AcquireFailure, Query (Point Block)) + -> Property prop_direct input = runSimOrThrow (direct @@ -155,7 +148,8 @@ prop_direct input = -- | Run a simple local state query client and server, going via the 'Peer' -- representation, but without going via a channel. -- -prop_connect :: Map (Point Block) (Maybe AcquireFailure, [Query]) -> Property +prop_connect :: Map (Point Block) (Maybe AcquireFailure, Query (Point Block)) + -> Property prop_connect input = case runSimOrThrow (connect @@ -177,7 +171,7 @@ prop_connect input = -- prop_channel :: (MonadAsync m, MonadCatch m, MonadST m) => m (Channel m ByteString, Channel m ByteString) - -> Map (Point Block) (Maybe AcquireFailure, [Query]) + -> Map (Point Block) (Maybe AcquireFailure, Query (Point Block)) -> m Property prop_channel createChannels input = @@ -196,20 +190,23 @@ prop_channel createChannels input = -- | Run 'prop_channel' in the simulation monad. -- -prop_channel_ST :: Map (Point Block) (Maybe AcquireFailure, [Query]) -> Property +prop_channel_ST :: Map (Point Block) (Maybe AcquireFailure, Query (Point Block)) + -> Property prop_channel_ST input = runSimOrThrow (prop_channel createConnectedChannels input) -- | Run 'prop_channel' in the IO monad. -- -prop_channel_IO :: Map (Point Block) (Maybe AcquireFailure, [Query]) -> Property +prop_channel_IO :: Map (Point Block) (Maybe AcquireFailure, Query (Point Block)) + -> Property prop_channel_IO input = ioProperty (prop_channel createConnectedChannels input) -- | Run 'prop_channel' in the IO monad using local pipes. -- -prop_pipe_IO :: Map (Point Block) (Maybe AcquireFailure, [Query]) -> Property +prop_pipe_IO :: Map (Point Block) (Maybe AcquireFailure, Query (Point Block)) + -> Property prop_pipe_IO input = ioProperty (prop_channel createPipeConnectedChannels input) @@ -224,22 +221,10 @@ instance Arbitrary AcquireFailure where , AcquireFailurePointNotOnChain ] -instance Arbitrary Query where - arbitrary = elements [QuerySlot, QueryHash] +instance Arbitrary (Query (Point Block)) where + arbitrary = pure QueryPoint -instance Arbitrary Result where - arbitrary = oneof - [ ResultSlot <$> frequency - [ (1, pure Origin) - , (9, At <$> arbitrary) - ] - , ResultHash <$> frequency - [ (1, pure GenesisHash) - , (9, BlockHash <$> arbitrary) - ] - ] - -instance Arbitrary (AnyMessageAndAgency (LocalStateQuery Block Query Result)) where +instance Arbitrary (AnyMessageAndAgency (LocalStateQuery Block Query)) where arbitrary = oneof [ AnyMessageAndAgency (ClientAgency TokIdle) <$> (MsgAcquire <$> arbitrary) @@ -251,10 +236,10 @@ instance Arbitrary (AnyMessageAndAgency (LocalStateQuery Block Query Result)) wh (MsgFailure <$> arbitrary) , AnyMessageAndAgency (ClientAgency TokAcquired) <$> - (MsgQuery <$> arbitrary) + (MsgQuery <$> (arbitrary :: Gen (Query (Point Block)))) - , AnyMessageAndAgency (ServerAgency TokQuerying) <$> - (MsgResult <$> arbitrary) + , AnyMessageAndAgency (ServerAgency (TokQuerying QueryPoint)) <$> + (MsgResult QueryPoint <$> arbitrary) , AnyMessageAndAgency (ClientAgency TokAcquired) <$> pure MsgRelease @@ -266,12 +251,13 @@ instance Arbitrary (AnyMessageAndAgency (LocalStateQuery Block Query Result)) wh pure MsgDone ] -instance (StandardHash block, Show query, Show result) => - Show (AnyMessageAndAgency (LocalStateQuery block query result)) where +instance ShowQuery Query where + showResult QueryPoint = show + +instance Show (AnyMessageAndAgency (LocalStateQuery Block Query)) where show (AnyMessageAndAgency _ msg) = show msg -instance (StandardHash block, Eq query, Eq result) => - Eq (AnyMessage (LocalStateQuery block query result)) where +instance Eq (AnyMessage (LocalStateQuery Block Query)) where (==) (AnyMessage (MsgAcquire pt)) (AnyMessage (MsgAcquire pt')) = pt == pt' @@ -283,10 +269,14 @@ instance (StandardHash block, Eq query, Eq result) => (AnyMessage (MsgFailure failure')) = failure == failure' (==) (AnyMessage (MsgQuery query)) - (AnyMessage (MsgQuery query')) = query == query' + (AnyMessage (MsgQuery query')) = + case (query, query') of + (QueryPoint, QueryPoint) -> True - (==) (AnyMessage (MsgResult result)) - (AnyMessage (MsgResult result')) = result == result' + (==) (AnyMessage (MsgResult query result)) + (AnyMessage (MsgResult query' result')) = + case (query, query') of + (QueryPoint, QueryPoint) -> result == result' (==) (AnyMessage MsgRelease) (AnyMessage MsgRelease) = True @@ -301,34 +291,48 @@ instance (StandardHash block, Eq query, Eq result) => codec :: MonadST m - => Codec (LocalStateQuery Block Query Result) + => Codec (LocalStateQuery Block Query) DeserialiseFailure m ByteString codec = codecLocalStateQuery Serialise.encode Serialise.decode - Serialise.encode Serialise.decode - Serialise.encode Serialise.decode + encodeQuery decodeQuery + encodeResult decodeResult + where + encodeQuery :: Query result -> CBOR.Encoding + encodeQuery QueryPoint = Serialise.encode () + + decodeQuery :: forall s . CBOR.Decoder s (Some Query) + decodeQuery = do + () <- Serialise.decode + return $ Some QueryPoint + + encodeResult :: Query result -> result -> CBOR.Encoding + encodeResult QueryPoint = Serialise.encode + + decodeResult :: Query result -> forall s. CBOR.Decoder s result + decodeResult QueryPoint = Serialise.decode -- | Check the codec round trip property. -- -prop_codec :: AnyMessageAndAgency (LocalStateQuery Block Query Result) -> Bool +prop_codec :: AnyMessageAndAgency (LocalStateQuery Block Query) -> Bool prop_codec msg = runST (prop_codecM codec msg) -- | Check for data chunk boundary problems in the codec using 2 chunks. -- -prop_codec_splits2 :: AnyMessageAndAgency (LocalStateQuery Block Query Result) -> Bool +prop_codec_splits2 :: AnyMessageAndAgency (LocalStateQuery Block Query) -> Bool prop_codec_splits2 msg = runST (prop_codec_splitsM splits2 codec msg) -- | Check for data chunk boundary problems in the codec using 3 chunks. -- -prop_codec_splits3 :: AnyMessageAndAgency (LocalStateQuery Block Query Result) -> Bool +prop_codec_splits3 :: AnyMessageAndAgency (LocalStateQuery Block Query) -> Bool prop_codec_splits3 msg = runST (prop_codec_splitsM splits3 codec msg) prop_codec_cbor - :: AnyMessageAndAgency (LocalStateQuery Block Query Result) + :: AnyMessageAndAgency (LocalStateQuery Block Query) -> Bool prop_codec_cbor msg = runST (prop_codec_cborM codec msg) diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Client.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Client.hs index 36c62f19c66..738540e7ea1 100644 --- a/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Client.hs +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Client.hs @@ -22,8 +22,8 @@ import Ouroboros.Network.Block (Point) import Ouroboros.Network.Protocol.LocalStateQuery.Type -newtype LocalStateQueryClient block query result m a = LocalStateQueryClient { - runLocalStateQueryClient :: ClientStIdle block query result m a +newtype LocalStateQueryClient block query m a = LocalStateQueryClient { + runLocalStateQueryClient :: ClientStIdle block query m a } -- | In the 'StIdle' protocol state, the client has agency and must send: @@ -31,13 +31,13 @@ newtype LocalStateQueryClient block query result m a = LocalStateQueryClient { -- * a request to acquire a state -- * a termination messge -- -data ClientStIdle block query result (m :: * -> *) a where +data ClientStIdle block query (m :: * -> *) a where SendMsgAcquire :: Point block - -> ClientStAcquiring block query result m a - -> ClientStIdle block query result m a + -> ClientStAcquiring block query m a + -> ClientStIdle block query m a SendMsgDone :: a - -> ClientStIdle block query result m a + -> ClientStIdle block query m a -- | In the 'StAcquiring' protocol state, the client does not have agency. -- Instead it is waiting for: @@ -47,11 +47,11 @@ data ClientStIdle block query result (m :: * -> *) a where -- -- It must be prepared to handle either. -- -data ClientStAcquiring block query result m a = ClientStAcquiring { - recvMsgAcquired :: ClientStAcquired block query result m a, +data ClientStAcquiring block query m a = ClientStAcquiring { + recvMsgAcquired :: ClientStAcquired block query m a, recvMsgFailure :: AcquireFailure - -> m (ClientStIdle block query result m a) + -> m (ClientStIdle block query m a) } -- | In the 'StAcquired' protocol state, the client has agency and must send: @@ -60,41 +60,41 @@ data ClientStAcquiring block query result m a = ClientStAcquiring { -- * a request to (re)acquire another state -- * a release of the current state -- -data ClientStAcquired block query result m a where - SendMsgQuery :: query - -> ClientStQuerying block query result m a - -> ClientStAcquired block query result m a +data ClientStAcquired block query m a where + SendMsgQuery :: query result + -> ClientStQuerying block query m a result + -> ClientStAcquired block query m a SendMsgReAcquire :: Point block - -> ClientStAcquiring block query result m a - -> ClientStAcquired block query result m a + -> ClientStAcquiring block query m a + -> ClientStAcquired block query m a - SendMsgRelease :: ClientStIdle block query result m a - -> ClientStAcquired block query result m a + SendMsgRelease :: ClientStIdle block query m a + -> ClientStAcquired block query m a -- | In the 'StQuerying' protocol state, the client does not have agency. -- Instead it is waiting for: -- -- * a result -- -data ClientStQuerying block query result m a = ClientStQuerying { - recvMsgResult :: result -> m (ClientStAcquired block query result m a) +data ClientStQuerying block query m a result = ClientStQuerying { + recvMsgResult :: result -> m (ClientStAcquired block query m a) } -- | Interpret a 'LocalStateQueryClient' action sequence as a 'Peer' on the -- client side of the 'LocalStateQuery' protocol. -- localStateQueryClientPeer - :: forall block query result m a. + :: forall block query m a. Monad m - => LocalStateQueryClient block query result m a - -> Peer (LocalStateQuery block query result) AsClient StIdle m a + => LocalStateQueryClient block query m a + -> Peer (LocalStateQuery block query) AsClient StIdle m a localStateQueryClientPeer (LocalStateQueryClient handler) = handleStIdle handler where handleStIdle - :: ClientStIdle block query result m a - -> Peer (LocalStateQuery block query result) AsClient StIdle m a + :: ClientStIdle block query m a + -> Peer (LocalStateQuery block query) AsClient StIdle m a handleStIdle req = case req of SendMsgAcquire pt stAcquiring -> Yield (ClientAgency TokIdle) @@ -106,21 +106,21 @@ localStateQueryClientPeer (LocalStateQueryClient handler) = (Done TokDone a) handleStAcquiring - :: ClientStAcquiring block query result m a - -> Peer (LocalStateQuery block query result) AsClient StAcquiring m a + :: ClientStAcquiring block query m a + -> Peer (LocalStateQuery block query) AsClient StAcquiring m a handleStAcquiring ClientStAcquiring{recvMsgAcquired, recvMsgFailure} = Await (ServerAgency TokAcquiring) $ \req -> case req of MsgAcquired -> handleStAcquired recvMsgAcquired MsgFailure failure -> Effect $ handleStIdle <$> recvMsgFailure failure handleStAcquired - :: ClientStAcquired block query result m a - -> Peer (LocalStateQuery block query result) AsClient StAcquired m a + :: ClientStAcquired block query m a + -> Peer (LocalStateQuery block query) AsClient StAcquired m a handleStAcquired req = case req of SendMsgQuery query stQuerying -> Yield (ClientAgency TokAcquired) (MsgQuery query) - (handleStQuerying stQuerying) + (handleStQuerying query stQuerying) SendMsgReAcquire pt stAcquiring -> Yield (ClientAgency TokAcquired) (MsgReAcquire pt) @@ -131,8 +131,9 @@ localStateQueryClientPeer (LocalStateQueryClient handler) = (handleStIdle stIdle) handleStQuerying - :: ClientStQuerying block query result m a - -> Peer (LocalStateQuery block query result) AsClient StQuerying m a - handleStQuerying ClientStQuerying{recvMsgResult} = - Await (ServerAgency TokQuerying) $ \req -> case req of - MsgResult result -> Effect (handleStAcquired <$> recvMsgResult result) + :: query result + -> ClientStQuerying block query m a result + -> Peer (LocalStateQuery block query) AsClient (StQuerying result) m a + handleStQuerying query ClientStQuerying{recvMsgResult} = + Await (ServerAgency (TokQuerying query)) $ \req -> case req of + MsgResult _ result -> Effect (handleStAcquired <$> recvMsgResult result) diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Codec.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Codec.hs index 9f6104040b8..2687ea22072 100644 --- a/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Codec.hs +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Codec.hs @@ -4,9 +4,12 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + module Ouroboros.Network.Protocol.LocalStateQuery.Codec ( codecLocalStateQuery , codecLocalStateQueryId + , Some (..) ) where import Control.Monad.Class.MonadST @@ -15,6 +18,7 @@ import qualified Codec.CBOR.Decoding as CBOR import qualified Codec.CBOR.Encoding as CBOR import qualified Codec.CBOR.Read as CBOR import Data.ByteString.Lazy (ByteString) +import Data.Type.Equality ((:~:) (..)) import Network.TypedProtocol.Codec.Cbor @@ -22,16 +26,19 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Type import Ouroboros.Network.Block (Point) +data Some (f :: k -> *) where + Some :: f a -> Some f + codecLocalStateQuery - :: forall block query result m. + :: forall block query m. MonadST m => (Point block -> CBOR.Encoding) -> (forall s . CBOR.Decoder s (Point block)) - -> (query -> CBOR.Encoding) - -> (forall s . CBOR.Decoder s query) - -> (result -> CBOR.Encoding) - -> (forall s . CBOR.Decoder s result) - -> Codec (LocalStateQuery block query result) CBOR.DeserialiseFailure m ByteString + -> (forall result . query result -> CBOR.Encoding) + -> (forall s . CBOR.Decoder s (Some query)) + -> (forall result . query result -> result -> CBOR.Encoding) + -> (forall result . query result -> forall s . CBOR.Decoder s result) + -> Codec (LocalStateQuery block query) CBOR.DeserialiseFailure m ByteString codecLocalStateQuery encodePoint decodePoint encodeQuery decodeQuery encodeResult decodeResult = @@ -49,9 +56,11 @@ codecLocalStateQuery encodePoint decodePoint 1 -> return AcquireFailurePointNotOnChain _ -> fail $ "decodeFailure: invalid tag " <> show tag - encode :: forall (pr :: PeerRole) st st'. + encode :: forall (pr :: PeerRole) + (st :: LocalStateQuery block query) + (st' :: LocalStateQuery block query). PeerHasAgency pr st - -> Message (LocalStateQuery block query result) st st' + -> Message (LocalStateQuery block query) st st' -> CBOR.Encoding encode (ClientAgency TokIdle) (MsgAcquire pt) = CBOR.encodeListLen 2 @@ -72,10 +81,10 @@ codecLocalStateQuery encodePoint decodePoint <> CBOR.encodeWord 3 <> encodeQuery query - encode (ServerAgency TokQuerying) (MsgResult result) = + encode (ServerAgency (TokQuerying _query)) (MsgResult query result) = CBOR.encodeListLen 2 <> CBOR.encodeWord 4 - <> encodeResult result + <> encodeResult query result encode (ClientAgency TokAcquired) MsgRelease = CBOR.encodeListLen 1 @@ -90,7 +99,7 @@ codecLocalStateQuery encodePoint decodePoint CBOR.encodeListLen 1 <> CBOR.encodeWord 7 - decode :: forall (pr :: PeerRole) s (st :: LocalStateQuery block query result). + decode :: forall (pr :: PeerRole) s (st :: LocalStateQuery block query). PeerHasAgency pr st -> CBOR.Decoder s (SomeMessage st) decode stok = do @@ -109,12 +118,12 @@ codecLocalStateQuery encodePoint decodePoint return (SomeMessage (MsgFailure failure)) (ClientAgency TokAcquired, 2, 3) -> do - query <- decodeQuery + Some query <- decodeQuery return (SomeMessage (MsgQuery query)) - (ServerAgency TokQuerying, 2, 4) -> do - result <- decodeResult - return (SomeMessage (MsgResult result)) + (ServerAgency (TokQuerying query), 2, 4) -> do + result <- decodeResult query + return (SomeMessage (MsgResult query result)) (ClientAgency TokAcquired, 1, 5) -> return (SomeMessage MsgRelease) @@ -132,7 +141,7 @@ codecLocalStateQuery encodePoint decodePoint fail "codecLocalStateQuery.Acquired: unexpected key" (ServerAgency TokAcquiring, _, _) -> fail "codecLocalStateQuery.Acquiring: unexpected key" - (ServerAgency TokQuerying, _, _) -> + (ServerAgency (TokQuerying _), _, _) -> fail "codecLocalStateQuery.Querying: unexpected key" @@ -140,36 +149,44 @@ codecLocalStateQuery encodePoint decodePoint -- any serialisation. It keeps the typed messages, wrapped in 'AnyMessage'. -- codecLocalStateQueryId - :: forall block query result m. + :: forall block (query :: * -> *) m. Monad m - => Codec (LocalStateQuery block query result) + => (forall result1 result2. + query result1 + -> query result2 + -> Maybe (result1 :~: result2) + ) + -> Codec (LocalStateQuery block query) CodecFailure m - (AnyMessage (LocalStateQuery block query result)) -codecLocalStateQueryId = + (AnyMessage (LocalStateQuery block query)) +codecLocalStateQueryId eqQuery = Codec encode decode where encode :: forall (pr :: PeerRole) st st'. PeerHasAgency pr st - -> Message (LocalStateQuery block query result) st st' - -> AnyMessage (LocalStateQuery block query result) + -> Message (LocalStateQuery block query) st st' + -> AnyMessage (LocalStateQuery block query) encode _ = AnyMessage - decode :: forall (pr :: PeerRole) st. + decode :: forall (pr :: PeerRole) (st :: LocalStateQuery block query). PeerHasAgency pr st - -> m (DecodeStep (AnyMessage (LocalStateQuery block query result)) + -> m (DecodeStep (AnyMessage (LocalStateQuery block query)) CodecFailure m (SomeMessage st)) decode stok = return $ DecodePartial $ \bytes -> case (stok, bytes) of - (ClientAgency TokIdle, Just (AnyMessage msg@(MsgAcquire{}))) -> res msg - (ClientAgency TokIdle, Just (AnyMessage msg@(MsgDone{}))) -> res msg - (ClientAgency TokAcquired, Just (AnyMessage msg@(MsgQuery{}))) -> res msg - (ClientAgency TokAcquired, Just (AnyMessage msg@(MsgReAcquire{}))) -> res msg - (ClientAgency TokAcquired, Just (AnyMessage msg@(MsgRelease{}))) -> res msg - (ServerAgency TokAcquiring, Just (AnyMessage msg@(MsgAcquired{}))) -> res msg - (ServerAgency TokAcquiring, Just (AnyMessage msg@(MsgFailure{}))) -> res msg - (ServerAgency TokQuerying, Just (AnyMessage msg@(MsgResult{}))) -> res msg + (ClientAgency TokIdle, Just (AnyMessage msg@(MsgAcquire{}))) -> res msg + (ClientAgency TokIdle, Just (AnyMessage msg@(MsgDone{}))) -> res msg + (ClientAgency TokAcquired, Just (AnyMessage msg@(MsgQuery{}))) -> res msg + (ClientAgency TokAcquired, Just (AnyMessage msg@(MsgReAcquire{}))) -> res msg + (ClientAgency TokAcquired, Just (AnyMessage msg@(MsgRelease{}))) -> res msg + (ServerAgency TokAcquiring, Just (AnyMessage msg@(MsgAcquired{}))) -> res msg + (ServerAgency TokAcquiring, Just (AnyMessage msg@(MsgFailure{}))) -> res msg + (ServerAgency (TokQuerying q), Just (AnyMessage msg@(MsgResult query _))) + | Just Refl <- eqQuery q query + -> res msg (_, Nothing) -> return (DecodeFail CodecFailureOutOfInput) (_, _) -> return (DecodeFail (CodecFailure failmsg)) - res :: Message (LocalStateQuery block query result) st st' -> m (DecodeStep bytes failure m (SomeMessage st)) + res :: Message (LocalStateQuery block query) st st' + -> m (DecodeStep bytes failure m (SomeMessage st)) res msg = return (DecodeDone (SomeMessage msg) Nothing) failmsg = "codecLocalStateQueryId: no matching message" diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Examples.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Examples.hs index 0db20696eda..88042771ea7 100644 --- a/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Examples.hs +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Examples.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Ouroboros.Network.Protocol.LocalStateQuery.Examples where @@ -15,56 +16,52 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Type -- | An example 'LocalStateQueryClient', which, for each point in the given -- list, acquires the state for that point, and if that succeeds, returns the --- results for all the corresponding queries. When the state could not be --- acquired, the 'AcquireFailure' is returned instead of the query results. +-- result for the corresponding query. When the state could not be acquired, +-- the 'AcquireFailure' is returned instead of the query results. -- localStateQueryClient :: forall block query result m. Applicative m - => [(Point block, [query])] - -> LocalStateQueryClient block query result m - [(Point block, Either AcquireFailure [result])] + => [(Point block, query result)] + -> LocalStateQueryClient block query m + [(Point block, Either AcquireFailure result)] localStateQueryClient = LocalStateQueryClient . goIdle [] where goIdle - :: [(Point block, Either AcquireFailure [result])] -- ^ Accumulator - -> [(Point block, [query])] -- ^ Remainder - -> ClientStIdle block query result m - [(Point block, Either AcquireFailure [result])] - goIdle acc [] = SendMsgDone $ reverse acc - goIdle acc ((pt, qs):ptqss') = SendMsgAcquire pt $ - goAcquiring acc pt qs ptqss' + :: [(Point block, Either AcquireFailure result)] -- ^ Accumulator + -> [(Point block, query result)] -- ^ Remainder + -> ClientStIdle block query m + [(Point block, Either AcquireFailure result)] + goIdle acc [] = SendMsgDone $ reverse acc + goIdle acc ((pt, q):ptqs') = SendMsgAcquire pt $ goAcquiring acc pt q ptqs' goAcquiring - :: [(Point block, Either AcquireFailure [result])] -- ^ Accumulator + :: [(Point block, Either AcquireFailure result)] -- ^ Accumulator -> Point block - -> [query] - -> [(Point block, [query])] -- ^ Remainder - -> ClientStAcquiring block query result m - [(Point block, Either AcquireFailure [result])] - goAcquiring acc pt qs ptqss' = ClientStAcquiring { - recvMsgAcquired = goQuery [] qs $ \rs -> goAcquired ((pt, Right rs):acc) ptqss' + -> query result + -> [(Point block, query result)] -- ^ Remainder + -> ClientStAcquiring block query m + [(Point block, Either AcquireFailure result)] + goAcquiring acc pt q ptqss' = ClientStAcquiring { + recvMsgAcquired = goQuery q $ \r -> goAcquired ((pt, Right r):acc) ptqss' , recvMsgFailure = \failure -> pure $ goIdle ((pt, Left failure):acc) ptqss' } goAcquired - :: [(Point block, Either AcquireFailure [result])] - -> [(Point block, [query])] -- ^ Remainder - -> ClientStAcquired block query result m - [(Point block, Either AcquireFailure [result])] + :: [(Point block, Either AcquireFailure result)] + -> [(Point block, query result)] -- ^ Remainder + -> ClientStAcquired block query m + [(Point block, Either AcquireFailure result)] goAcquired acc [] = SendMsgRelease $ SendMsgDone $ reverse acc goAcquired acc ((pt, qs):ptqss') = SendMsgReAcquire pt $ goAcquiring acc pt qs ptqss' goQuery :: forall a. - [result] -- ^ Result accumulator - -> [query] - -> ([result] -> ClientStAcquired block query result m a) + query result + -> (result -> ClientStAcquired block query m a) -- ^ Continuation - -> ClientStAcquired block query result m a - goQuery acc [] k = k (reverse acc) - goQuery acc (q:qs') k = SendMsgQuery q $ ClientStQuerying $ \r -> - pure $ goQuery (r:acc) qs' k + -> ClientStAcquired block query m a + goQuery q k = SendMsgQuery q $ ClientStQuerying $ \r -> pure $ k r -- -- Example server @@ -74,25 +71,25 @@ localStateQueryClient = LocalStateQueryClient . goIdle [] -- acquire a @state@, after which the second will be used to query the state. -- localStateQueryServer - :: forall block query result m state. Applicative m + :: forall block query m state. Applicative m => (Point block -> Either AcquireFailure state) - -> (state -> query -> result) - -> LocalStateQueryServer block query result m () + -> (forall result. state -> query result -> result) + -> LocalStateQueryServer block query m () localStateQueryServer acquire answer = LocalStateQueryServer $ pure goIdle where - goIdle :: ServerStIdle block query result m () + goIdle :: ServerStIdle block query m () goIdle = ServerStIdle { recvMsgAcquire = goAcquiring , recvMsgDone = pure () } - goAcquiring :: Point block -> m (ServerStAcquiring block query result m ()) + goAcquiring :: Point block -> m (ServerStAcquiring block query m ()) goAcquiring pt = pure $ case acquire pt of Left failure -> SendMsgFailure failure goIdle Right state -> SendMsgAcquired $ goAcquired state - goAcquired :: state -> ServerStAcquired block query result m () + goAcquired :: state -> ServerStAcquired block query m () goAcquired state = ServerStAcquired { recvMsgQuery = \query -> pure $ SendMsgResult (answer state query) $ goAcquired state diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Server.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Server.hs index 71118579f7f..4ad3a89d5c2 100644 --- a/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Server.hs +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Server.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Ouroboros.Network.Protocol.LocalStateQuery.Server ( -- * Protocol type for the server @@ -21,8 +22,8 @@ import Ouroboros.Network.Block (Point) import Ouroboros.Network.Protocol.LocalStateQuery.Type -newtype LocalStateQueryServer block query result m a = LocalStateQueryServer { - runLocalStateQueryServer :: m (ServerStIdle block query result m a) +newtype LocalStateQueryServer block query m a = LocalStateQueryServer { + runLocalStateQueryServer :: m (ServerStIdle block query m a) } -- | In the 'StIdle' protocol state, the server does not have agency. Instead @@ -33,9 +34,9 @@ newtype LocalStateQueryServer block query result m a = LocalStateQueryServer { -- -- It must be prepared to handle either. -- -data ServerStIdle block query result m a = ServerStIdle { +data ServerStIdle block query m a = ServerStIdle { recvMsgAcquire :: Point block - -> m (ServerStAcquiring block query result m a), + -> m (ServerStAcquiring block query m a), recvMsgDone :: m a } @@ -46,16 +47,16 @@ data ServerStIdle block query result m a = ServerStIdle { -- * acquired -- * failure to acquire -- -data ServerStAcquiring block query result m a where - SendMsgAcquired :: ServerStAcquired block query result m a - -> ServerStAcquiring block query result m a +data ServerStAcquiring block query m a where + SendMsgAcquired :: ServerStAcquired block query m a + -> ServerStAcquiring block query m a SendMsgFailure :: AcquireFailure - -> ServerStIdle block query result m a - -> ServerStAcquiring block query result m a + -> ServerStIdle block query m a + -> ServerStAcquiring block query m a --- | In the 'StAcquired' protocol state, the server does not have agency. Instead --- it is waiting for: +-- | In the 'StAcquired' protocol state, the server does not have agency. +-- Instead it is waiting for: -- -- * a query -- * a request to (re)acquire another state @@ -63,39 +64,40 @@ data ServerStAcquiring block query result m a where -- -- It must be prepared to handle either. -- -data ServerStAcquired block query result m a = ServerStAcquired { - recvMsgQuery :: query - -> m (ServerStQuerying block query result m a), +data ServerStAcquired block query m a = ServerStAcquired { + recvMsgQuery :: forall result. + query result + -> m (ServerStQuerying block query m a result), recvMsgReAcquire :: Point block - -> m (ServerStAcquiring block query result m a), + -> m (ServerStAcquiring block query m a), - recvMsgRelease :: m (ServerStIdle block query result m a) + recvMsgRelease :: m (ServerStIdle block query m a) } -- | In the 'StQuerying' protocol state, the server has agency and must send: -- -- * a result -- -data ServerStQuerying block query result m a where +data ServerStQuerying block query m a result where SendMsgResult :: result - -> ServerStAcquired block query result m a - -> ServerStQuerying block query result m a + -> ServerStAcquired block query m a + -> ServerStQuerying block query m a result -- | Interpret a 'LocalStateQueryServer' action sequence as a 'Peer' on the server -- side of the 'LocalStateQuery' protocol. -- localStateQueryServerPeer - :: forall block query result m a. + :: forall block query m a. Monad m - => LocalStateQueryServer block query result m a - -> Peer (LocalStateQuery block query result) AsServer StIdle m a + => LocalStateQueryServer block query m a + -> Peer (LocalStateQuery block query) AsServer StIdle m a localStateQueryServerPeer (LocalStateQueryServer handler) = Effect $ handleStIdle <$> handler where handleStIdle - :: ServerStIdle block query result m a - -> Peer (LocalStateQuery block query result) AsServer StIdle m a + :: ServerStIdle block query m a + -> Peer (LocalStateQuery block query) AsServer StIdle m a handleStIdle ServerStIdle{recvMsgAcquire, recvMsgDone} = Await (ClientAgency TokIdle) $ \req -> case req of MsgAcquire pt -> Effect $ @@ -104,8 +106,8 @@ localStateQueryServerPeer (LocalStateQueryServer handler) = Done TokDone <$> recvMsgDone handleStAcquiring - :: ServerStAcquiring block query result m a - -> Peer (LocalStateQuery block query result) AsServer StAcquiring m a + :: ServerStAcquiring block query m a + -> Peer (LocalStateQuery block query) AsServer StAcquiring m a handleStAcquiring req = case req of SendMsgAcquired stAcquired -> Yield (ServerAgency TokAcquiring) @@ -117,18 +119,19 @@ localStateQueryServerPeer (LocalStateQueryServer handler) = (handleStIdle stIdle) handleStAcquired - :: ServerStAcquired block query result m a - -> Peer (LocalStateQuery block query result) AsServer StAcquired m a + :: ServerStAcquired block query m a + -> Peer (LocalStateQuery block query) AsServer StAcquired m a handleStAcquired ServerStAcquired{recvMsgQuery, recvMsgReAcquire, recvMsgRelease} = Await (ClientAgency TokAcquired) $ \req -> case req of - MsgQuery query -> Effect $ handleStQuerying <$> recvMsgQuery query - MsgReAcquire pt -> Effect $ handleStAcquiring <$> recvMsgReAcquire pt - MsgRelease -> Effect $ handleStIdle <$> recvMsgRelease + MsgQuery query -> Effect $ handleStQuerying query <$> recvMsgQuery query + MsgReAcquire pt -> Effect $ handleStAcquiring <$> recvMsgReAcquire pt + MsgRelease -> Effect $ handleStIdle <$> recvMsgRelease handleStQuerying - :: ServerStQuerying block query result m a - -> Peer (LocalStateQuery block query result) AsServer StQuerying m a - handleStQuerying (SendMsgResult result stAcquired) = - Yield (ServerAgency TokQuerying) - (MsgResult result) + :: query result + -> ServerStQuerying block query m a result + -> Peer (LocalStateQuery block query) AsServer (StQuerying result) m a + handleStQuerying query (SendMsgResult result stAcquired) = + Yield (ServerAgency (TokQuerying query)) + (MsgResult query result) (handleStAcquired stAcquired) diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Type.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Type.hs index 6c84e420782..a5613978e5c 100644 --- a/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Type.hs +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/LocalStateQuery/Type.hs @@ -1,10 +1,13 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | The type of the local ledger state query protocol. -- @@ -13,9 +16,8 @@ -- module Ouroboros.Network.Protocol.LocalStateQuery.Type where - -import Network.TypedProtocol.Core -import Ouroboros.Network.Block (Point, StandardHash) +import Network.TypedProtocol.Core +import Ouroboros.Network.Block (Point, StandardHash) -- | The kind of the local state query protocol, and the types of @@ -24,42 +26,41 @@ import Ouroboros.Network.Block (Point, StandardHash) -- It is parametrised over the type of block (for points), the type of queries -- and query results. -- -data LocalStateQuery block query result where +data LocalStateQuery block query where -- | The client has agency. It can ask to acquire a state or terminate. -- -- There is no timeout in this state. -- - StIdle :: LocalStateQuery block query result + StIdle :: LocalStateQuery block query -- | The server has agency. it must acquire the state at the requested point -- or report a failure. -- -- There is a timeout in this state. -- - StAcquiring :: LocalStateQuery block query result + StAcquiring :: LocalStateQuery block query -- | The client has agency. It can request queries against the current state, -- or it can release the state. -- - StAcquired :: LocalStateQuery block query result + StAcquired :: LocalStateQuery block query -- | The server has agency. It must respond with the query result. -- - StQuerying :: LocalStateQuery block query result + StQuerying :: result -> LocalStateQuery block query -- | Nobody has agency. The terminal state. -- - StDone :: LocalStateQuery block query result - + StDone :: LocalStateQuery block query -instance Protocol (LocalStateQuery block query result) where +instance Protocol (LocalStateQuery block query) where -- | The messages in the state query protocol. -- - -- The pattern of use is to + -- The pattern of use is to -- - data Message (LocalStateQuery block query result) from to where + data Message (LocalStateQuery block query) from to where -- | The client requests that the state as of a particular recent point on -- the server's chain (within K of the tip) be made available to query, @@ -67,37 +68,40 @@ instance Protocol (LocalStateQuery block query result) where -- MsgAcquire :: Point block - -> Message (LocalStateQuery block query result) StIdle StAcquiring + -> Message (LocalStateQuery block query) StIdle StAcquiring -- | The server can confirm that it has the state at the requested point. -- MsgAcquired - :: Message (LocalStateQuery block query result) StAcquiring StAcquired + :: Message (LocalStateQuery block query) StAcquiring StAcquired -- | The server can report that it cannot obtain the state for the -- requested point. -- MsgFailure :: AcquireFailure - -> Message (LocalStateQuery block query result) StAcquiring StIdle + -> Message (LocalStateQuery block query) StAcquiring StIdle -- | The client can perform queries on the current acquired state. -- MsgQuery - :: query - -> Message (LocalStateQuery block query result) StAcquired StQuerying + :: query result + -> Message (LocalStateQuery block query) StAcquired (StQuerying result) - -- | The server must reply with the query results. + -- | The server must reply with the queries. -- MsgResult - :: result - -> Message (LocalStateQuery block query result) StQuerying StAcquired + :: query result + -- ^ The query will not be sent across the network, it is solely used + -- as evidence that @result@ is a valid type index of @query@. + -> result + -> Message (LocalStateQuery block query) (StQuerying result) StAcquired -- | The client can instruct the server to release the state. This lets -- the server free resources. -- MsgRelease - :: Message (LocalStateQuery block query result) StAcquired StIdle + :: Message (LocalStateQuery block query) StAcquired StIdle -- | This is like 'MsgAcquire' but for when the client already has a -- state. By moveing to another state directly without a 'MsgRelease' it @@ -109,12 +113,12 @@ instance Protocol (LocalStateQuery block query result) where -- MsgReAcquire :: Point block - -> Message (LocalStateQuery block query result) StAcquired StAcquiring + -> Message (LocalStateQuery block query) StAcquired StAcquiring -- | The client can terminate the protocol. -- MsgDone - :: Message (LocalStateQuery block query result) StIdle StDone + :: Message (LocalStateQuery block query) StIdle StDone data ClientHasAgency st where @@ -123,7 +127,8 @@ instance Protocol (LocalStateQuery block query result) where data ServerHasAgency st where TokAcquiring :: ServerHasAgency StAcquiring - TokQuerying :: ServerHasAgency StQuerying + TokQuerying :: query result + -> ServerHasAgency (StQuerying result :: LocalStateQuery block query) data NobodyHasAgency st where TokDone :: NobodyHasAgency StDone @@ -140,13 +145,47 @@ data AcquireFailure = AcquireFailurePointTooOld | AcquireFailurePointNotOnChain deriving (Eq, Enum, Show) -deriving instance (StandardHash block, Show query, Show result) => - Show (Message (LocalStateQuery block query result) from to) - -instance Show (ClientHasAgency (st :: LocalStateQuery block query result)) where +instance Show (ClientHasAgency (st :: LocalStateQuery block query)) where show TokIdle = "TokIdle" show TokAcquired = "TokAcquired" -instance Show (ServerHasAgency (st :: LocalStateQuery block query result)) where - show TokAcquiring = "TokAcquiring" - show TokQuerying = "TokQuerying" +instance Show (ServerHasAgency (st :: LocalStateQuery block query)) where + show TokAcquiring = "TokAcquiring" + show (TokQuerying _) = "TokQuerying" + +-- | To implement 'Show' for: +-- +-- > ('Message' ('LocalStateQuery' block query) st st') +-- +-- we need a way to print the @query@ GADT and its type index, @result@. This +-- class contain the method we need to provide this 'Show' instance. +-- +-- We use a type class for this, as this 'Show' constraint propagates to a lot +-- of places. +class (forall result. Show (query result)) => ShowQuery query where + showResult :: forall result. query result -> result -> String + +instance (ShowQuery query, StandardHash block) + => Show (Message (LocalStateQuery block query) st st') where + showsPrec p msg = case msg of + MsgAcquire pt -> showParen (p >= 11) $ + showString "MsgAcquire " . + showsPrec 11 pt + MsgAcquired -> + showString "MsgAcquired" + MsgFailure failure -> showParen (p >= 11) $ + showString "MsgFailure " . + showsPrec 11 failure + MsgQuery query -> showParen (p >= 11) $ + showString "MsgQuery " . + showsPrec 11 query + MsgResult query result -> showParen (p >= 11) $ + showString "MsgResult " . + showParen True (showString (showResult query result)) + MsgRelease -> + showString "MsgRelease" + MsgReAcquire pt -> showParen (p >= 11) $ + showString "MsgReAcquire " . + showsPrec 11 pt + MsgDone -> + showString "MsgDone"