Skip to content
Draft
Show file tree
Hide file tree
Changes from all 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
16 changes: 13 additions & 3 deletions cabal.project
Original file line number Diff line number Diff line change
Expand Up @@ -10,8 +10,8 @@ repository cardano-haskell-packages
d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee

index-state:
, hackage.haskell.org 2025-08-03T21:32:16Z
, cardano-haskell-packages 2025-07-30T14:13:57Z
, hackage.haskell.org 2025-10-17T00:26:22Z
, cardano-haskell-packages 2025-11-07T15:42:47Z

packages:
cardano-db
Expand Down Expand Up @@ -75,7 +75,6 @@ constraints:
-- then clashes with the `show` in `Prelude`.
, text < 2.1.2

, cardano-node ^>= 10.4

if impl (ghc >= 9.12)
allow-newer:
Expand All @@ -86,3 +85,14 @@ if impl (ghc >= 9.12)
-- when using the "cabal" wrapper script provided by nix-shell.
-- --------------------------- 8< --------------------------
-- Please do not put any `source-repository-package` clause above this line.

source-repository-package
type: git
location: https://github.com/IntersectMBO/cardano-node
tag: f5ac0eb01b56af80e8d430828ff6000b6abb92e9
--sha256: sha256-pm+lbEiRdQesnkaXmzn58aWlBhD29l7QHGNtJiDlzuA=
subdir:
cardano-node
trace-dispatcher
trace-forward
trace-resources
8 changes: 4 additions & 4 deletions cardano-chain-gen/cardano-chain-gen.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -83,7 +83,7 @@ library
, extra
, mtl
, microlens
, network-mux
, network
, nothunks
, ouroboros-consensus
, ouroboros-consensus-cardano
Expand All @@ -97,10 +97,10 @@ library
, plutus-ledger-api:{plutus-ledger-api-testlib}
, serialise
, strict-sop-core
, strict-stm
, io-classes:strict-stm
, text
, typed-protocols
, typed-protocols-stateful
, typed-protocols:stateful

