[Leios prototype] InMemory LeiosDb improvements

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

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

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
+      ]

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

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

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

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"
     }
 
 -- -----------------------------------------------------------------------------

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

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

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

trace-forward/trace-forward.cabal

@@ -108,6 +108,7 @@ test-suite test
                       , tasty-quickcheck
                       , typed-protocols
                       , text
+                      , si-timers
 
   ghc-options:          -rtsopts
                         -threaded