Run simulations from BenchTopology (#108)

.github/workflows/ci.yaml

@@ -63,8 +63,10 @@ jobs:
           # Defaults, added for clarity:
           cabal-version: "latest"
           cabal-update: true
+
       - name: Install libraries
-        run: sudo apt-get install -y libpango1.0-dev libgtk-3-dev
+        run: sudo apt-get install -y graphviz libpango1.0-dev libgtk-3-dev
+
       - name: Configure the build
         run: |
           cabal configure --enable-tests --enable-benchmarks --disable-documentation

.vscode/settings.json

@@ -4,5 +4,5 @@
     "source.organizeImports": "explicit",
   },
   "editor.formatOnSave": true,
-  "haskell.formattingProvider": "fourmolu", // Disable default formatter if ESLint is handling formatting
+  "haskell.formattingProvider": "fourmolu"
 }

cabal.project

@@ -17,6 +17,8 @@ index-state:
 packages: 
   simulation
 
+tests: True
+
 source-repository-package
     type: git
     location: https://github.com/IntersectMBO/ouroboros-network.git

hooks/pre-commit

@@ -7,10 +7,13 @@
 
 # Check for fourmolu
 fourmolu_required_version="0.15.0.0"
-fourmolu="$(which fourmolu)"
+fourmolu="$(which fourmolu-0.15.0.0)"
 if [ "${fourmolu}" = "" ]; then
-    echo "pre-commit: Requires fourmolu version ${fourmolu_required_version}; no version found"
-    exit 1
+    fourmolu="$(which fourmolu)"
+    if [ "${fourmolu}" = "" ]; then
+        echo "pre-commit: Requires fourmolu version ${fourmolu_required_version}; no version found"
+        exit 1
+    fi
 fi
 fourmolu_installed_version="$($fourmolu --version | head -n 1 | cut -d' ' -f2)"
 if [ ! "${fourmolu_installed_version}" = "${fourmolu_required_version}" ]; then
@@ -28,7 +31,7 @@ fi
 
 # Check Haskell files with fourmolu
 echo "Formatting Haskell source files with fourmolu version ${fourmolu_required_version}"
-if ! git ls-files --exclude-standard --no-deleted --deduplicate '*.hs' | xargs -L 1 fourmolu --mode=check --quiet; then
-    git ls-files --exclude-standard --no-deleted --deduplicate '*.hs' | xargs -L 1 fourmolu --mode=inplace --quiet
+if ! git ls-files --exclude-standard --no-deleted --deduplicate '*.hs' | xargs -L 1 "${fourmolu}" --mode=check --quiet; then
+    git ls-files --exclude-standard --no-deleted --deduplicate '*.hs' | xargs -L 1 "${fourmolu}" --mode=inplace --quiet
     exit 1
 fi

simulation/ouroboros-leios-sim.cabal

@@ -19,6 +19,9 @@ maintainer:         [email protected]
 -- category:
 build-type:         Simple
 extra-source-files: CHANGELOG.md
+data-files:
+  test/data/BenchTopology/topology-dense-52.json
+  test/data/BenchTopology/latency.sqlite3.gz
 
 flag perf
   description: Ghc options for improved performance, disables asserts.
@@ -166,3 +169,27 @@ executable ols
 
   default-language: Haskell2010
   ghc-options:      -Wall
+
+test-suite ols-test
+  if flag(perf)
+    import: performance-opts
+
+  type:           exitcode-stdio-1.0
+  hs-source-dirs: test
+  main-is:        Main.hs
+  build-depends:
+    , base
+    , directory
+    , fgl
+    , fgl-arbitrary
+    , ouroboros-leios-sim
+    , QuickCheck
+    , random
+    , tasty
+    , tasty-hunit
+    , tasty-quickcheck
+    , text
+  other-modules:
+    Paths_ouroboros_leios_sim
+    Test.Topology
+  default-language: Haskell2010

simulation/src/Main.hs

@@ -17,8 +17,9 @@ import qualified PraosProtocol.ExamplesPraosP2P as VizPraosP2P
 import qualified PraosProtocol.VizSimBlockFetch as VizBlockFetch
 import qualified PraosProtocol.VizSimChainSync as VizChainSync
 import qualified PraosProtocol.VizSimPraos as VizPraos
+import SimTypes (WorldShape (..))
 import TimeCompat (DiffTime, Time (..))
-import Topology (readP2PTopography, readSimpleTopologyFromBenchTopologyAndLatency, writeSimpleTopology)
+import Topology (defaultParams, readP2PTopography, readSimpleTopologyFromBenchTopologyAndLatency, writeSimpleTopology)
 import Viz
 
 main :: IO ()
