Skip to content
Merged
Show file tree
Hide file tree
Changes from 3 commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
7 changes: 6 additions & 1 deletion ouroboros-network-protocols/bench-cddl/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -318,7 +318,12 @@ localStateQueryMessages =
(Stateful.AnyMessage
StateIdle
(LocalStateQuery.MsgAcquire
(SpecificPoint (BlockPoint largeCBORBS))))
(SpecificPoint (BlockPoint largeCBORBS)) Nothing))
, AnyMessageWithResult
(Stateful.AnyMessage
StateIdle
(LocalStateQuery.MsgAcquire
(SpecificPoint (BlockPoint largeCBORBS)) (Just 2600)))
, AnyMessageWithResult
(Stateful.AnyMessage
StateAcquiring
Expand Down
6 changes: 3 additions & 3 deletions ouroboros-network-protocols/cddl/specs/local-state-query.cddl
Original file line number Diff line number Diff line change
Expand Up @@ -23,9 +23,9 @@ failure = acquireFailurePointTooOld
query = any
result = any

msgAcquire = [0, base.point, ? bool]
/ [8, ? bool]
/ [10, ? bool]
msgAcquire = [0, point, ? word32]

@adithyaov adithyaov Feb 10, 2026

Copy link
Copy Markdown

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

We are choosing to modify msgAcquire as opposed to adding a new message. Is this what we want to do?

Copy link
Copy Markdown
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

For the time being, yeah, this change is backwards compatible, but adding the new error type isn't. Either way, this probably isn't the implementation we'll use going forwards anyway.

/ [8, ? word32]
/ [10, ? word32]
msgAcquired = [1]
msgFailure = [2, failure]
msgQuery = [3, query]
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -40,7 +40,7 @@ newtype LocalStateQueryClient block point (query :: Type -> Type) m a =
--
data ClientStIdle block point query (m :: Type -> Type) a where
SendMsgAcquire :: Target point
-> Bool
-> Maybe LeashID
-> ClientStAcquiring block point query m a
-> ClientStIdle block point query m a

Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -77,27 +77,27 @@ codecLocalStateQuery version
State st
-> Message (LocalStateQuery block point query) st st'
-> CBOR.Encoding
encode _ (MsgAcquire (SpecificPoint pt) False) =
encode _ (MsgAcquire (SpecificPoint pt) Nothing) =
CBOR.encodeListLen 2
<> CBOR.encodeWord 0
<> encodePoint pt

encode _ (MsgAcquire (SpecificPoint pt) True) =
encode _ (MsgAcquire (SpecificPoint pt) (Just (LeashID leashId))) =
CBOR.encodeListLen 3
<> CBOR.encodeWord 0
<> encodePoint pt
<> CBOR.encodeBool True
<> CBOR.encodeWord32 leashId

encode _ (MsgAcquire VolatileTip False) =
encode _ (MsgAcquire VolatileTip Nothing) =
CBOR.encodeListLen 1
<> CBOR.encodeWord 8

encode _ (MsgAcquire VolatileTip True) =
encode _ (MsgAcquire VolatileTip (Just (LeashID leashId))) =
CBOR.encodeListLen 2
<> CBOR.encodeWord 8
<> CBOR.encodeBool True
<> CBOR.encodeWord32 leashId

encode _ (MsgAcquire ImmutableTip False)
encode _ (MsgAcquire ImmutableTip Nothing)
| canAcquireImmutable =
CBOR.encodeListLen 1
<> CBOR.encodeWord 10
Expand All @@ -106,11 +106,11 @@ codecLocalStateQuery version
++ "must be conditional on negotiating v16 of the node-to-client "
++ "protocol"

encode _ (MsgAcquire ImmutableTip True)
encode _ (MsgAcquire ImmutableTip (Just (LeashID leashId)))
| canAcquireImmutable =
CBOR.encodeListLen 2
<> CBOR.encodeWord 10
<> CBOR.encodeBool True
<> CBOR.encodeWord32 leashId
| otherwise =
error $ "encodeFailure: local state query: acquiring the immutable tip "
++ "must be conditional on negotiating v16 of the node-to-client "
Expand Down Expand Up @@ -172,26 +172,26 @@ codecLocalStateQuery version
case (stok, f, len, key) of
(SingIdle, _, 2, 0) -> do
pt <- decodePoint
return (SomeMessage (MsgAcquire (SpecificPoint pt) False))
return (SomeMessage (MsgAcquire (SpecificPoint pt) Nothing))

(SingIdle, _, 3, 0) -> do
pt <- decodePoint
leashed <- CBOR.decodeBool
return (SomeMessage (MsgAcquire (SpecificPoint pt) leashed))
leashed <- CBOR.decodeWord32
return (SomeMessage (MsgAcquire (SpecificPoint pt) (Just (LeashID leashed))))

(SingIdle, _, 1, 8) -> do
return (SomeMessage (MsgAcquire VolatileTip False))
return (SomeMessage (MsgAcquire VolatileTip Nothing))

(SingIdle, _, 2, 8) -> do
leashed <- CBOR.decodeBool
return (SomeMessage (MsgAcquire VolatileTip leashed))
leashed <- CBOR.decodeWord32
return (SomeMessage (MsgAcquire VolatileTip (Just (LeashID leashed))))

(SingIdle, _, 1, 10) -> do
return (SomeMessage (MsgAcquire ImmutableTip False))
return (SomeMessage (MsgAcquire ImmutableTip Nothing))

(SingIdle, _, 2, 10) -> do
leashed <- CBOR.decodeBool
return (SomeMessage (MsgAcquire ImmutableTip leashed))
leashed <- CBOR.decodeWord32
return (SomeMessage (MsgAcquire ImmutableTip (Just (LeashID leashed))))

(SingAcquiring, _, 1, 1) ->
return (SomeMessage MsgAcquired)
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -37,7 +37,7 @@ newtype LocalStateQueryServer block point (query :: Type -> Type) m a = LocalSta
--
data ServerStIdle block point query m a = ServerStIdle {
recvMsgAcquire :: Target point
-> Bool
-> Maybe LeashID
-> m (ServerStAcquiring block point query m a),

recvMsgDone :: m a
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,8 @@
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | The type of the local ledger state query protocol.
--
Expand All @@ -29,6 +31,8 @@ import Network.TypedProtocol.Stateful.Codec (AnyMessage (..))
import Control.DeepSeq
import GHC.Generics
import Ouroboros.Network.Util.ShowProxy (ShowProxy (..))
import Data.Word (Word32)
import NoThunks.Class (NoThunks)


-- | The kind of the local state query protocol, and the types of
Expand Down Expand Up @@ -128,6 +132,12 @@ data Target point = -- | The tip of the volatile chain
| ImmutableTip
deriving (Eq, Foldable, Functor, Generic, Ord, Show, Traversable, NFData)


newtype LeashID = LeashID Word32
deriving stock (Show)
-- TODO: anything else?
deriving newtype (Eq, Ord, NFData, Num, Read, NoThunks)

instance Protocol (LocalStateQuery (block :: Type) (point :: Type) (query :: Type -> Type)) where

-- | The messages in the state query protocol.
Expand All @@ -141,7 +151,7 @@ instance Protocol (LocalStateQuery (block :: Type) (point :: Type) (query :: Typ
--
MsgAcquire
:: Target point
-> Bool
-> Maybe LeashID -- ^ Optional leashing ID
-> Message (LocalStateQuery block point query) StIdle StAcquiring

-- | The server can confirm that it has the state at the requested point.
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,8 @@ module Ouroboros.Network.Protocol.LocalStateQuery.Examples where
import Ouroboros.Network.Protocol.LocalStateQuery.Client
import Ouroboros.Network.Protocol.LocalStateQuery.Server
import Ouroboros.Network.Protocol.LocalStateQuery.Type (AcquireFailure (..),
Target)
Target,
LeashID)


--
Expand All @@ -20,38 +21,38 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Type (AcquireFailure (..),
localStateQueryClient
:: forall block point query result m.
Applicative m
=> [(Target point, Bool, query result)]
=> [(Target point, Maybe LeashID, query result)]
-> LocalStateQueryClient block point query m
[(Target point, Bool, Either AcquireFailure result)]
[(Target point, Maybe LeashID, Either AcquireFailure result)]
localStateQueryClient = LocalStateQueryClient . pure . goIdle []
where
goIdle
:: [(Target point, Bool, Either AcquireFailure result)] -- ^ Accumulator
-> [(Target point, Bool, query result)] -- ^ Remainder
:: [(Target point, Maybe LeashID, Either AcquireFailure result)] -- ^ Accumulator
-> [(Target point, Maybe LeashID, query result)] -- ^ Remainder
-> ClientStIdle block point query m
[(Target point, Bool, Either AcquireFailure result)]
[(Target point, Maybe LeashID, Either AcquireFailure result)]
goIdle acc [] = SendMsgDone $ reverse acc
goIdle acc ((tgt, leashed, q):ptqs') = SendMsgAcquire tgt leashed $
goAcquiring acc tgt leashed q ptqs'

goAcquiring
:: [(Target point, Bool, Either AcquireFailure result)] -- ^ Accumulator
:: [(Target point, Maybe LeashID, Either AcquireFailure result)] -- ^ Accumulator
-> Target point
-> Bool
-> Maybe LeashID
-> query result
-> [(Target point, Bool, query result)] -- ^ Remainder
-> [(Target point, Maybe LeashID, query result)] -- ^ Remainder
-> ClientStAcquiring block point query m
[(Target point, Bool, Either AcquireFailure result)]
[(Target point, Maybe LeashID, Either AcquireFailure result)]
goAcquiring acc pt leashed q ptqss' = ClientStAcquiring {
recvMsgAcquired = pure $ goQuery q $ \r -> goAcquired ((pt, leashed, Right r):acc) ptqss'
, recvMsgFailure = \failure -> pure $ goIdle ((pt, leashed, Left failure):acc) ptqss'
}

goAcquired
:: [(Target point, Bool, Either AcquireFailure result)]
-> [(Target point, Bool, query result)] -- ^ Remainder
:: [(Target point, Maybe LeashID, Either AcquireFailure result)]
-> [(Target point, Maybe LeashID, query result)] -- ^ Remainder
-> ClientStAcquired block point query m
[(Target point, Bool, Either AcquireFailure result)]
[(Target point, Maybe LeashID, Either AcquireFailure result)]
goAcquired acc [] = SendMsgRelease $ pure $ SendMsgDone $ reverse acc
goAcquired acc ((tgt, leashed, qs):ptqss') = SendMsgReAcquire tgt $
goAcquiring acc tgt leashed qs ptqss'
Expand All @@ -73,7 +74,7 @@ localStateQueryClient = LocalStateQueryClient . pure . goIdle []
--
localStateQueryServer
:: forall block point query m state. Applicative m
=> (Target point -> Bool -> Either AcquireFailure state)
=> (Target point -> Maybe LeashID -> Either AcquireFailure state)
-> (forall result. state -> query result -> result)
-> LocalStateQueryServer block point query m ()
localStateQueryServer acquire answer =
Expand All @@ -85,12 +86,12 @@ localStateQueryServer acquire answer =
, recvMsgDone = pure ()
}

goAcquiring :: Target point -> Bool -> m (ServerStAcquiring block point query m ())
goAcquiring :: Target point -> Maybe LeashID -> m (ServerStAcquiring block point query m ())
goAcquiring tgt leashed = pure $ case acquire tgt leashed of
Left failure -> SendMsgFailure failure goIdle
Right state -> SendMsgAcquired $ goAcquired leashed state

goAcquired :: Bool -> state -> ServerStAcquired block point query m ()
goAcquired :: Maybe LeashID -> state -> ServerStAcquired block point query m ()
goAcquired leashed state = ServerStAcquired {
recvMsgQuery = \query ->
pure $ SendMsgResult (answer state query) $ goAcquired leashed state
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -165,10 +165,10 @@ prop_direct :: SetupData
prop_direct input =
runSimOrThrow
(direct
(localStateQueryClient (map (\(tgt, q) -> (tgt, False, q)) clientInput))
(localStateQueryClient (map (\(tgt, q) -> (tgt, Nothing, q)) clientInput))
(localStateQueryServer (\tgt _ -> serverAcquire tgt) serverAnswer))
===
(map (\(t, r) -> (t, False, r)) expected, ())
(map (\(t, r) -> (t, Nothing, r)) expected, ())
where
Setup { clientInput, serverAcquire, serverAnswer, expected } = mkSetup input

Expand All @@ -186,7 +186,7 @@ prop_connect input =
case runSimOrThrow
(Stateful.connect StateIdle
(localStateQueryClientPeer $
localStateQueryClient (map (\(tgt, q) -> (tgt, False, q)) clientInput))
localStateQueryClient (map (\(tgt, q) -> (tgt, Nothing, q)) clientInput))
(localStateQueryServerPeer $
localStateQueryServer (\tgt _ -> serverAcquire tgt) serverAnswer)) of

Expand Down Expand Up @@ -218,7 +218,7 @@ prop_channel createChannels input = do
codec
StateIdle
(localStateQueryClientPeer $
localStateQueryClient (map (\(tgt, q) -> (tgt, False, q)) clientInput))
localStateQueryClient (map (\(tgt, q) -> (tgt, Nothing, q)) clientInput))
(localStateQueryServerPeer $
localStateQueryServer (\tgt _ -> serverAcquire tgt) serverAnswer)
return $ case r of
Expand Down Expand Up @@ -304,6 +304,8 @@ newtype AnyMessageV7 block point query result = AnyMessageV7 {
}
deriving Show

deriving instance Arbitrary LeashID

instance ( Arbitrary point
, Arbitrary (query result)
, Arbitrary result
Expand Down
Loading