test-suite cardano-chain-gen
type: exitcode-stdio-1.0
Expand Down Expand Up @@ -183,9 +183,9 @@ test-suite cardano-chain-gen
, extra
, filepath
, int-cast
, io-classes:strict-stm
, silently
, stm
, strict-stm
, tasty
, tasty-quickcheck
, text
Expand Down
103 changes: 33 additions & 70 deletions cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs
Original file line number Diff line number Diff line change
Expand Up @@ -48,10 +48,8 @@ import Control.Tracer (nullTracer)
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust)
import Data.Void (Void)
import qualified Network.Mux as Mux
import qualified Network.Socket as Socket
import Network.TypedProtocol.Peer (Peer (..))
import Network.TypedProtocol.Stateful.Codec ()
import qualified Network.TypedProtocol.Stateful.Peer as St
import Ouroboros.Consensus.Block (CodecConfig, HasHeader, Point, StandardHash, castPoint)
import Ouroboros.Consensus.Config (TopLevelConfig, configCodec)
Expand All @@ -65,7 +63,6 @@ import Ouroboros.Consensus.Node.DbMarker ()
import Ouroboros.Consensus.Node.InitStorage ()
import Ouroboros.Consensus.Node.NetworkProtocolVersion (
BlockNodeToClientVersion,
NodeToClientVersion,
SupportedNetworkProtocolVersion,
latestReleasedNodeVersion,
supportedNodeToClientVersions,
Expand All @@ -87,25 +84,22 @@ import Ouroboros.Network.Block (
)
import Ouroboros.Network.Channel (Channel)
import Ouroboros.Network.Driver.Simple (runPeer)
import qualified Ouroboros.Network.Driver.Stateful as St (runPeer)
import Ouroboros.Network.IOManager (IOManager)
import qualified Ouroboros.Network.IOManager as IOManager
import qualified Ouroboros.Network.Driver.Stateful as Stateful
import Ouroboros.Network.Magic (NetworkMagic)
import Ouroboros.Network.Mux (OuroborosApplicationWithMinimalCtx)
import Ouroboros.Network.NodeToClient (NodeToClientVersionData (..))
import qualified Ouroboros.Network.NodeToClient as NodeToClient
import Ouroboros.Network.NodeToNode (Versions)
import Ouroboros.Network.NodeToClient
import Ouroboros.Network.Protocol.ChainSync.Server (
ChainSyncServer (..),
ServerStIdle (..),
ServerStIntersect (..),
ServerStNext (SendMsgRollBackward, SendMsgRollForward),
chainSyncServerPeer,
)
import Ouroboros.Network.Protocol.Handshake.Version (simpleSingletonVersions)
import Ouroboros.Network.Protocol.Handshake
import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery
import Ouroboros.Network.Snocket (LocalAddress, LocalSnocket, LocalSocket (..))
import Ouroboros.Network.Server.Simple as Server
import Ouroboros.Network.Snocket
import qualified Ouroboros.Network.Snocket as Snocket
import Ouroboros.Network.Socket
import Ouroboros.Network.Util.ShowProxy (Proxy (..), ShowProxy (..))

{- HLINT ignore "Use readTVarIO" -}
Expand Down Expand Up @@ -212,33 +206,41 @@ runLocalServer ::
FilePath ->
StrictTVar IO (ChainProducerState blk) ->
IO ()
runLocalServer iom codecConfig netMagic localDomainSock chainProdState =
withSnocket iom localDomainSock $ \localSocket localSnocket -> do
networkState <- NodeToClient.newNetworkMutableState
_ <-
NodeToClient.withServer
localSnocket
NodeToClient.nullNetworkServerTracers -- debuggingNetworkServerTracers
networkState
localSocket
(versions chainProdState)
NodeToClient.networkErrorPolicies
pure ()
runLocalServer iom codecConfig netMagic localDomainSock chainProdState = do
_ <-
Server.with
(Snocket.socketSnocket iom)
makeSocketBearer -- makeLocalBearer --
(\_ _ -> pure ())
(Socket.SockAddrUnix localDomainSock)
( HandshakeArguments
{ haHandshakeTracer = nullTracer
, haBearerTracer = nullTracer
, haHandshakeCodec = codecHandshake nodeToClientVersionCodec
, haVersionDataCodec = cborTermVersionDataCodec nodeToClientCodecCBORTerm
, haAcceptVersion = acceptableVersion
, haQueryVersion = queryVersion
, haTimeLimits = noTimeLimitsHandshake
}
)
(versions chainProdState)
(\_ serverAsync -> wait serverAsync)
pure ()
where
versions ::
StrictTVar IO (ChainProducerState blk) ->
Versions
NodeToClientVersion
NodeToClientVersionData
(OuroborosApplicationWithMinimalCtx 'Mux.ResponderMode LocalAddress ByteString IO Void ())
(SomeResponderApplication Socket.SockAddr ByteString IO ())
versions state =
let version = fromJust $ snd $ latestReleasedNodeVersion (Proxy @blk)
allVersions = supportedNodeToClientVersions (Proxy @blk)
blockVersion = fromJust $ Map.lookup version allVersions
in simpleSingletonVersions
version
(NodeToClientVersionData netMagic False)
(\versionData -> NTC.responder version versionData $ mkApps state version blockVersion (NTC.defaultCodecs codecConfig blockVersion version))
(\versionData' -> SomeResponderApplication $ NTC.responder version versionData' $ mkApps state version blockVersion (NTC.defaultCodecs codecConfig blockVersion version))

mkApps ::
StrictTVar IO (ChainProducerState blk) ->
Expand All @@ -260,11 +262,10 @@ runLocalServer iom codecConfig netMagic localDomainSock chainProdState =
IO ((), Maybe ByteString)
chainSyncServer' _them channel =
runPeer
nullTracer -- TODO add a tracer!
nullTracer
(cChainSyncCodec codecs)
channel
$ chainSyncServerPeer
$ chainSyncServer state codecConfig blockVersion
(chainSyncServerPeer $ chainSyncServer state codecConfig blockVersion)

txSubmitServer ::
localPeer ->
Expand All @@ -277,12 +278,8 @@ runLocalServer iom codecConfig netMagic localDomainSock chainProdState =
channel
(Effect (forever $ threadDelay 3_600_000_000))

stateQueryServer ::
localPeer ->
Channel IO ByteString ->
IO ((), Maybe ByteString)
stateQueryServer _them channel =
St.runPeer
Stateful.runPeer
nullTracer
(cStateQueryCodec codecs)
channel
Expand Down Expand Up @@ -354,8 +351,7 @@ chainSyncServer state codec _blockVersion =
(Tip blk, ChainUpdate blk blk) ->
ServerStNext (Serialised blk) (Point blk) (Tip blk) m ()
sendNext r (tip, AddBlock b) =
-- SendMsgRollForward -- (Serialised $ toLazyByteString $ encodeNodeToClient codec blockVersion b) tip (idle' r)
SendMsgRollForward (mkSerialised (encodeDisk codec) b) tip (idle' r) -- encodeNodeToClient codec blockVersion -- mkSerialised encode b
SendMsgRollForward (mkSerialised (encodeDisk codec) b) tip (idle' r)
sendNext r (tip, RollBack p) = SendMsgRollBackward (castPoint p) tip (idle' r)

newFollower :: m FollowerId
Expand Down Expand Up @@ -404,36 +400,3 @@ chainSyncServer state codec _blockVersion =
writeTVar state cps'
let chain = chainDB cps'
pure (castTip (headTip chain), u)

withSnocket ::
forall a.
IOManager ->
FilePath ->
(LocalSocket -> LocalSnocket -> IO a) ->
IO a
withSnocket iocp localDomainSock k =
bracket localServerInit localServerCleanup localServerBody
where
localServerInit :: IO (LocalSocket, LocalSnocket)
localServerInit = do
let sn = Snocket.localSnocket iocp
sd <-
Snocket.open
sn
( Snocket.addrFamily sn $
Snocket.localAddressFromPath localDomainSock
)
pure (sd, sn)

-- We close the socket here, even if it was provided for us.
localServerCleanup :: (LocalSocket, LocalSnocket) -> IO ()
localServerCleanup (sd, sn) = Snocket.close sn sd

localServerBody :: (LocalSocket, LocalSnocket) -> IO a
localServerBody (sd, sn) = do
Snocket.bind sn sd (Snocket.localAddressFromPath localDomainSock)
Snocket.listen sn sd
k sd sn

withIOManager :: (IOManager -> IO a) -> IO a
withIOManager = IOManager.withIOManager
Loading
Loading