@@ -227,8 +228,8 @@ vizOptionsToViz VizCommandWithOptions{..} = case vizSubCommand of
   VizPBF1 -> pure VizBlockFetch.example1
   VizPraos1 -> pure VizPraos.example1
   VizPraosP2P1{..} -> do
-    let worldDimensions = (1200, 1000)
-    maybeP2PTopography <- traverse (readP2PTopography worldDimensions) maybeTopologyFile
+    let worldShape = WorldShape (1200, 1000) True
+    maybeP2PTopography <- traverse (readP2PTopography defaultParams worldShape) maybeTopologyFile
     pure $ VizPraosP2P.example1 seed blockInterval maybeP2PTopography
   VizPraosP2P2 -> pure VizPraosP2P.example2
   VizRelayTest1 -> pure VizSimTestRelay.example1

simulation/src/P2P.hs

@@ -25,16 +25,16 @@ import Data.List (mapAccumL, sort, unfoldr)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import GHC.Generics (Generic)
+import GHC.Stack (HasCallStack)
 import SimTypes (NodeId (..), Point (..), WorldShape (..))
-import System.Random (StdGen)
 import qualified System.Random as Random
 
 data P2PTopography = P2PTopography
   { p2pNodes :: !(Map NodeId Point)
   , p2pLinks :: !(Map (NodeId, NodeId) Latency)
   , p2pWorldShape :: !WorldShape
   }
-  deriving (Show, Generic)
+  deriving (Eq, Show, Generic)
 
 instance ToJSON P2PTopography where
   toEncoding = genericToEncoding defaultOptions
@@ -56,7 +56,7 @@ data P2PTopographyCharacteristics = P2PTopographyCharacteristics
   -- ^ Per-node upstream links picked as random peers, e.g. 5 of 10 total
   , p2pNodeLinksRandom :: Int
   }
-  deriving (Show, Generic)
+  deriving (Eq, Show, Generic)
 
 instance ToJSON P2PTopographyCharacteristics where
   toEncoding = genericToEncoding defaultOptions
@@ -77,8 +77,10 @@ instance FromJSON P2PTopographyCharacteristics
 -- * The latency of each link will be chosen based on the shortest distance
 --   between the nodes: connecting over the "date line" if necessary.
 genArbitraryP2PTopography ::
+  forall g.
+  (HasCallStack, Random.RandomGen g) =>
   P2PTopographyCharacteristics ->
-  StdGen ->
+  g ->
   P2PTopography
 genArbitraryP2PTopography
   P2PTopographyCharacteristics
@@ -107,7 +109,7 @@ genArbitraryP2PTopography
     nodePositions =
       Map.fromList $ snd $ mapAccumL genNodePos rngNodes nodes
      where
-      genNodePos :: StdGen -> NodeId -> (StdGen, (NodeId, Point))
+      genNodePos :: g -> NodeId -> (g, (NodeId, Point))
       genNodePos rng nodeid =
         (rng'', (nodeid, Point x y))
        where
@@ -143,7 +145,7 @@ genArbitraryP2PTopography
         linkLatencySquared
         [(p, n) | (n, p) <- Map.toList nodePositions]
 
-    pickNodeLinksRandom :: NodeId -> StdGen -> [NodeId]
+    pickNodeLinksRandom :: NodeId -> g -> [NodeId]
     pickNodeLinksRandom nid rng =
       take
         p2pNodeLinksRandom

simulation/src/SimTypes.hs

@@ -24,11 +24,12 @@ data LabelLink e = LabelLink NodeId NodeId e deriving (Show)
 
 -- | Position in simulation world coordinates
 data Point = Point {_1 :: !Double, _2 :: !Double}
-  deriving (Show, Generic)
+  deriving (Eq, Show, Generic)
 
 -- | Path in simulation world
 newtype Path = Path [Point]
-  deriving (Show, Generic)
+  deriving (Eq, Show, Generic)
+  deriving newtype (Semigroup, Monoid)
 
 instance ToJSON Point where
   toEncoding = genericToEncoding defaultOptions
@@ -46,7 +47,7 @@ data WorldShape = WorldShape
   -- to the West edge, or if the world is a rectangle, with no wrapping at
   -- the edges. This affects the latencies.
   }
-  deriving (Show, Generic)
+  deriving (Eq, Show, Generic)
 
 instance ToJSON WorldShape where
   toEncoding = genericToEncoding defaultOptions