diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs index b17e44eefdf..58390da40b4 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs @@ -13,23 +13,10 @@ module Cardano.Benchmarking.GeneratorTx.NodeToNode , benchmarkConnectTxSubmit ) where +import Cardano.Benchmarking.LogTypes (EnvConsts (..), SendRecvConnect, + SendRecvTxSubmission2) import Cardano.Prelude (forever, liftIO, throwIO) -import Prelude - -import "contra-tracer" Control.Tracer (Tracer (..)) - -import Codec.Serialise (DeserialiseFailure) -import Control.Concurrent.Class.MonadSTM.Strict (newTVarIO) -import Control.Monad.Class.MonadTimer (MonadTimer, threadDelay) -import Data.ByteString.Lazy (ByteString) -import Data.Foldable (fold) -import qualified Data.Map.Strict as Map -import Data.Proxy (Proxy (..)) -import Data.Void (Void, absurd) -import qualified Network.Mux as Mux -import Network.Socket (AddrInfo (..)) -import System.Random (newStdGen) - +import Cardano.TxGenerator.Setup.NixService (defaultKeepaliveTimeout, getKeepaliveTimeout) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Byron.Ledger.Mempool (GenTx) import qualified Ouroboros.Consensus.Cardano as Consensus (CardanoBlock) @@ -38,16 +25,15 @@ import Ouroboros.Consensus.Network.NodeToNode (Codecs (..), defaultCod import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run (RunNode) import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) - -import Ouroboros.Network.Channel (Channel (..)) +import Ouroboros.Network.Channel (Channel (..), Reception) import Ouroboros.Network.Context import Ouroboros.Network.ControlMessage (continueForever) import Ouroboros.Network.DeltaQ (defaultGSV) import Ouroboros.Network.Driver (runPeer, runPeerWithLimits) import Ouroboros.Network.KeepAlive import Ouroboros.Network.Magic -import Ouroboros.Network.Mux (MiniProtocolCb (..), - OuroborosApplication (..), OuroborosBundle, RunMiniProtocol (..)) +import Ouroboros.Network.Mux (MiniProtocolCb (..), OuroborosApplication (..), + OuroborosBundle, RunMiniProtocol (..)) import Ouroboros.Network.NodeToClient (chainSyncPeerNull) import Ouroboros.Network.NodeToNode (NetworkConnectTracers (..)) import qualified Ouroboros.Network.NodeToNode as NtN @@ -59,15 +45,26 @@ import Ouroboros.Network.Protocol.BlockFetch.Client (BlockFetchClient import Ouroboros.Network.Protocol.Handshake.Version (simpleSingletonVersions) import Ouroboros.Network.Protocol.KeepAlive.Client hiding (SendMsgDone) import Ouroboros.Network.Protocol.KeepAlive.Codec -import Ouroboros.Network.Protocol.TxSubmission2.Client (TxSubmissionClient, - txSubmissionClientPeer) import Ouroboros.Network.Protocol.PeerSharing.Client (PeerSharingClient (..), peerSharingClientPeer) - +import Ouroboros.Network.Protocol.TxSubmission2.Client (TxSubmissionClient, + txSubmissionClientPeer) import Ouroboros.Network.Snocket (socketSnocket) -import Cardano.Benchmarking.LogTypes (EnvConsts (..), SendRecvConnect, SendRecvTxSubmission2) -import Cardano.TxGenerator.Setup.NixService (defaultKeepaliveTimeout, getKeepaliveTimeout) +import Prelude + +import Codec.Serialise (DeserialiseFailure) +import Control.Concurrent.Class.MonadSTM.Strict (newTVarIO) +import Control.Monad.Class.MonadTimer (MonadTimer, threadDelay) +import "contra-tracer" Control.Tracer (Tracer (..)) +import Data.ByteString.Lazy (ByteString) +import Data.Foldable (fold) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (..)) +import Data.Void (Void, absurd) +import qualified Network.Mux as Mux +import Network.Socket (AddrInfo (..)) +import System.Random (newStdGen) type CardanoBlock = Consensus.CardanoBlock StandardCrypto type ConnectClient = AddrInfo -> TxSubmissionClient (GenTxId CardanoBlock) (GenTx CardanoBlock) IO () -> IO () @@ -115,7 +112,7 @@ benchmarkConnectTxSubmit EnvConsts { .. } handshakeTracer submissionTracer codec supportedVers = supportedNodeToNodeVersions (Proxy @blk) myCodecs :: Codecs blk NtN.RemoteAddress DeserialiseFailure IO ByteString ByteString ByteString ByteString ByteString ByteString - ByteString + ByteString ByteString ByteString myCodecs = defaultCodecs codecConfig blkN2nVer encodeRemoteAddress decodeRemoteAddress n2nVer peerMultiplex :: NtN.Versions NodeToNodeVersion NtN.NodeToNodeVersionData @@ -173,14 +170,14 @@ benchmarkConnectTxSubmit EnvConsts { .. } handshakeTracer submissionTracer codec => NodeToNodeVersion -> remotePeer -> Channel IO ByteString - -> IO ((), Maybe ByteString) + -> IO ((), Maybe (Reception ByteString)) kaClient _version them channel = do keepAliveRng <- newStdGen peerGSVMap <- liftIO . newTVarIO $ Map.singleton them defaultGSV runPeerWithLimits mempty (cKeepAliveCodec myCodecs) - (byteLimitsKeepAlive (const 0)) -- TODO: Real Bytelimits, see #1727 + byteLimitsKeepAlive timeLimitsKeepAlive channel $ keepAliveClientPeer diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 4040dba52c3..15ac4efb5b8 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -70,6 +70,7 @@ library exposed-modules: Cardano.Node.Configuration.Logging Cardano.Node.Configuration.NodeAddress Cardano.Node.Configuration.POM + Cardano.Node.Configuration.Leios Cardano.Node.Configuration.LedgerDB Cardano.Node.Configuration.Socket Cardano.Node.Configuration.Topology diff --git a/cardano-node/src/Cardano/Node/Configuration/Leios.hs b/cardano-node/src/Cardano/Node/Configuration/Leios.hs new file mode 100644 index 00000000000..c1535758a8e --- /dev/null +++ b/cardano-node/src/Cardano/Node/Configuration/Leios.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Node.Configuration.Leios( + LeiosDbConfig(..) + ) where + +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value (String), object, + withObject, (.:), (.=)) + +data LeiosDbConfig = LeiosDbInMemory + | LeiosDbSQLite !FilePath + deriving (Eq, Show) + +instance FromJSON LeiosDbConfig where + parseJSON = withObject "LeiosDbConfig" $ \o -> do + backend :: String <- o .: "Backend" + case backend of + "InMemory" -> return LeiosDbInMemory + "SQLite" -> do + fp <- o .: "Filepath" + return $ LeiosDbSQLite fp + _ -> fail $ "Invalid LeiosDb backend " <> backend <> ", did you mean InMemory or SQLite?" + +instance ToJSON LeiosDbConfig where + toJSON LeiosDbInMemory = + object + [ "Backend" .= String "InMemory" + ] + toJSON (LeiosDbSQLite fp) = + object + [ "Backend" .= String "SQLite", + "Filepath" .= fp + ] diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index e5c29910f0a..b040c036640 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -31,6 +31,7 @@ import Cardano.Crypto (RequiresNetworkMagic (..)) import Cardano.Logging.Types import Cardano.Network.Types (NumberOfBigLedgerPeers (..)) import Cardano.Node.Configuration.LedgerDB +import Cardano.Node.Configuration.Leios (LeiosDbConfig (..)) import Cardano.Node.Configuration.NodeAddress (SocketPath) import Cardano.Node.Configuration.Socket (SocketConfig (..)) import Cardano.Node.Handlers.Shutdown @@ -203,6 +204,9 @@ data NodeConfiguration , ncGenesisConfig :: GenesisConfig , ncResponderCoreAffinityPolicy :: ResponderCoreAffinityPolicy + + -- Leios + , ncLeiosDbConfig :: LeiosDbConfig } deriving (Eq, Show) -- | We expose the `Ouroboros.Network.Mux.ForkPolicy` as a `NodeConfiguration` field. @@ -301,6 +305,9 @@ data PartialNodeConfiguration , pncGenesisConfigFlags :: !(Last GenesisConfigFlags) , pncResponderCoreAffinityPolicy :: !(Last ResponderCoreAffinityPolicy) + + -- Leios + , pncLeiosDbConfig :: !(Last LeiosDbConfig) } deriving (Eq, Generic, Show) instance AdjustFilePaths PartialNodeConfiguration where @@ -420,6 +427,8 @@ instance FromJSON PartialNodeConfiguration where <$> v .:? "ResponderCoreAffinityPolicy" <*> v .:? "ForkPolicy" -- deprecated + pncLeiosDbConfig <- Last <$> v .:? "LeiosDbConfig" + pure PartialNodeConfiguration { pncProtocolConfig , pncSocketConfig = Last . Just $ SocketConfig mempty mempty mempty pncSocketPath @@ -465,6 +474,7 @@ instance FromJSON PartialNodeConfiguration where , pncPeerSharing , pncGenesisConfigFlags , pncResponderCoreAffinityPolicy + , pncLeiosDbConfig } where parseMempoolCapacityBytesOverride v = parseNoOverride <|> parseOverride @@ -701,6 +711,7 @@ defaultPartialNodeConfiguration = -- the default is defined in `makeNodeConfiguration` , pncGenesisConfigFlags = Last (Just defaultGenesisConfigFlags) , pncResponderCoreAffinityPolicy = Last $ Just NoResponderCoreAffinity + , pncLeiosDbConfig = Last (Just (LeiosDbSQLite "leios.db")) } where PeerSelectionTargets { @@ -860,6 +871,11 @@ makeNodeConfiguration pnc = do experimentalProtocols <- lastToEither "Missing ExperimentalProtocolsEnabled" $ pncExperimentalProtocolsEnabled pnc + + ncLeiosDbConfig <- + lastToEither "Missing LeiosDbConfig" + $ pncLeiosDbConfig pnc + return $ NodeConfiguration { ncConfigFile = configFile , ncTopologyFile = topologyFile @@ -908,6 +924,7 @@ makeNodeConfiguration pnc = do , ncConsensusMode , ncGenesisConfig , ncResponderCoreAffinityPolicy + , ncLeiosDbConfig } ncProtocol :: NodeConfiguration -> Protocol diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs index 5f9afd83c4c..aba556b8764 100644 --- a/cardano-node/src/Cardano/Node/Parsers.hs +++ b/cardano-node/src/Cardano/Node/Parsers.hs @@ -136,6 +136,7 @@ nodeRunParser = do , pncPeerSharing = mempty , pncGenesisConfigFlags = mempty , pncResponderCoreAffinityPolicy = mempty + , pncLeiosDbConfig = mempty } parseSocketPath :: Text -> Parser SocketPath diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index a81f6c9641d..a9ad85592d7 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -44,6 +44,7 @@ import Cardano.Node.Configuration.Socket (SocketOrSocketInfo' (..), import qualified Cardano.Node.Configuration.Topology as TopologyNonP2P import Cardano.Node.Configuration.TopologyP2P import qualified Cardano.Node.Configuration.TopologyP2P as TopologyP2P +import Cardano.Node.Configuration.Leios (LeiosDbConfig(..)) import Cardano.Node.Handlers.Shutdown import Cardano.Node.Protocol (ProtocolInstantiationError (..), mkConsensusProtocol) import Cardano.Node.Protocol.Byron (ByronProtocolInstantiationError (CredentialsError)) @@ -169,7 +170,7 @@ import Paths_cardano_node (version) import Paths_cardano_node (version) -import LeiosDemoDb (newLeiosDBSQLiteFromEnv) +import LeiosDemoDb (newLeiosDBInMemory, newLeiosDBSQLite) {- HLINT ignore "Fuse concatMap/map" -} {- HLINT ignore "Redundant <$>" -} @@ -472,7 +473,9 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do $ Proxy @blk )) - leiosDB <- newLeiosDBSQLiteFromEnv + leiosDB <- case ncLeiosDbConfig nc of + LeiosDbInMemory -> newLeiosDBInMemory + LeiosDbSQLite leiosDbPath -> newLeiosDBSQLite leiosDbPath withShutdownHandling (ncShutdownConfig nc) (shutdownTracer tracers) $ case p2pMode of diff --git a/cardano-node/test/Test/Cardano/Node/POM.hs b/cardano-node/test/Test/Cardano/Node/POM.hs index ff996959fc2..e90e49f99e4 100644 --- a/cardano-node/test/Test/Cardano/Node/POM.hs +++ b/cardano-node/test/Test/Cardano/Node/POM.hs @@ -34,6 +34,7 @@ import Data.Text (Text) import Hedgehog (Property, discover, withTests, (===)) import qualified Hedgehog import Hedgehog.Internal.Property (evalEither, failWith) +import Cardano.Node.Configuration.Leios (LeiosDbConfig(LeiosDbSQLite)) -- This is a simple test to check that the POM technique is working as intended. @@ -170,6 +171,7 @@ testPartialYamlConfig = , pncResponderCoreAffinityPolicy = mempty , pncLedgerDbConfig = mempty , pncEgressPollInterval = mempty + , pncLeiosDbConfig = mempty } -- | Example partial configuration theoretically created @@ -221,6 +223,7 @@ testPartialCliConfig = , pncResponderCoreAffinityPolicy = mempty , pncLedgerDbConfig = mempty , pncEgressPollInterval = mempty + , pncLeiosDbConfig = mempty } -- | Expected final NodeConfiguration @@ -278,6 +281,7 @@ eExpectedConfig = do , ncGenesisConfig = disableGenesisConfig , ncResponderCoreAffinityPolicy = NoResponderCoreAffinity , ncLedgerDbConfig = LedgerDbConfiguration DefaultNumOfDiskSnapshots DefaultSnapshotInterval DefaultQueryBatchSize V2InMemory noDeprecatedOptions + , ncLeiosDbConfig = LeiosDbSQLite "leios.db" } -- ----------------------------------------------------------------------------- diff --git a/trace-dispatcher/src/Cardano/Logging/Formatter.hs b/trace-dispatcher/src/Cardano/Logging/Formatter.hs index aa7b0ef04ed..15f6506eeb7 100644 --- a/trace-dispatcher/src/Cardano/Logging/Formatter.hs +++ b/trace-dispatcher/src/Cardano/Logging/Formatter.hs @@ -39,7 +39,7 @@ import Network.HostName import System.IO.Unsafe (unsafePerformIO) -data I a = I a +newtype I a = I a instance Functor I where fmap f (I x) = I (f x) encodingToText :: AE.Encoding -> Text @@ -107,7 +107,7 @@ preFormatted withForHuman = Nothing -> I Nothing Just (AE.Number tm') -> I $ Just $ AE.String $ timeFormattedT $ tmf $ toRational tm' Just x -> I $ Just x - machineFormatted = AE.toEncoding $ obj' + machineFormatted = AE.toEncoding obj' pure (lc, Right (PreFormatted { pfForHuman = if withForHuman then condForHuman else Nothing diff --git a/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs b/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs index 59d8b9ad487..27377f33647 100644 --- a/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs +++ b/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs @@ -14,6 +14,7 @@ import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadST import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime) import Control.Monad.IOSim (runSimOrThrow) import Control.Monad.ST (runST) import Control.Tracer (nullTracer) @@ -115,6 +116,7 @@ prop_channel :: ( MonadST m , MonadAsync m , MonadCatch m + , MonadMonotonicTime m ) => (Int -> Int) -> Int diff --git a/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs b/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs index 67ecbe9741f..88ef27d188d 100644 --- a/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs +++ b/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs @@ -13,6 +13,7 @@ import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadST import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime) import Control.Monad.IOSim (runSimOrThrow) import Control.Monad.ST (runST) import Control.Tracer (nullTracer) @@ -112,6 +113,7 @@ prop_channel :: ( MonadST m , MonadAsync m , MonadCatch m + , MonadMonotonicTime m ) => (Int -> Int) -> Int diff --git a/trace-forward/trace-forward.cabal b/trace-forward/trace-forward.cabal index 07ea61dfad2..0d7a24cd26a 100644 --- a/trace-forward/trace-forward.cabal +++ b/trace-forward/trace-forward.cabal @@ -108,6 +108,7 @@ test-suite test , tasty-quickcheck , typed-protocols , text + , si-timers ghc-options: -rtsopts -threaded