diff --git a/.envrc b/.envrc new file mode 100644 index 000000000..638c8ed6a --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +use flake .#dev-top-level diff --git a/.github/workflows/simulation.yaml b/.github/workflows/simulation.yaml index 2faac4289..c825da90b 100644 --- a/.github/workflows/simulation.yaml +++ b/.github/workflows/simulation.yaml @@ -116,4 +116,4 @@ jobs: - name: πŸ› οΈ Run fourmolu uses: haskell-actions/run-fourmolu@v11 with: - version: "0.15.0.0" + version: "0.19.0.1" diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 86f706eab..85302cf50 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -68,14 +68,14 @@ how something is implemented in a feature idea or bug ticket beforehand. To build Haskell code in this repository, you need to install: -* The [GHC](https://www.haskell.org/ghc/) compiler version 9.6.3 -* [cabal](https://www.haskell.org/cabal/) build tool +* The [GHC](https://www.haskell.org/ghc/) compiler version 9.10.1 +* [cabal](https://www.haskell.org/cabal/) build tool version 3.12.1.0 > [!NOTE] > Installing those tools might depend on your system's details, we suggest two different methods: > > * Install [GHCup](https://www.haskell.org/ghcup/) to manage various tools from the Haskell ecosystem -> * Use the provided [Nix shell](shell.nix) +> * Use the provided Nix shell by invoking `nix develop` Running `cabal update && cabal build all` at the top-level of the project should build all the Haskell components. Tests are run with diff --git a/analysis/deltaq/flake.nix b/analysis/deltaq/flake.nix index b1e122857..e04fc6493 100644 --- a/analysis/deltaq/flake.nix +++ b/analysis/deltaq/flake.nix @@ -18,63 +18,97 @@ deltaq.flake = false; }; - outputs = { - self, - flake-compat, - flake-utils, - nixpkgs, - jupyenv, - deltaq, - ... - } @ inputs: - flake-utils.lib.eachSystem (with flake-utils.lib.system; [ x86_64-linux ]) - ( - system: let + outputs = + { + self, + flake-utils, + nixpkgs, + jupyenv, + deltaq, + ... + }: + flake-utils.lib.eachSystem (with flake-utils.lib.system; [ x86_64-linux ]) ( + system: + let - overlay = next: prev: { + overlay = _next: prev: { haskell = prev.haskell // { - packageOverrides = hnext: hprev: { + packageOverrides = _hnext: hprev: { # Include the DeltaQ packages. - deltaq = hprev.callCabal2nixWithOptions - "deltaq" - (deltaq.outPath + "/lib/deltaq") - "--no-check" - {}; - probability-polynomial = hprev.callCabal2nixWithOptions - "probability-polynomial" - (deltaq.outPath + "/lib/probability-polynomial") - "--no-check" - {}; + deltaq = hprev.callCabal2nixWithOptions "deltaq" (deltaq.outPath + "/lib/deltaq") "--no-check" { }; + probability-polynomial = hprev.callCabal2nixWithOptions "probability-polynomial" ( + deltaq.outPath + "/lib/probability-polynomial" + ) "--no-check" { }; # Use a more recent version of `lattices` than is available in the curated Nix package set. lattices = hprev.callPackage ( - { mkDerivation, base, containers, deepseq, hashable - , integer-logarithms, lib, QuickCheck, quickcheck-instances, tagged - , tasty, tasty-quickcheck, transformers, universe-base - , universe-reverse-instances, unordered-containers + { + mkDerivation, + base, + containers, + deepseq, + hashable, + integer-logarithms, + lib, + QuickCheck, + quickcheck-instances, + tagged, + tasty, + tasty-quickcheck, + transformers, + universe-base, + universe-reverse-instances, + unordered-containers, }: mkDerivation { pname = "lattices"; version = "2.2.1"; sha256 = "27063f2343b1547033cd59f61b27f797041ed0c25c921f253ce82dc6fffa7666"; libraryHaskellDepends = [ - base containers deepseq hashable integer-logarithms QuickCheck - tagged transformers universe-base universe-reverse-instances + base + containers + deepseq + hashable + integer-logarithms + QuickCheck + tagged + transformers + universe-base + universe-reverse-instances unordered-containers ]; testHaskellDepends = [ - base containers QuickCheck quickcheck-instances tasty - tasty-quickcheck transformers universe-base - universe-reverse-instances unordered-containers + base + containers + QuickCheck + quickcheck-instances + tasty + tasty-quickcheck + transformers + universe-base + universe-reverse-instances + unordered-containers ]; homepage = "http://github.com/phadej/lattices/"; description = "Fine-grained library for constructing and manipulating lattices"; license = lib.licenses.bsd3; } - ) {}; + ) { }; # Sadly, we need to loosen the dependency constraint that `Chart-cairo` has on `time`. Chart-cairo = hprev.callPackage ( - { mkDerivation, array, base, cairo, Chart, colour - , data-default-class, lens, lib, mtl, old-locale, operational, time + { + mkDerivation, + array, + base, + cairo, + Chart, + colour, + data-default-class, + lens, + lib, + mtl, + old-locale, + operational, + time, }: mkDerivation { pname = "Chart-cairo"; @@ -84,26 +118,41 @@ sed -e '/, time/s/ >=.*$//' -i Chart-cairo.cabal ''; libraryHaskellDepends = [ - array base cairo Chart colour data-default-class lens mtl - old-locale operational time + array + base + cairo + Chart + colour + data-default-class + lens + mtl + old-locale + operational + time ]; homepage = "https://github.com/timbod7/haskell-chart/wiki"; description = "Cairo backend for Charts"; license = lib.licenses.bsd3; } - ) {}; + ) { }; }; }; }; - pkgs = import nixpkgs { inherit system; overlays = [ overlay ]; }; + pkgs = import nixpkgs { + inherit system; + overlays = [ overlay ]; + }; inherit (jupyenv.lib.${system}) mkJupyterlabNew; - jupyterlab = mkJupyterlabNew ({...}: { - nixpkgs = nixpkgs; - imports = [(import ./kernels.nix {pkgs = pkgs;})]; - }); + jupyterlab = mkJupyterlabNew ( + { ... }: + { + inherit nixpkgs; + imports = [ (import ./kernels.nix { inherit pkgs; }) ]; + } + ); docker = pkgs.dockerTools.buildImage { name = "jupyter-deltaq"; @@ -146,13 +195,14 @@ "--NotebookApp.token=deltaq" ]; ExposedPorts = { - "8888" = {}; + "8888" = { }; }; }; }; - in rec { - packages = {inherit jupyterlab docker;}; + in + rec { + packages = { inherit jupyterlab docker; }; packages.default = jupyterlab; apps.default.program = "${jupyterlab}/bin/jupyter-lab"; apps.default.type = "app"; diff --git a/analysis/deltaq/kernels.nix b/analysis/deltaq/kernels.nix index ae3356873..3cbec58e2 100644 --- a/analysis/deltaq/kernels.nix +++ b/analysis/deltaq/kernels.nix @@ -1,4 +1,4 @@ -{pkgs, ...}: +{ pkgs, ... }: { @@ -10,37 +10,38 @@ enable = true; nixpkgs = pkgs; haskellCompiler = "ghc94"; - extraHaskellPackages = p: with p; [ - - # Required for charts in iHaskell kernel - ihaskell - ihaskell-charts - Chart-cairo - - # Packages - deltaq - probability-polynomial - - # Library dependencies - Chart - exact-combinatorics - graphviz - lattices - - # Test dependencies, not strictly needed but perhaps convenient - hspec - hspec-discover - QuickCheck - - # Benchmark dependencies, not strictly needed but perhaps convenient - cassava - criterion - hvega - optparse-applicative - statistics - vector - - ]; + extraHaskellPackages = + p: with p; [ + + # Required for charts in iHaskell kernel + ihaskell + ihaskell-charts + Chart-cairo + + # Packages + deltaq + probability-polynomial + + # Library dependencies + Chart + exact-combinatorics + graphviz + lattices + + # Test dependencies, not strictly needed but perhaps convenient + hspec + hspec-discover + QuickCheck + + # Benchmark dependencies, not strictly needed but perhaps convenient + cassava + criterion + hvega + optparse-applicative + statistics + vector + + ]; }; } diff --git a/analysis/markov/shell.nix b/analysis/markov/shell.nix index 342c9b3d9..28e3b8717 100644 --- a/analysis/markov/shell.nix +++ b/analysis/markov/shell.nix @@ -1,4 +1,6 @@ -{ pkgs ? import {} }: +{ + pkgs ? import { }, +}: pkgs.mkShell { buildInputs = with pkgs; [ diff --git a/analysis/sims/flake.nix b/analysis/sims/flake.nix index b7e1eeac9..f11923a80 100644 --- a/analysis/sims/flake.nix +++ b/analysis/sims/flake.nix @@ -1,58 +1,67 @@ { description = "Flake for simulations and analysis"; - nixConfig.extra-substituters = [ - "https://tweag-jupyter.cachix.org" - ]; - nixConfig.extra-trusted-public-keys = [ - "tweag-jupyter.cachix.org-1:UtNH4Zs6hVUFpFBTLaA4ejYavPo5EFFqgd7G7FxGW9g=" - ]; + nixConfig = { + extra-substituters = [ + "https://tweag-jupyter.cachix.org" + ]; + extra-trusted-public-keys = [ + "tweag-jupyter.cachix.org-1:UtNH4Zs6hVUFpFBTLaA4ejYavPo5EFFqgd7G7FxGW9g=" + ]; + }; - inputs.flake-compat.url = "github:edolstra/flake-compat"; - inputs.flake-compat.flake = false; - inputs.flake-utils.url = "github:numtide/flake-utils"; - inputs.nixpkgs.url = "github:nixos/nixpkgs/nixos-25.05"; - inputs.jupyenv.url = "github:tweag/jupyenv"; + inputs = { + flake-compat.url = "github:edolstra/flake-compat"; + flake-compat.flake = false; + flake-utils.url = "github:numtide/flake-utils"; + nixpkgs.url = "github:nixos/nixpkgs/nixos-25.05"; + jupyenv.url = "github:tweag/jupyenv"; + }; outputs = - { self - , flake-compat - , flake-utils - , nixpkgs - , jupyenv - , ... - } @ inputs: - flake-utils.lib.eachSystem [ - flake-utils.lib.system.x86_64-linux - ] - (system: - let - inherit (jupyenv.lib.${system}) mkJupyterlabNew; - jupyterlab = mkJupyterlabNew ({ ... }: { - nixpkgs = inputs.nixpkgs; - imports = [ (import ./kernels.nix { pkgs = nixpkgs; }) ]; - }); - pkgs = import nixpkgs { inherit system; }; - in - rec { - packages = { inherit jupyterlab; }; - packages.default = jupyterlab; + { + flake-utils, + nixpkgs, + jupyenv, + ... + }@inputs: + flake-utils.lib.eachSystem + [ + flake-utils.lib.system.x86_64-linux + ] + ( + system: + let + inherit (jupyenv.lib.${system}) mkJupyterlabNew; + jupyterlab = mkJupyterlabNew ( + { ... }: + { + inherit (inputs) nixpkgs; + imports = [ (import ./kernels.nix) ]; + } + ); + pkgs = import nixpkgs { inherit system; }; + in + rec { + packages = { inherit jupyterlab; }; + packages.default = jupyterlab; - apps.default.program = "${jupyterlab}/bin/jupyter-lab"; - apps.default.type = "app"; + apps.default.program = "${jupyterlab}/bin/jupyter-lab"; + apps.default.type = "app"; - devShells.sims = pkgs.mkShell { - buildInputs = [ - pkgs.remarshal # yaml2json - pkgs.jq - pkgs.ansifilter - pkgs.gnugrep - pkgs.gnused - pkgs.gzip - pkgs.pigz - pkgs.bc - ]; - }; - devShells.default = devShells.sims; - }); + devShells.sims = pkgs.mkShell { + buildInputs = [ + pkgs.remarshal # yaml2json + pkgs.jq + pkgs.ansifilter + pkgs.gnugrep + pkgs.gnused + pkgs.gzip + pkgs.pigz + pkgs.bc + ]; + }; + devShells.default = devShells.sims; + } + ); } diff --git a/analysis/sims/kernels.nix b/analysis/sims/kernels.nix index 0fe971a14..36fbb0982 100644 --- a/analysis/sims/kernels.nix +++ b/analysis/sims/kernels.nix @@ -1,45 +1,34 @@ -{pkgs, ...}: - -let - - # FIXME: Ugly but necessary! - nixpkgs_version = builtins.fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/11cb3517b3af6af300dd6c055aeda73c9bf52c48.tar.gz"; - sha256 = "sha256:1915r28xc4znrh2vf4rrjnxldw2imysz819gzhk9qlrkqanmfsxd"; - }; - rPackages = (import nixpkgs_version {system = "x86_64-linux";}).rPackages; - -in - { kernel.python.minimal = { enable = true; - extraPackages = p: with p; [ - numpy - pandas - ]; + extraPackages = + p: with p; [ + numpy + pandas + ]; }; kernel.r.minimal = { enable = true; - extraRPackages = p: with p; [ - bit64 - cowplot - curl - data_table - dplyr - ggpattern - ggplot2 - ggExtra - igraph - lubridate - mongolite - poibin - quantreg - RPostgres - R_utils - stringr - svglite - VGAM - ]; + extraRPackages = + p: with p; [ + bit64 + cowplot + curl + data_table + dplyr + ggpattern + ggplot2 + ggExtra + igraph + lubridate + mongolite + poibin + quantreg + RPostgres + R_utils + stringr + svglite + VGAM + ]; }; } diff --git a/antithesis/entrypoint.py b/antithesis/entrypoint.py index c8e75a118..cf866e27d 100755 --- a/antithesis/entrypoint.py +++ b/antithesis/entrypoint.py @@ -1,6 +1,6 @@ #!/usr/bin/env -S python3 -u -# This file serves as the client's entrypoint. It: +# This file serves as the client's entrypoint. It: # 1. Confirms that all nodes in the cluster are available # 2. Signals "setupComplete" using the Antithesis SDK @@ -15,7 +15,7 @@ print("Client [entrypoint]: running...") # Here is the python format for setup_complete. At this point, our system is fully initialized and ready to test. -setup_complete({"Message":"sim-rs cluster is healthy"}) +setup_complete({"Message": "sim-rs cluster is healthy"}) # sleep infinity time.sleep(31536000) diff --git a/build.nix b/build.nix new file mode 100644 index 000000000..e7d8357ff --- /dev/null +++ b/build.nix @@ -0,0 +1,27 @@ +{ + + perSystem = + { + config, + pkgs, + ... + }: + { + devShells.dev-top-level = pkgs.mkShell { + name = "dev-top-level"; + + inherit (config.pre-commit.settings) shellHook; + + buildInputs = config.pre-commit.settings.enabledPackages; + }; + + formatter = pkgs.writeShellScriptBin "pre-commit-run" '' + ${pkgs.lib.getExe config.pre-commit.settings.package} run --all-files --config ${config.pre-commit.settings.configFile} + ''; + + pre-commit.settings = { + hooks = import ./pre-commit-hooks.nix; + }; + + }; +} diff --git a/crypto-benchmarks.rs/demo/ui/server.py b/crypto-benchmarks.rs/demo/ui/server.py index 8102fa3db..b150f4a9d 100644 --- a/crypto-benchmarks.rs/demo/ui/server.py +++ b/crypto-benchmarks.rs/demo/ui/server.py @@ -1,4 +1,12 @@ -from flask import Flask, send_from_directory, jsonify, render_template, abort, redirect, url_for +from flask import ( + Flask, + send_from_directory, + jsonify, + render_template, + abort, + redirect, + url_for, +) import json import subprocess from pathlib import Path @@ -22,7 +30,9 @@ def committee(run): abort(500, f"extract_committee.py not found at {script}") try: - out = subprocess.check_output(["python3", str(script), str(rdir)], cwd=ROOT, text=True) + out = subprocess.check_output( + ["python3", str(script), str(rdir)], cwd=ROOT, text=True + ) data = json.loads(out) return jsonify(data) except subprocess.CalledProcessError as e: @@ -48,11 +58,10 @@ def registry(run): pools.append({"id": pid, "stake": s}) total_stake += s - return jsonify({ - "pools": pools, - "total_pools": len(pools), - "total_stake": total_stake - }) + return jsonify( + {"pools": pools, "total_pools": len(pools), "total_stake": total_stake} + ) + @app.route("/demo/") def demo_for_run(run): @@ -63,6 +72,7 @@ def demo_for_run(run): return send_from_directory(str(run_dir), "demo.json") abort(404, f"demo.json not found in {run_dir}") + @app.route("/demo//") def demo_asset(run, filename): """Serve auxiliary files (eid.txt, ebhash.txt, etc.) from the run directory.""" @@ -72,15 +82,18 @@ def demo_asset(run, filename): return send_from_directory(str(run_dir), filename) abort(404, f"{filename} not found in {run_dir}") + # === UI endpoint === @app.route("/ui") def ui(): return render_template("index.html") + # Small helper route to redirect `/` to `/ui` @app.route("/") def root(): return redirect(url_for("ui")) + if __name__ == "__main__": app.run(host="0.0.0.0", port=5050, debug=True) diff --git a/flake.lock b/flake.lock index 8ab0aa100..9bb657c97 100644 --- a/flake.lock +++ b/flake.lock @@ -382,6 +382,40 @@ "type": "github" } }, + "flake-compat_7": { + "flake": false, + "locked": { + "lastModified": 1761588595, + "narHash": "sha256-XKUZz9zewJNUj46b4AJdiRZJAvSZ0Dqj2BNfXvFlJC4=", + "owner": "edolstra", + "repo": "flake-compat", + "rev": "f387cd2afec9419c8ee37694406ca490c3f34ee5", + "type": "github" + }, + "original": { + "owner": "edolstra", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-parts": { + "inputs": { + "nixpkgs-lib": "nixpkgs-lib" + }, + "locked": { + "lastModified": 1763759067, + "narHash": "sha256-LlLt2Jo/gMNYAwOgdRQBrsRoOz7BPRkzvNaI/fzXi2Q=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "2cccadc7357c0ba201788ae99c4dfa90728ef5e0", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "flake-parts", + "type": "github" + } + }, "flake-utils": { "inputs": { "systems": "systems" @@ -569,6 +603,27 @@ "type": "github" } }, + "gitignore_3": { + "inputs": { + "nixpkgs": [ + "pre-commit-hooks", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1709087332, + "narHash": "sha256-HG2cCnktfHsKV0s4XW83gU3F57gaTljL9KNSuG6bnQs=", + "owner": "hercules-ci", + "repo": "gitignore.nix", + "rev": "637db329424fd7e46cf4185293b9cc8c88c95394", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "gitignore.nix", + "type": "github" + } + }, "hackage": { "flake": false, "locked": { @@ -1692,6 +1747,21 @@ "type": "github" } }, + "nixpkgs-lib": { + "locked": { + "lastModified": 1761765539, + "narHash": "sha256-b0yj6kfvO8ApcSE+QmA6mUfu8IYG6/uU28OFn4PaC8M=", + "owner": "nix-community", + "repo": "nixpkgs.lib", + "rev": "719359f4562934ae99f5443f20aa06c2ffff91fc", + "type": "github" + }, + "original": { + "owner": "nix-community", + "repo": "nixpkgs.lib", + "type": "github" + } + }, "nixpkgs-regression": { "locked": { "lastModified": 1643052045, @@ -1898,6 +1968,37 @@ "type": "github" } }, + "nixpkgs_7": { + "locked": { + "lastModified": 1764862057, + "narHash": "sha256-yNA0Tng/zMguT87fi/ZzXh3lHC4QrMb5m21k2STVgIg=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "8429e36770290990df3b178fffccdc037145ac2b", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs_8": { + "locked": { + "lastModified": 1759417375, + "narHash": "sha256-O7eHcgkQXJNygY6AypkF9tFhsoDQjpNEojw3eFs73Ow=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "dc704e6102e76aad573f63b74c742cd96f8f1e6c", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, "old-ghc-nix": { "flake": false, "locked": { @@ -1932,6 +2033,26 @@ "type": "github" } }, + "pre-commit-hooks": { + "inputs": { + "flake-compat": "flake-compat_7", + "gitignore": "gitignore_3", + "nixpkgs": "nixpkgs_8" + }, + "locked": { + "lastModified": 1763988335, + "narHash": "sha256-QlcnByMc8KBjpU37rbq5iP7Cp97HvjRP0ucfdh+M4Qc=", + "owner": "cachix", + "repo": "git-hooks.nix", + "rev": "50b9238891e388c9fdc6a5c49e49c42533a1b5ce", + "type": "github" + }, + "original": { + "owner": "cachix", + "repo": "git-hooks.nix", + "type": "github" + } + }, "pre-commit-hooks-nix": { "inputs": { "flake-compat": "flake-compat_3", @@ -1976,8 +2097,11 @@ }, "root": { "inputs": { + "flake-parts": "flake-parts", "iogx": "iogx", - "leios-spec": "leios-spec" + "leios-spec": "leios-spec", + "nixpkgs": "nixpkgs_7", + "pre-commit-hooks": "pre-commit-hooks" } }, "secp256k1": { diff --git a/flake.nix b/flake.nix index 14edefbfc..2405d5d49 100644 --- a/flake.nix +++ b/flake.nix @@ -1,44 +1,72 @@ { description = "Ouroboros Leios"; + nixConfig = { + extra-substituters = [ + "https://cache.iog.io" + ]; + extra-trusted-public-keys = [ + "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=" + ]; + allow-import-from-derivation = true; + }; inputs = { - iogx = { - url = "github:input-output-hk/iogx"; - }; - - leios-spec.url = "github:input-output-hk/ouroboros-leios-formal-spec?rev=2ccae64440bf8834cbed69acfd1993a808b9046a"; - }; + nixpkgs.url = "github:NixOS/nixpkgs"; + iogx.url = "github:input-output-hk/iogx"; - outputs = inputs: inputs.iogx.lib.mkFlake { + leios-spec.url = "github:input-output-hk/ouroboros-leios-formal-spec?rev=2ccae64440bf8834cbed69acfd1993a808b9046a"; - inherit inputs; + flake-parts.url = "github:hercules-ci/flake-parts"; - repoRoot = ./.; + pre-commit-hooks.url = "github:cachix/git-hooks.nix"; + }; - outputs = import ./nix/outputs.nix; + outputs = + inputs@{ + self, + nixpkgs, + flake-parts, + ... + }: + let + inherit (nixpkgs) lib; + # Collect all the build.nix files (flake-parts modules) + buildDotNixes = import ./nix/findFilesRecursive.nix { + inherit lib; + toInclude = lib.hasSuffix "build.nix"; + dir = ./.; + }; + in + flake-parts.lib.mkFlake { inherit inputs; } { - # systems = [ "x86_64-linux" "x86_64-darwin" "aarch64-darwin" "aarch64-linux" ]; + imports = [ + inputs.pre-commit-hooks.flakeModule + ./nix/pkgs.nix + ] + ++ buildDotNixes; - # debug = false; + debug = true; - # nixpkgsArgs = { - # config = {}; - # overlays = []; - # }; + systems = [ + "x86_64-linux" + "x86_64-darwin" + "aarch64-linux" + "aarch64-darwin" + ]; - # flake = { repoRoot, inputs }: {}; - }; + flake.hydraJobs = import ./nix/hydra.nix { + flake = self; + inherit lib; + systems = [ + "x86_64-linux" + "x86_64-darwin" + "aarch64-linux" + "aarch64-darwin" + ]; + }; + }; - nixConfig = { - extra-substituters = [ - "https://cache.iog.io" - ]; - extra-trusted-public-keys = [ - "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=" - ]; - allow-import-from-derivation = true; - }; } diff --git a/leios-trace-hs/src/JSONCompat.hs b/leios-trace-hs/src/JSONCompat.hs index 52c527954..5e18eae18 100644 --- a/leios-trace-hs/src/JSONCompat.hs +++ b/leios-trace-hs/src/JSONCompat.hs @@ -60,7 +60,7 @@ parseFieldOrDefault obj = tracingParser v = parseJSON v `parserCatchError` ( \path msg -> - trace ("Using default value for: " ++ show path ++ " , error: " ++ msg) (pure defVal) + trace ("Using default value for: " ++ show path ++ " , error: " ++ msg) (pure defVal) ) parseField :: forall obj fld a. (HasField fld obj a, KnownSymbol fld, FromJSON a) => Object -> Parser a diff --git a/leios-trace-hs/src/LeiosEvents.hs b/leios-trace-hs/src/LeiosEvents.hs index 18be87954..b6a45627f 100644 --- a/leios-trace-hs/src/LeiosEvents.hs +++ b/leios-trace-hs/src/LeiosEvents.hs @@ -159,17 +159,17 @@ data Event where deriving (Generic) $( deriveJSON - defaultOptions - { sumEncoding = defaultTaggedObject{tagFieldName = "type"} - , fieldLabelModifier = \fl -> case fl of - ('b' : 'l' : 'o' : 'c' : 'k' : '_' : xs) -> xs - "bytes" -> "size_bytes" - "payload_bytes" -> "tx_payload_bytes" - xs -> xs - , allowOmittedFields = True - , omitNothingFields = True - } - ''Event + defaultOptions + { sumEncoding = defaultTaggedObject{tagFieldName = "type"} + , fieldLabelModifier = \fl -> case fl of + ('b' : 'l' : 'o' : 'c' : 'k' : '_' : xs) -> xs + "bytes" -> "size_bytes" + "payload_bytes" -> "tx_payload_bytes" + xs -> xs + , allowOmittedFields = True + , omitNothingFields = True + } + ''Event ) data TraceEvent = TraceEvent diff --git a/leios-trace-verifier/hs-src/app/linear/Main.hs b/leios-trace-verifier/hs-src/app/linear/Main.hs index 65ab0f45e..a90e1d9b2 100644 --- a/leios-trace-verifier/hs-src/app/linear/Main.hs +++ b/leios-trace-verifier/hs-src/app/linear/Main.hs @@ -41,8 +41,8 @@ main = result <- pure ($ startingSlot) <*> verifyTraceFromSlot nrNodes idSut stakeDistribution lhdr lvote ldiff validityCheckTime - . decodeJSONL - <$> BSL.readFile logFile + . decodeJSONL + <$> BSL.readFile logFile hPutStrLn stderr $ "Applying " <> show (fst result) <> " actions" unless (fst (snd result) == "ok") $ do diff --git a/leios-trace-verifier/hs-src/test/Spec.hs b/leios-trace-verifier/hs-src/test/Spec.hs index c58a79e6a..4c0b9932e 100644 --- a/leios-trace-verifier/hs-src/test/Spec.hs +++ b/leios-trace-verifier/hs-src/test/Spec.hs @@ -1,5 +1,4 @@ -- | Main entry point. - module Main where import Spec.Generated (generated) diff --git a/nix/agda.nix b/nix/agda.nix index 4a16eaac2..98de6eb35 100644 --- a/nix/agda.nix +++ b/nix/agda.nix @@ -1,4 +1,8 @@ -{ pkgs, lib, inputs, ... }: +{ + pkgs, + inputs, + ... +}: with pkgs; let @@ -6,22 +10,30 @@ let locales = { LANG = "en_US.UTF-8"; LC_ALL = "en_US.UTF-8"; - LOCALE_ARCHIVE = if pkgs.system == "x86_64-linux" - then "${pkgs.glibcLocales}/lib/locale/locale-archive" - else ""; + LOCALE_ARCHIVE = + if pkgs.system == "x86_64-linux" then "${pkgs.glibcLocales}/lib/locale/locale-archive" else ""; }; leiosSpec = inputs.leios-spec; - agdaIOGPrelude = leiosSpec.packages.agdaIOGPrelude; - agdaSets = leiosSpec.packages.agdaSets; - agdaStdlib = leiosSpec.packages.agdaStdlib; - agdaStdlibMeta = leiosSpec.packages.agdaStdlibMeta; - agdaStdlibClasses = leiosSpec.packages.agdaStdlibClasses; + inherit (leiosSpec.packages) + agdaIOGPrelude + agdaSets + agdaStdlib + agdaStdlibMeta + agdaStdlibClasses + agdaWithDeps + ; agdaLeiosSpec = leiosSpec.packages.leiosSpec; - agdaWithDeps = leiosSpec.packages.agdaWithDeps; - deps = [ agdaStdlib agdaStdlibMeta agdaStdlibClasses agdaSets agdaIOGPrelude agdaLeiosSpec ]; + deps = [ + agdaStdlib + agdaStdlibMeta + agdaStdlibClasses + agdaSets + agdaIOGPrelude + agdaLeiosSpec + ]; agdaTraceParser = pkgs.agdaPackages.mkDerivation { inherit (locales) LANG LC_ALL LOCALE_ARCHIVE; @@ -52,6 +64,15 @@ let }; in { - inherit agdaStdlib agdaStdlibMeta agdaStdlibClasses agdaSets agdaIOGPrelude agdaLeiosSpec agdaTraceParser hsTraceParser; + inherit + agdaStdlib + agdaStdlibMeta + agdaStdlibClasses + agdaSets + agdaIOGPrelude + agdaLeiosSpec + agdaTraceParser + hsTraceParser + ; agdaWithDeps = agdaWithDeps.withPackages { pkgs = deps; }; } diff --git a/nix/build.nix b/nix/build.nix new file mode 100644 index 000000000..4c4528348 --- /dev/null +++ b/nix/build.nix @@ -0,0 +1,14 @@ +# NOTE(bladyjoker): Removing the hydraJobs from iogx to produce it generically for the entire flake after +{ inputs, config, ... }: +{ + flake = builtins.removeAttrs (inputs.iogx.lib.mkFlake { + + inherit inputs; + + repoRoot = ./..; + + outputs = import ./outputs.nix; + + inherit (config) systems; + }) [ "hydraJobs" ]; +} diff --git a/nix/findFilesRecursive.nix b/nix/findFilesRecursive.nix new file mode 100644 index 000000000..e4af2ec94 --- /dev/null +++ b/nix/findFilesRecursive.nix @@ -0,0 +1,28 @@ +# NOTE(bladyjoker): Sadly needed because the repo contains files and directories that are invalid Nix Store path names +# TODO(bladyjoker): If the repo adjusts the naming scheme one can simply use lib.filesystem.listFilesRecursive +{ + lib, + toInclude, + dir, +}: +let + # Regex for characters allowed in Nix store paths: + # Alphanumeric, dots (.), underscores (_), plus (+), and hyphens (-) + isValidName = name: builtins.match "[a-zA-Z0-9._+-]+" name != null; + + internalFunc = + dir: + (lib.mapAttrsToList ( + name: type: + if isValidName name then + if type == "directory" then + internalFunc (dir + "/${name}") + else if toInclude name then + [ (dir + "/${name}") ] + else + [ ] + else + [ ] + ) (builtins.readDir dir)); +in +lib.flatten (internalFunc dir) diff --git a/nix/hydra.nix b/nix/hydra.nix new file mode 100644 index 000000000..cb0db28fa --- /dev/null +++ b/nix/hydra.nix @@ -0,0 +1,70 @@ +# Make default hydraJobs from Flake outputs +# If you have the following checks/devShells/packages +# β”œβ”€β”€β”€checks +# β”‚ └───x86_64-linux +# β”‚ β”œβ”€β”€β”€check-foo: derivation 'check-foo' +# β”‚ β”œβ”€β”€β”€check-bar: derivation 'check-bar' +# β”‚ └───x86_64-darwin +# β”‚ β”œβ”€β”€β”€check-foo: derivation 'check-foo' +# β”‚ β”œβ”€β”€β”€check-bar: derivation 'check-bar' +# β”œβ”€β”€β”€devShells +# β”‚ └───x86_64-linux +# β”‚ β”œβ”€β”€β”€dev-foo: development environment 'dev-foo' +# β”‚ β”œβ”€β”€β”€dev-bar: development environment 'dev-bar' +# β”‚ └───x86_64-darwin +# β”‚ β”œβ”€β”€β”€dev-foo: development environment 'dev-foo' +# β”‚ β”œβ”€β”€β”€dev-bar: development environment 'dev-bar' +# └───packages +# └───x86_64-linux +# β”œβ”€β”€β”€foo: package 'foo' +# β”œβ”€β”€β”€bar: package 'bar' +# └───x86_64-darwin +# β”œβ”€β”€β”€foo: package 'foo' +# β”œβ”€β”€β”€bar: package 'bar' +# This function will produce hydraJobs as +# β”œβ”€β”€β”€hydraJobs +# β”‚ β”œβ”€β”€β”€checks +# β”‚ β”‚ β”œβ”€β”€β”€check-foo +# β”‚ β”‚ β”‚ └───x86_64-linux: derivation 'check-foo' +# β”‚ β”‚ β”‚ └───x86_64-darwin: derivation 'check-foo' +# β”‚ β”‚ β”œβ”€β”€β”€check-bar +# β”‚ β”‚ β”‚ └───x86_64-linux: derivation 'check-bar' +# β”‚ β”‚ β”‚ └───x86_64-darwin: derivation 'check-bar' +# β”‚ β”œβ”€β”€β”€devShells +# β”‚ β”‚ β”œβ”€β”€β”€dev-foo +# β”‚ β”‚ β”‚ └───x86_64-linux: derivation 'dev-foo' +# β”‚ β”‚ β”‚ └───x86_64-darwin: derivation 'dev-foo' +# β”‚ β”‚ β”œβ”€β”€β”€dev-bar +# β”‚ β”‚ β”‚ └───x86_64-linux: derivation 'dev-bar' +# β”‚ β”‚ β”‚ └───x86_64-darwin: derivation 'dev-bar' +# β”‚ └───packages +# β”‚ β”œβ”€β”€β”€foo +# β”‚ β”‚ └───x86_64-linux: derivation 'foo' +# β”‚ β”‚ └───x86_64-darwin: derivation 'foo' +# β”‚ β”œβ”€β”€β”€bar +# β”‚ β”‚ └───x86_64-linux: derivation 'bar' +# β”‚ β”‚ └───x86_64-darwin: derivation 'bar' +{ + flake, + lib, + systems, + ... +}: +let + flakeOutputs = [ + "packages" + "checks" + "devShells" + ]; +in +lib.genAttrs flakeOutputs ( + flakeOutput: + lib.foldl' lib.recursiveUpdate { } ( + builtins.map ( + system: + lib.genAttrs (builtins.attrNames flake.${flakeOutput}.${system}) (drvName: { + ${system} = flake.${flakeOutput}.${system}.${drvName}; + }) + ) systems + ) +) diff --git a/nix/outputs.nix b/nix/outputs.nix index 43116df55..771ad25cf 100644 --- a/nix/outputs.nix +++ b/nix/outputs.nix @@ -1,15 +1,21 @@ -{ repoRoot, inputs, pkgs, lib, system }: +{ + repoRoot, + inputs, + pkgs, + lib, + ... +}: let - project = repoRoot.nix.project; + inherit (repoRoot.nix) project; agda = import ./agda.nix { inherit pkgs lib inputs; }; artifacts = import ./artifacts.nix { inherit pkgs; }; in [ - (project.flake) + project.flake { packages = agda // artifacts; diff --git a/nix/pkgs.nix b/nix/pkgs.nix new file mode 100644 index 000000000..b17a656ec --- /dev/null +++ b/nix/pkgs.nix @@ -0,0 +1,15 @@ +# Repo-wide Nixpkgs with different overlays +{ inputs, ... }: +{ + perSystem = + { system, ... }: + { + + _module.args = { + pkgs = import inputs.nixpkgs { + inherit system; + }; + + }; + }; +} diff --git a/nix/project.nix b/nix/project.nix index db61cac93..f8010e7fd 100644 --- a/nix/project.nix +++ b/nix/project.nix @@ -1,8 +1,14 @@ -{ repoRoot, inputs, pkgs, system, lib }: +{ + repoRoot, + inputs, + pkgs, + lib, + ... +}: let - agda = import ./agda.nix {inherit pkgs lib inputs;}; + agda = import ./agda.nix { inherit pkgs lib inputs; }; sources = pkgs.stdenv.mkDerivation { name = "leios-hs-sources"; @@ -36,27 +42,15 @@ let ''; }; - cabalProject' = pkgs.haskell-nix.cabalProject' ({ pkgs, config, ... }: - let - # When `isCross` is `true`, it means that we are cross-compiling the project. - # WARNING You must use the `pkgs` coming from cabalProject' for `isCross` to work. - isCross = pkgs.stdenv.hostPlatform != pkgs.stdenv.buildPlatform; - in - { - src = sources.out; - shell.withHoogle = false; - inputMap = { - "https://chap.intersectmbo.org/" = inputs.iogx.inputs.CHaP; - }; - name = "ouroboros-leios"; - compiler-nix-name = lib.mkDefault "ghc9101"; - modules = [ - { #enableLibraryProfiling = true; - #enableProfiling = true; - #profilingDetail = "late"; - } - ]; - }); + cabalProject' = pkgs.haskell-nix.cabalProject' { + src = sources.out; + shell.withHoogle = false; + inputMap = { + "https://chap.intersectmbo.org/" = inputs.iogx.inputs.CHaP; + }; + name = "ouroboros-leios"; + compiler-nix-name = lib.mkDefault "ghc9101"; + }; cabalProject = cabalProject'.appendOverlays [ ]; @@ -65,22 +59,6 @@ let inherit cabalProject; shellArgs = repoRoot.nix.shell; - - # includeMingwW64HydraJobs = false; - - # includeProfiledHydraJobs = false; - - # readTheDocs = { - # enable = false; - # siteFolder = "doc/read-the-docs-site"; - # sphinxToolchain = null; - # }; - - # combinedHaddock = { - # enable = false; - # prologue = ""; - # packages = []; - # }; }; in diff --git a/nix/shell.nix b/nix/shell.nix index f93d2bbaa..022374749 100644 --- a/nix/shell.nix +++ b/nix/shell.nix @@ -1,19 +1,27 @@ # Docs for this file: https://github.com/input-output-hk/iogx/blob/main/doc/api.md#mkhaskellprojectinshellargs # See `shellArgs` in `mkHaskellProject` in ./project.nix for more details. -{ repoRoot, inputs, pkgs, lib, system }: +{ + inputs, + pkgs, + lib, + ... +}: # Each flake variant defined in your project.nix project will yield a separate -# shell. If no flake variants are defined, then cabalProject is the original +# shell. If no flake variants are defined, then cabalProject is the original # project. -cabalProject: +_cabalProject: let - agda = import ./agda.nix {inherit pkgs lib inputs;}; - emacsWithPackages = pkgs.emacs.pkgs.withPackages (epkgs: [ epkgs.agda2-mode pkgs.mononoki ]); + agda = import ./agda.nix { inherit pkgs lib inputs; }; + emacsWithPackages = pkgs.emacs.pkgs.withPackages (epkgs: [ + epkgs.agda2-mode + pkgs.mononoki + ]); -in +in { name = "nix-shell"; @@ -29,80 +37,27 @@ in ]; # Agda environment variables. - env.AGDA_STDLIB = "${agda.agdaStdlib}/standard-library.agda-lib"; - env.AGDA_STDLIB_CLASSES = "${agda.agdaStdlibClasses}/standard-library-classes.agda-lib"; - env.AGDA_STDLIB_META = "${agda.agdaStdlibMeta}/standard-library-meta.agda-lib"; - env.AGDA_SETS = "${agda.agdaSets}/abstract-set-theory.agda-lib"; - env.AGDA_IOG_PRELUDE = "${agda.agdaIOGPrelude}/iog-prelude.agda-lib"; - -# prompt = "[ouroboros-leios]$ "; + env = { + AGDA_STDLIB = "${agda.agdaStdlib}/standard-library.agda-lib"; + AGDA_STDLIB_CLASSES = "${agda.agdaStdlibClasses}/standard-library-classes.agda-lib"; + AGDA_STDLIB_META = "${agda.agdaStdlibMeta}/standard-library-meta.agda-lib"; + AGDA_SETS = "${agda.agdaSets}/abstract-set-theory.agda-lib"; + AGDA_IOG_PRELUDE = "${agda.agdaIOGPrelude}/iog-prelude.agda-lib"; + }; welcomeMessage = '' - Welcome to Ouroboros Leios! + Welcome to Ouroboros Leios! - Locations of Agda libraries: - ${agda.agdaStdlib}/standard-library.agda-lib - ${agda.agdaStdlibClasses}/standard-library-classes.agda-lib - ${agda.agdaStdlibMeta}/standard-library-meta.agda-lib - ${agda.agdaSets}/abstract-set-theory.agda-lib - ${agda.agdaIOGPrelude}/iog-prelude.agda-lib + Locations of Agda libraries: + ${agda.agdaStdlib}/standard-library.agda-lib + ${agda.agdaStdlibClasses}/standard-library-classes.agda-lib + ${agda.agdaStdlibMeta}/standard-library-meta.agda-lib + ${agda.agdaSets}/abstract-set-theory.agda-lib + ${agda.agdaIOGPrelude}/iog-prelude.agda-lib - Run 'emacs' to edit .agda files. + Run 'emacs' to edit .agda files. ''; - # shellHook = ""; - tools = { - # haskellCompilerVersion = cabalProject.args.compiler-nix-name; - # cabal-fmt = null; - # cabal-install = null; - # haskell-language-server = null; - # haskell-language-server-wrapper = null; - # fourmolu = null; - # hlint = null; - # stylish-haskell = null; - # ghcid = null; - # shellcheck = null; - # prettier = null; - # editorconfig-checker = null; - # nixpkgs-fmt = null; - # optipng = null; - # purs-tidy = null; }; - - # scripts = { - # foo = { - # description = ""; - # group = "general"; - # enabled = true; - # exec = '' - # echo "Hello, World!" - # ''; - # }; - # }; - - # preCommit = { - # cabal-fmt.enable = false; - # cabal-fmt.extraOptions = ""; - # stylish-haskell.enable = false; - # stylish-haskell.extraOptions = ""; - # fourmolu.enable = false; - # fourmolu.extraOptions = ""; - # hlint.enable = false; - # hlint.extraOptions = ""; - # shellcheck.enable = false; - # shellcheck.extraOptions = ""; - # prettier.enable = false; - # prettier.extraOptions = ""; - # editorconfig-checker.enable = false; - # editorconfig-checker.extraOptions = ""; - # nixpkgs-fmt.enable = false; - # nixpkgs-fmt.extraOptions = ""; - # optipng.enable = false; - # optipng.extraOptions = ""; - # purs-tidy.enable = false; - # purs-tidy.extraOptions = ""; - # }; - } - diff --git a/nix/web-shell.nix b/nix/web-shell.nix index f2dc5df4e..2858ff47f 100644 --- a/nix/web-shell.nix +++ b/nix/web-shell.nix @@ -1,4 +1,6 @@ -{ pkgs ? import { } }: +{ + pkgs ? import { }, +}: pkgs.mkShell { packages = [ diff --git a/pre-commit-hooks.nix b/pre-commit-hooks.nix new file mode 100644 index 000000000..57171ce37 --- /dev/null +++ b/pre-commit-hooks.nix @@ -0,0 +1,16 @@ +# Sourced by build.nix +# https://github.com/cachix/git-hooks.nix?tab=readme-ov-file#hooks +{ + # Nix + nixfmt-rfc-style.enable = true; + deadnix.enable = true; + statix.enable = true; + + # Haskell + fourmolu.enable = true; + hlint.enable = true; + + # Python + black.enable = true; + ruff.enable = true; +} diff --git a/scripts/trace-translator/trace-translator.py b/scripts/trace-translator/trace-translator.py index 9bf16178c..c4a9610c4 100755 --- a/scripts/trace-translator/trace-translator.py +++ b/scripts/trace-translator/trace-translator.py @@ -5,12 +5,15 @@ in the format expected by the Leios trace verifier. """ -import json, sys +import json +import sys from datetime import datetime, timezone + def log_message(message, time): print(json.dumps({"message": message, "time_s": time.total_seconds()})) + fmt = "%Y-%m-%dT%H:%M:%S.%fZ" last_at = None last_SLC_slot = None @@ -23,43 +26,39 @@ def log_message(message, time): exit(127) if last_at is None: - last_at = obj['at'] + last_at = obj["at"] - curr_at = obj['at'] - time = datetime.strptime(curr_at, fmt).replace(tzinfo=timezone.utc) \ - - \ - datetime.strptime(last_at, fmt).replace(tzinfo=timezone.utc) + curr_at = obj["at"] + time = datetime.strptime(curr_at, fmt).replace( + tzinfo=timezone.utc + ) - datetime.strptime(last_at, fmt).replace(tzinfo=timezone.utc) last_at = curr_at - if obj['ns'] == "Forge.Loop.AdoptedBlock": + if obj["ns"] == "Forge.Loop.AdoptedBlock": message = { - "type": "RBGenerated", - "producer": obj['host'], - "slot": last_SLC_slot, - "id": obj['data']['blockHash'], - "endorsement": None, - "parent": None, # FIXME: This is not available - "size": obj['data']['blockSize'], - "tx_payload_bytes": None, # FIXME: This is not available - } - elif obj['ns'] == "BlockFetch.Client.CompletedBlockFetch": + "type": "RBGenerated", + "producer": obj["host"], + "slot": last_SLC_slot, + "id": obj["data"]["blockHash"], + "endorsement": None, + "parent": None, # FIXME: This is not available + "size": obj["data"]["blockSize"], + "tx_payload_bytes": None, # FIXME: This is not available + } + elif obj["ns"] == "BlockFetch.Client.CompletedBlockFetch": message = { - "type": "RBReceived", - "recipient": obj['host'], - "id": obj['data']['block'] - } + "type": "RBReceived", + "recipient": obj["host"], + "id": obj["data"]["block"], + } else: - if obj['ns'] == "Forge.Loop.StartLeadershipCheck": + if obj["ns"] == "Forge.Loop.StartLeadershipCheck": if last_SLC_slot is None: - last_SLC_slot = obj['data']['slot'] + last_SLC_slot = obj["data"]["slot"] else: - message = { - "type": "Slot", - "node": obj['host'], - "slot": last_SLC_slot - } + message = {"type": "Slot", "node": obj["host"], "slot": last_SLC_slot} log_message(message, time) - last_SLC_slot = obj['data']['slot'] + last_SLC_slot = obj["data"]["slot"] continue log_message(message, time) diff --git a/simulation/src/LeiosProtocol/Short.hs b/simulation/src/LeiosProtocol/Short.hs index 730199403..c7042b805 100644 --- a/simulation/src/LeiosProtocol/Short.hs +++ b/simulation/src/LeiosProtocol/Short.hs @@ -291,8 +291,8 @@ convertConfig disk = durationMsToDiffTime $ sum [ disk.voteGenerationCpuTimeMsConstant - + disk.voteGenerationCpuTimeMsPerIb - `forEach` eb.inputBlocks + + disk.voteGenerationCpuTimeMsPerIb + `forEach` eb.inputBlocks | eb <- ebs ] , linearVoteMsgGeneration = \vm ibs -> @@ -354,11 +354,11 @@ delaysAndSizesAsFull cfg@LeiosConfig{pipeline, voteSendStage} = ] fullLinearEBsVotedFor = [ InputBlock - { body = fullIB.body - , header = - let InputBlockHeader{..} = fullIB.header - in InputBlockHeader{id = unconvertLinearId id', ..} - } + { body = fullIB.body + , header = + let InputBlockHeader{..} = fullIB.header + in InputBlockHeader{id = unconvertLinearId id', ..} + } | id' <- fullVT.endorseBlocks ] fullRB = mockFullRankingBlock cfg diff --git a/simulation/src/LeiosProtocol/Short/Sim.hs b/simulation/src/LeiosProtocol/Short/Sim.hs index d41ca66ca..e388cd860 100644 --- a/simulation/src/LeiosProtocol/Short/Sim.hs +++ b/simulation/src/LeiosProtocol/Short/Sim.hs @@ -94,9 +94,9 @@ logLeiosEvent nodeNames loudness e = case e of .= to <> mconcat [ "fragments" - .= length fcs - <> "forecast" - .= forecast + .= length fcs + <> "forecast" + .= forecast | emitDebug ] <> mconcat ["forecasts" .= fcs | emitControl] diff --git a/simulation/src/LeiosProtocol/Short/SimP2P.hs b/simulation/src/LeiosProtocol/Short/SimP2P.hs index 4cd7e7080..cee73014f 100644 --- a/simulation/src/LeiosProtocol/Short/SimP2P.hs +++ b/simulation/src/LeiosProtocol/Short/SimP2P.hs @@ -62,10 +62,10 @@ traceLeiosP2P mapM_ (\m -> mapM_ forkIO =<< m) [ leiosNode - (nodeTracer nid) - (leiosNodeConfig slotConfig nid rng) - (Map.findWithDefault [] nid chansToDownstream) - (Map.findWithDefault [] nid chansToUpstream) + (nodeTracer nid) + (leiosNodeConfig slotConfig nid rng) + (Map.findWithDefault [] nid chansToDownstream) + (Map.findWithDefault [] nid chansToUpstream) | (nid, rng) <- zip (Map.keys p2pNodes) diff --git a/simulation/src/LeiosProtocol/Short/VizSim.hs b/simulation/src/LeiosProtocol/Short/VizSim.hs index c2994114a..4ea9cbe92 100644 --- a/simulation/src/LeiosProtocol/Short/VizSim.hs +++ b/simulation/src/LeiosProtocol/Short/VizSim.hs @@ -106,12 +106,12 @@ data LeiosSimVizState = LeiosSimVizState , vizNodeLinks :: !(Map Link LinkPoints) , vizMsgsInTransit :: !( Map - (NodeId, NodeId) - [ ( LeiosMessage - , TcpMsgForecast - , [TcpMsgForecast] - ) - ] + (NodeId, NodeId) + [ ( LeiosMessage + , TcpMsgForecast + , [TcpMsgForecast] + ) + ] ) , vizNodeTip :: !(Map NodeId FullTip) , -- the Buffer and Queue names are legacy from VizSimRelay. @@ -738,11 +738,11 @@ leiosSimVizRenderModel Cairo.setLineWidth 3 sequence_ [ do - Cairo.arc x y 25 0 (pi * 2) - Cairo.setSourceRGB r b g - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.stroke + Cairo.arc x y 25 0 (pi * 2) + Cairo.setSourceRGB r b g + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.stroke | (node, pos) <- Map.toList vizNodePos , let (Point x y) = simPointToPixel worldDimensions screenSize pos , let (r, b, g) = case Map.lookup node vizNodeTip of @@ -757,24 +757,24 @@ leiosSimVizRenderModel Cairo.setLineWidth 3 sequence_ [ do - Cairo.save - renderPathRoundedRect fromPos toPos 20 - Cairo.setSourceRGB 0.9 0.9 0.9 - Cairo.fillPreserve - Cairo.clip - Cairo.newPath - -- draw all the messages within the clipping region of the link - renderMessagesInFlight - (TcpSimVizConfig $ leiosMessageColor cfg) - now - fromPos - toPos - msgs - Cairo.restore - -- the draw the link border on top (without clipping) - renderPathRoundedRect fromPos toPos 20 - Cairo.setSourceRGB 0 0 0 - Cairo.stroke + Cairo.save + renderPathRoundedRect fromPos toPos 20 + Cairo.setSourceRGB 0.9 0.9 0.9 + Cairo.fillPreserve + Cairo.clip + Cairo.newPath + -- draw all the messages within the clipping region of the link + renderMessagesInFlight + (TcpSimVizConfig $ leiosMessageColor cfg) + now + fromPos + toPos + msgs + Cairo.restore + -- the draw the link border on top (without clipping) + renderPathRoundedRect fromPos toPos 20 + Cairo.setSourceRGB 0 0 0 + Cairo.stroke | (fromPos, toPos, msgs) <- linksAndMsgs ] -- draw the message labels on top of the links @@ -815,8 +815,8 @@ leiosSimVizRenderModel -- draw lines from labels to messages sequence_ [ do - withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) - withPoint Cairo.lineTo msgTrailingEdge + withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) + withPoint Cairo.lineTo msgTrailingEdge | ((_msgLabel, msgforecast), n) <- zip msgLabels [0 ..] , let (msgTrailingEdge, _msgLeadingEdge) = lineMessageInFlight now fromPos toPos msgforecast @@ -826,9 +826,9 @@ leiosSimVizRenderModel Cairo.setSourceRGB 0 0 0 sequence_ [ do - withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) - Cairo.showText msgLabel - Cairo.newPath + withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) + Cairo.showText msgLabel + Cairo.newPath | ((msgLabel, _), n) <- zip msgLabels [0 ..] ] Cairo.restore @@ -846,18 +846,18 @@ leiosSimVizRenderModel Cairo.save sequence_ [ do - Cairo.setSourceRGB r g b - Cairo.arc (x - 10) y' 10 0 (2 * pi) - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.setLineWidth 1 - Cairo.stroke - case nodeMessageText msg of - Nothing -> return () - Just txt -> do - Cairo.moveTo (x - 32) (y' + 5) - Cairo.showText txt - Cairo.newPath + Cairo.setSourceRGB r g b + Cairo.arc (x - 10) y' 10 0 (2 * pi) + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.setLineWidth 1 + Cairo.stroke + case nodeMessageText msg of + Nothing -> return () + Just txt -> do + Cairo.moveTo (x - 32) (y' + 5) + Cairo.showText txt + Cairo.newPath | (node, msgs) <- Map.toList msgsAtNodeQueue , (n, msg) <- zip [1 ..] msgs , let (Point x y) = @@ -870,18 +870,18 @@ leiosSimVizRenderModel ] sequence_ [ do - Cairo.setSourceRGB r g b - Cairo.arc (x + 10) y' 10 0 (2 * pi) - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.setLineWidth 1 - Cairo.stroke - case nodeMessageText msg of - Nothing -> return () - Just txt -> do - Cairo.moveTo (x + 22) (y' + 5) - Cairo.showText txt - Cairo.newPath + Cairo.setSourceRGB r g b + Cairo.arc (x + 10) y' 10 0 (2 * pi) + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.setLineWidth 1 + Cairo.stroke + case nodeMessageText msg of + Nothing -> return () + Just txt -> do + Cairo.moveTo (x + 22) (y' + 5) + Cairo.showText txt + Cairo.newPath | (node, msgs) <- Map.toList msgsAtNodeBuffer , (n, msg) <- zip [1 ..] msgs , let (Point x y) = diff --git a/simulation/src/LeiosProtocol/Short/VizSimP2P.hs b/simulation/src/LeiosProtocol/Short/VizSimP2P.hs index f374340e9..453cdff19 100644 --- a/simulation/src/LeiosProtocol/Short/VizSimP2P.hs +++ b/simulation/src/LeiosProtocol/Short/VizSimP2P.hs @@ -210,30 +210,30 @@ leiosP2PSimVizRenderModel Cairo.setFontSize 10 sequence_ [ do - Cairo.arc x y 10 0 (pi * 2) - Cairo.setSourceRGB r g b - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.stroke - {- - -- Label with message counts, processing and buffer - let qlabel = show nqmsgs ++ "," ++ show rqmsgs ++ "," ++ show tqmsgs - Cairo.moveTo (x-6) (y-5) - Cairo.setSourceRGB 1 1 1 -- white backdrop text for readabilty - Cairo.showText qlabel -- on dark backgrounds - Cairo.moveTo (x-7) (y-4) - Cairo.setSourceRGB 0 0 0 - Cairo.showText qlabel + Cairo.arc x y 10 0 (pi * 2) + Cairo.setSourceRGB r g b + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.stroke + {- + -- Label with message counts, processing and buffer + let qlabel = show nqmsgs ++ "," ++ show rqmsgs ++ "," ++ show tqmsgs + Cairo.moveTo (x-6) (y-5) + Cairo.setSourceRGB 1 1 1 -- white backdrop text for readabilty + Cairo.showText qlabel -- on dark backgrounds + Cairo.moveTo (x-7) (y-4) + Cairo.setSourceRGB 0 0 0 + Cairo.showText qlabel - let blabel = show nbmsgs ++ "," ++ show rbmsgs ++ "," ++ show tbmsgs - Cairo.moveTo (x-6) (y+10) - Cairo.setSourceRGB 1 1 1 -- white backdrop text for readabilty - Cairo.showText blabel -- on dark backgrounds - Cairo.moveTo (x-7) (y+9) - Cairo.setSourceRGB 0 0 0 - Cairo.showText blabel - -} - Cairo.newPath + let blabel = show nbmsgs ++ "," ++ show rbmsgs ++ "," ++ show tbmsgs + Cairo.moveTo (x-6) (y+10) + Cairo.setSourceRGB 1 1 1 -- white backdrop text for readabilty + Cairo.showText blabel -- on dark backgrounds + Cairo.moveTo (x-7) (y+9) + Cairo.setSourceRGB 0 0 0 + Cairo.showText blabel + -} + Cairo.newPath | (node, pos) <- Map.toList vizNodePos , let Point x y = toScreenPoint pos -- qmsgs = fromMaybe [] (Map.lookup node vizMsgsAtNodeQueue) @@ -259,72 +259,72 @@ leiosP2PSimVizRenderModel Cairo.save sequence_ [ case classifyInFlightMsgs msgs of - -- We don't even draw links that are inactive - MsgsInFlightNone -> return () - -- Similarly, all links will have boring control messages - -- it'd be too much details - MsgsInFlightControl -> return () - -- We draw with a dotted line - MsgsInFlightNonBallistic -> - case catMaybes [snd <$> ptclMessageColor msg | (msg, _, _) <- msgs] of - [] -> return () - ((toSRGB -> (r, g, b)) : _) -> do - Cairo.setSourceRGB r g b - Cairo.setLineWidth 1 - Cairo.setDash [10, 5] 0 - case vizNodeLinks !!! (fromNode, toNode) of - LinkPointsNoWrap fromPos toPos -> do - withPoint Cairo.moveTo (toScreenPoint fromPos) - withPoint Cairo.lineTo (toScreenPoint toPos) - Cairo.stroke - LinkPointsWrap fromPos toPos fromPos' toPos' -> do - withPoint Cairo.moveTo (toScreenPoint fromPos) - withPoint Cairo.lineTo (toScreenPoint toPos) - Cairo.stroke - withPoint Cairo.moveTo (toScreenPoint fromPos') - withPoint Cairo.lineTo (toScreenPoint toPos') - Cairo.stroke + -- We don't even draw links that are inactive + MsgsInFlightNone -> return () + -- Similarly, all links will have boring control messages + -- it'd be too much details + MsgsInFlightControl -> return () + -- We draw with a dotted line + MsgsInFlightNonBallistic -> + case catMaybes [snd <$> ptclMessageColor msg | (msg, _, _) <- msgs] of + [] -> return () + ((toSRGB -> (r, g, b)) : _) -> do + Cairo.setSourceRGB r g b + Cairo.setLineWidth 1 + Cairo.setDash [10, 5] 0 + case vizNodeLinks !!! (fromNode, toNode) of + LinkPointsNoWrap fromPos toPos -> do + withPoint Cairo.moveTo (toScreenPoint fromPos) + withPoint Cairo.lineTo (toScreenPoint toPos) + Cairo.stroke + LinkPointsWrap fromPos toPos fromPos' toPos' -> do + withPoint Cairo.moveTo (toScreenPoint fromPos) + withPoint Cairo.lineTo (toScreenPoint toPos) + Cairo.stroke + withPoint Cairo.moveTo (toScreenPoint fromPos') + withPoint Cairo.lineTo (toScreenPoint toPos') + Cairo.stroke - -- We draw with a full line - MsgsInFlightBallistic -> - case catMaybes [snd <$> ptclMessageColor msg | (msg, _, _) <- msgs] of - [] -> return () - ((toSRGB -> (r, g, b)) : _) -> do - Cairo.setSourceRGB r g b - Cairo.setDash [] 0 - Cairo.setLineWidth 2 - case vizNodeLinks !!! (fromNode, toNode) of - LinkPointsNoWrap fromPos toPos -> do - withPoint Cairo.moveTo (toScreenPoint fromPos) - withPoint Cairo.lineTo (toScreenPoint toPos) - Cairo.stroke - LinkPointsWrap fromPos toPos fromPos' toPos' -> do - withPoint Cairo.moveTo (toScreenPoint fromPos) - withPoint Cairo.lineTo (toScreenPoint toPos) - Cairo.stroke - withPoint Cairo.moveTo (toScreenPoint fromPos') - withPoint Cairo.lineTo (toScreenPoint toPos') - Cairo.stroke + -- We draw with a full line + MsgsInFlightBallistic -> + case catMaybes [snd <$> ptclMessageColor msg | (msg, _, _) <- msgs] of + [] -> return () + ((toSRGB -> (r, g, b)) : _) -> do + Cairo.setSourceRGB r g b + Cairo.setDash [] 0 + Cairo.setLineWidth 2 + case vizNodeLinks !!! (fromNode, toNode) of + LinkPointsNoWrap fromPos toPos -> do + withPoint Cairo.moveTo (toScreenPoint fromPos) + withPoint Cairo.lineTo (toScreenPoint toPos) + Cairo.stroke + LinkPointsWrap fromPos toPos fromPos' toPos' -> do + withPoint Cairo.moveTo (toScreenPoint fromPos) + withPoint Cairo.lineTo (toScreenPoint toPos) + Cairo.stroke + withPoint Cairo.moveTo (toScreenPoint fromPos') + withPoint Cairo.lineTo (toScreenPoint toPos') + Cairo.stroke | ((fromNode, toNode), msgs) <- Map.toList vizMsgsInTransit ] Cairo.restore -- draw the messages in flight on top sequence_ [ case vizNodeLinks !!! (fromNode, toNode) of - LinkPointsNoWrap fromPos toPos -> do - let (msgTrailingEdge, _msgLeadingEdge) = - lineMessageInFlight now fromPos toPos msgforecast - Point x y = toScreenPoint msgTrailingEdge - renderDiagramAt screenSize (x, y) $ messageDiagram msgViz - LinkPointsWrap fromPos toPos fromPos' toPos' -> do - let (msgTrailingEdge, _msgLeadingEdge) = - lineMessageInFlight now fromPos toPos msgforecast - Point x y = toScreenPoint msgTrailingEdge - renderDiagramAt screenSize (x, y) $ messageDiagram msgViz - let (msgTrailingEdge', _msgLeadingEdge) = - lineMessageInFlight now fromPos' toPos' msgforecast - Point x' y' = toScreenPoint msgTrailingEdge' - renderDiagramAt screenSize (x', y') $ messageDiagram msgViz + LinkPointsNoWrap fromPos toPos -> do + let (msgTrailingEdge, _msgLeadingEdge) = + lineMessageInFlight now fromPos toPos msgforecast + Point x y = toScreenPoint msgTrailingEdge + renderDiagramAt screenSize (x, y) $ messageDiagram msgViz + LinkPointsWrap fromPos toPos fromPos' toPos' -> do + let (msgTrailingEdge, _msgLeadingEdge) = + lineMessageInFlight now fromPos toPos msgforecast + Point x y = toScreenPoint msgTrailingEdge + renderDiagramAt screenSize (x, y) $ messageDiagram msgViz + let (msgTrailingEdge', _msgLeadingEdge) = + lineMessageInFlight now fromPos' toPos' msgforecast + Point x' y' = toScreenPoint msgTrailingEdge' + renderDiagramAt screenSize (x', y') $ messageDiagram msgViz | ((fromNode, toNode), msgs) <- Map.toList vizMsgsInTransit , (msg, msgforecast, _msgforecasts) <- msgs , now >= msgSendTrailingEdge msgforecast @@ -387,11 +387,11 @@ chartDiffusionLatency cfg@LeiosP2PSimVizConfig{nodeMessageColor} tag = \_ _ ( SimVizModel - _ - st@LeiosSimVizState - { vizNodeStakes - } - ) -> case tag of + _ + st@LeiosSimVizState + { vizNodeStakes + } + ) -> case tag of RB -> theChart (show tag) vizNodeStakes nodeMessageColor . coerce . Map.elems $ st.vizMsgsDiffusionLatency IB -> theChart (show tag) vizNodeStakes cfg.ibColor . coerce . Map.elems $ st.ibDiffusionLatency EB -> theChart (show tag) vizNodeStakes cfg.ebColor . coerce . Map.elems $ st.ebDiffusionLatency @@ -413,14 +413,14 @@ chartDiffusionLatency cfg@LeiosP2PSimVizConfig{nodeMessageColor} tag = } , Chart._layout_plots = [ Chart.toPlot $ - Chart.def - { Chart._plot_lines_values = [timeseries] - , Chart._plot_lines_style = - let (r, g, b) = nodeMsgColor blk - in Chart.def - { Chart._line_color = Chart.opaque (Colour.sRGB r g b) - } - } + Chart.def + { Chart._plot_lines_values = [timeseries] + , Chart._plot_lines_style = + let (r, g, b) = nodeMsgColor blk + in Chart.def + { Chart._line_color = Chart.opaque (Colour.sRGB r g b) + } + } | (blk, _nid, created, arrivals) <- msgsDiffusionLatency , let timeseries = map (second Chart.Percent) $ @@ -435,9 +435,9 @@ chartBandwidth LeiosModelConfig{recentSpan} = \_ _ ( SimVizModel - _ - vs - ) -> + _ + vs + ) -> (Chart.def :: Chart.Layout Double Double) { Chart._layout_title = "Distribution of block frequency" , Chart._layout_title_style = Chart.def{Chart._font_size = 15} @@ -458,14 +458,14 @@ chartBandwidth LeiosModelConfig{recentSpan} = where recentPlot lbl color maps = [ bandwidthHistPlot - maxX - (0, maxX) - lbl - color - ( map - (fromIntegral :: Int -> Double) - (Map.elems recent) - ) + maxX + (0, maxX) + lbl + color + ( map + (fromIntegral :: Int -> Double) + (Map.elems recent) + ) | not (Map.null recent) ] where @@ -520,9 +520,9 @@ chartCPUUsage LeiosModelConfig{numCores} = \(Time now) _ ( SimVizModel - _ - vs - ) -> + _ + vs + ) -> let numNodes = Map.size vs.vizNodePos maxCPUs = case numCores of @@ -562,9 +562,9 @@ chartDataTransmitted LeiosModelConfig{maxBandwidthPerNode} = \(Time now) _ ( SimVizModel - _ - vs - ) -> + _ + vs + ) -> let numNodes = Map.size vs.vizNodePos toMiB = (/ 1e6) @@ -603,11 +603,11 @@ chartLinkUtilisation = \_ _ ( SimVizModel - _ - LeiosSimVizState - { vizMsgsInTransit - } - ) -> + _ + LeiosSimVizState + { vizMsgsInTransit + } + ) -> let counts :: UArray MsgsInFlightClassification Int counts = accumArray @@ -763,8 +763,8 @@ example2 , LayoutBeside [ LayoutAbove [ LayoutReqSize 350 250 $ - Layout $ - chartDiffusionLatency config tag + Layout $ + chartDiffusionLatency config tag | tag <- [IB, EB, VT, RB] ] , LayoutAbove diff --git a/simulation/src/LeiosProtocol/VizSimTestRelay.hs b/simulation/src/LeiosProtocol/VizSimTestRelay.hs index 950997e00..22d43b4bb 100644 --- a/simulation/src/LeiosProtocol/VizSimTestRelay.hs +++ b/simulation/src/LeiosProtocol/VizSimTestRelay.hs @@ -127,12 +127,12 @@ data RelaySimVizState = RelaySimVizState , vizNodeLinks :: !(Map Link LinkPoints) , vizMsgsInTransit :: !( Map - (NodeId, NodeId) - [ ( TestBlockRelayMessage - , TcpMsgForecast - , [TcpMsgForecast] - ) - ] + (NodeId, NodeId) + [ ( TestBlockRelayMessage + , TcpMsgForecast + , [TcpMsgForecast] + ) + ] ) , vizMsgsAtNodeQueue :: !(Map NodeId [TestBlock]) , vizMsgsAtNodeBuffer :: !(Map NodeId [TestBlock]) @@ -424,11 +424,11 @@ relaySimVizRenderModel Cairo.setLineWidth 3 sequence_ [ do - Cairo.arc x y 25 0 (pi * 2) - Cairo.setSourceRGB 0.7 0.7 0.7 - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.stroke + Cairo.arc x y 25 0 (pi * 2) + Cairo.setSourceRGB 0.7 0.7 0.7 + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.stroke | (_node, pos) <- Map.toList vizNodePos , let (Point x y) = simPointToPixel worldDimensions screenSize pos ] @@ -438,18 +438,18 @@ relaySimVizRenderModel Cairo.save sequence_ [ do - Cairo.setSourceRGB r g b - Cairo.arc (x - 10) y' 10 0 (2 * pi) - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.setLineWidth 1 - Cairo.stroke - case nodeMessageText msg of - Nothing -> return () - Just txt -> do - Cairo.moveTo (x - 32) (y' + 5) - Cairo.showText txt - Cairo.newPath + Cairo.setSourceRGB r g b + Cairo.arc (x - 10) y' 10 0 (2 * pi) + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.setLineWidth 1 + Cairo.stroke + case nodeMessageText msg of + Nothing -> return () + Just txt -> do + Cairo.moveTo (x - 32) (y' + 5) + Cairo.showText txt + Cairo.newPath | (node, msgs) <- Map.toList vizMsgsAtNodeQueue , (n, msg) <- zip [1 ..] msgs , let (Point x y) = @@ -462,18 +462,18 @@ relaySimVizRenderModel ] sequence_ [ do - Cairo.setSourceRGB r g b - Cairo.arc (x + 10) y' 10 0 (2 * pi) - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.setLineWidth 1 - Cairo.stroke - case nodeMessageText msg of - Nothing -> return () - Just txt -> do - Cairo.moveTo (x + 22) (y' + 5) - Cairo.showText txt - Cairo.newPath + Cairo.setSourceRGB r g b + Cairo.arc (x + 10) y' 10 0 (2 * pi) + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.setLineWidth 1 + Cairo.stroke + case nodeMessageText msg of + Nothing -> return () + Just txt -> do + Cairo.moveTo (x + 22) (y' + 5) + Cairo.showText txt + Cairo.newPath | (node, msgs) <- Map.toList vizMsgsAtNodeBuffer , (n, msg) <- zip [1 ..] msgs , let (Point x y) = @@ -492,24 +492,24 @@ relaySimVizRenderModel Cairo.setLineWidth 3 sequence_ [ do - Cairo.save - renderPathRoundedRect fromPos toPos 20 - Cairo.setSourceRGB 0.9 0.9 0.9 - Cairo.fillPreserve - Cairo.clip - Cairo.newPath - -- draw all the messages within the clipping region of the link - renderMessagesInFlight - (TcpSimVizConfig ptclMessageColor) - now - fromPos - toPos - msgs - Cairo.restore - -- the draw the link border on top (without clipping) - renderPathRoundedRect fromPos toPos 20 - Cairo.setSourceRGB 0 0 0 - Cairo.stroke + Cairo.save + renderPathRoundedRect fromPos toPos 20 + Cairo.setSourceRGB 0.9 0.9 0.9 + Cairo.fillPreserve + Cairo.clip + Cairo.newPath + -- draw all the messages within the clipping region of the link + renderMessagesInFlight + (TcpSimVizConfig ptclMessageColor) + now + fromPos + toPos + msgs + Cairo.restore + -- the draw the link border on top (without clipping) + renderPathRoundedRect fromPos toPos 20 + Cairo.setSourceRGB 0 0 0 + Cairo.stroke | (fromPos, toPos, msgs) <- linksAndMsgs ] -- draw the message labels on top of the links @@ -550,8 +550,8 @@ relaySimVizRenderModel -- draw lines from labels to messages sequence_ [ do - withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) - withPoint Cairo.lineTo msgTrailingEdge + withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) + withPoint Cairo.lineTo msgTrailingEdge | ((_msgLabel, msgforecast), n) <- zip msgLabels [0 ..] , let (msgTrailingEdge, _msgLeadingEdge) = lineMessageInFlight now fromPos toPos msgforecast @@ -561,9 +561,9 @@ relaySimVizRenderModel Cairo.setSourceRGB 0 0 0 sequence_ [ do - withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) - Cairo.showText msgLabel - Cairo.newPath + withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) + Cairo.showText msgLabel + Cairo.newPath | ((msgLabel, _), n) <- zip msgLabels [0 ..] ] Cairo.restore diff --git a/simulation/src/P2P.hs b/simulation/src/P2P.hs index fa7df59ae..1ad5a1436 100644 --- a/simulation/src/P2P.hs +++ b/simulation/src/P2P.hs @@ -77,8 +77,8 @@ traverseLinks p2pLinks newConn = do tcplinks <- sequence [ do - (aChan, bChan) <- newConn na nb info - return ((na :<- nb), (aChan :<- bChan)) + (aChan, bChan) <- newConn na nb info + return ((na :<- nb), (aChan :<- bChan)) | ((na :<- nb), info) <- Map.toList p2pLinks ] let chansToUpstream = @@ -373,12 +373,12 @@ allPairsMinWeights g edgeWeight vertexWeight = sequence_ [writeArray arr (v, v) 0 | v <- [0 .. n]] sequence_ [ do - w_ik <- readArray arr (i, k) - w_kj <- readArray arr (k, j) - w_ij <- readArray arr (i, j) - let !w_ikj = w_ik + w_kj + vertexWeight k - when (w_ij > w_ikj) $ - writeArray arr (i, j) w_ikj + w_ik <- readArray arr (i, k) + w_kj <- readArray arr (k, j) + w_ij <- readArray arr (i, j) + let !w_ikj = w_ik + w_kj + vertexWeight k + when (w_ij > w_ikj) $ + writeArray arr (i, j) w_ikj | k <- [0 .. n] , i <- [0 .. n] , j <- [0 .. n] diff --git a/simulation/src/PraosProtocol/ExamplesPraosP2P.hs b/simulation/src/PraosProtocol/ExamplesPraosP2P.hs index 7a13a05c0..90bff3ea8 100644 --- a/simulation/src/PraosProtocol/ExamplesPraosP2P.hs +++ b/simulation/src/PraosProtocol/ExamplesPraosP2P.hs @@ -150,11 +150,11 @@ diffusionSampleModel p2pTopography fp = SampleModel initState accum render let stable_chain_hashes = coerce $ map blockHash $ Chain.toNewestFirst stable_chain let entries = [ DiffusionEntry - { hash = coerce hash' - , node_id = coerce i - , created = coerce t - , arrivals = coerce ts - } + { hash = coerce hash' + , node_id = coerce i + , created = coerce t + , arrivals = coerce ts + } | (hash', (_, i, t, ts)) <- Map.toList diffusions ] let latency_per_stake = map (diffusionEntryToLatencyPerStake nnodes) entries diff --git a/simulation/src/PraosProtocol/SimPraosP2P.hs b/simulation/src/PraosProtocol/SimPraosP2P.hs index 3912129cc..82bf42e0c 100644 --- a/simulation/src/PraosProtocol/SimPraosP2P.hs +++ b/simulation/src/PraosProtocol/SimPraosP2P.hs @@ -60,10 +60,10 @@ tracePraosP2P mapM_ (\m -> mapM_ forkIO =<< m) [ praosNode - (nodeTracer nid) - (praosConfig slotConfig nid rng) - (Map.findWithDefault [] nid chansToDownstream) - (Map.findWithDefault [] nid chansToUpstream) + (nodeTracer nid) + (praosConfig slotConfig nid rng) + (Map.findWithDefault [] nid chansToDownstream) + (Map.findWithDefault [] nid chansToUpstream) | (nid, rng) <- zip (Map.keys p2pNodes) diff --git a/simulation/src/PraosProtocol/VizSimBlockFetch.hs b/simulation/src/PraosProtocol/VizSimBlockFetch.hs index 1dfd7a80c..bab1c696e 100644 --- a/simulation/src/PraosProtocol/VizSimBlockFetch.hs +++ b/simulation/src/PraosProtocol/VizSimBlockFetch.hs @@ -83,12 +83,12 @@ data BlockFetchVizState = BlockFetchVizState , vizNodeLinks :: !(Map Link LinkPoints) , vizMsgsInTransit :: !( Map - (NodeId, NodeId) - [ ( BlockFetchMessage BlockBody - , TcpMsgForecast - , [TcpMsgForecast] - ) - ] + (NodeId, NodeId) + [ ( BlockFetchMessage BlockBody + , TcpMsgForecast + , [TcpMsgForecast] + ) + ] ) , vizMsgsAtNodeQueue :: !(Map NodeId [BlockHeader]) , vizMsgsAtNodeBuffer :: !(Map NodeId [BlockHeader]) @@ -306,11 +306,11 @@ relaySimVizRenderModel Cairo.setLineWidth 3 sequence_ [ do - Cairo.arc x y 25 0 (pi * 2) - Cairo.setSourceRGB 0.7 0.7 0.7 - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.stroke + Cairo.arc x y 25 0 (pi * 2) + Cairo.setSourceRGB 0.7 0.7 0.7 + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.stroke | (_node, pos) <- Map.toList vizNodePos , let (Point x y) = simPointToPixel worldDimensions screenSize pos ] @@ -322,24 +322,24 @@ relaySimVizRenderModel Cairo.setLineWidth 3 sequence_ [ do - Cairo.save - renderPathRoundedRect fromPos toPos 20 - Cairo.setSourceRGB 0.9 0.9 0.9 - Cairo.fillPreserve - Cairo.clip - Cairo.newPath - -- draw all the messages within the clipping region of the link - renderMessagesInFlight - (TcpSimVizConfig ptclMessageColor) - now - fromPos - toPos - msgs - Cairo.restore - -- the draw the link border on top (without clipping) - renderPathRoundedRect fromPos toPos 20 - Cairo.setSourceRGB 0 0 0 - Cairo.stroke + Cairo.save + renderPathRoundedRect fromPos toPos 20 + Cairo.setSourceRGB 0.9 0.9 0.9 + Cairo.fillPreserve + Cairo.clip + Cairo.newPath + -- draw all the messages within the clipping region of the link + renderMessagesInFlight + (TcpSimVizConfig ptclMessageColor) + now + fromPos + toPos + msgs + Cairo.restore + -- the draw the link border on top (without clipping) + renderPathRoundedRect fromPos toPos 20 + Cairo.setSourceRGB 0 0 0 + Cairo.stroke | (fromPos, toPos, msgs) <- linksAndMsgs ] -- draw the message labels on top of the links @@ -380,8 +380,8 @@ relaySimVizRenderModel -- draw lines from labels to messages sequence_ [ do - withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) - withPoint Cairo.lineTo msgTrailingEdge + withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) + withPoint Cairo.lineTo msgTrailingEdge | ((_msgLabel, msgforecast), n) <- zip msgLabels [0 ..] , let (msgTrailingEdge, _msgLeadingEdge) = lineMessageInFlight now fromPos toPos msgforecast @@ -391,9 +391,9 @@ relaySimVizRenderModel Cairo.setSourceRGB 0 0 0 sequence_ [ do - withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) - Cairo.showText msgLabel - Cairo.newPath + withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) + Cairo.showText msgLabel + Cairo.newPath | ((msgLabel, _), n) <- zip msgLabels [0 ..] ] Cairo.restore diff --git a/simulation/src/PraosProtocol/VizSimChainSync.hs b/simulation/src/PraosProtocol/VizSimChainSync.hs index b8351fa8f..dc0e566d9 100644 --- a/simulation/src/PraosProtocol/VizSimChainSync.hs +++ b/simulation/src/PraosProtocol/VizSimChainSync.hs @@ -89,12 +89,12 @@ data ChainSyncVizState = ChainSyncVizState , vizNodeLinks :: !(Map Link LinkPoints) , vizMsgsInTransit :: !( Map - (NodeId, NodeId) - [ ( ChainSyncMessage - , TcpMsgForecast - , [TcpMsgForecast] - ) - ] + (NodeId, NodeId) + [ ( ChainSyncMessage + , TcpMsgForecast + , [TcpMsgForecast] + ) + ] ) , vizMsgsAtNodeQueue :: !(Map NodeId [BlockHeader]) , vizMsgsAtNodeBuffer :: !(Map NodeId [BlockHeader]) @@ -387,11 +387,11 @@ relaySimVizRenderModel Cairo.setLineWidth 3 sequence_ [ do - Cairo.arc x y 25 0 (pi * 2) - Cairo.setSourceRGB 0.7 0.7 0.7 - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.stroke + Cairo.arc x y 25 0 (pi * 2) + Cairo.setSourceRGB 0.7 0.7 0.7 + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.stroke | (_node, pos) <- Map.toList vizNodePos , let (Point x y) = simPointToPixel worldDimensions screenSize pos ] @@ -401,18 +401,18 @@ relaySimVizRenderModel Cairo.save sequence_ [ do - Cairo.setSourceRGB r g b - Cairo.arc (x - 10) y' 10 0 (2 * pi) - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.setLineWidth 1 - Cairo.stroke - case nodeMessageText msg of - Nothing -> return () - Just txt -> do - Cairo.moveTo (x - 32) (y' + 5) - Cairo.showText txt - Cairo.newPath + Cairo.setSourceRGB r g b + Cairo.arc (x - 10) y' 10 0 (2 * pi) + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.setLineWidth 1 + Cairo.stroke + case nodeMessageText msg of + Nothing -> return () + Just txt -> do + Cairo.moveTo (x - 32) (y' + 5) + Cairo.showText txt + Cairo.newPath | (node, msgs) <- Map.toList vizMsgsAtNodeQueue , (n, msg) <- zip [1 ..] msgs , let (Point x y) = @@ -425,18 +425,18 @@ relaySimVizRenderModel ] sequence_ [ do - Cairo.setSourceRGB r g b - Cairo.arc (x + 10) y' 10 0 (2 * pi) - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.setLineWidth 1 - Cairo.stroke - case nodeMessageText msg of - Nothing -> return () - Just txt -> do - Cairo.moveTo (x + 22) (y' + 5) - Cairo.showText txt - Cairo.newPath + Cairo.setSourceRGB r g b + Cairo.arc (x + 10) y' 10 0 (2 * pi) + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.setLineWidth 1 + Cairo.stroke + case nodeMessageText msg of + Nothing -> return () + Just txt -> do + Cairo.moveTo (x + 22) (y' + 5) + Cairo.showText txt + Cairo.newPath | (node, msgs) <- Map.toList vizMsgsAtNodeBuffer , (n, msg) <- zip [1 ..] msgs , let (Point x y) = @@ -455,24 +455,24 @@ relaySimVizRenderModel Cairo.setLineWidth 3 sequence_ [ do - Cairo.save - renderPathRoundedRect fromPos toPos 20 - Cairo.setSourceRGB 0.9 0.9 0.9 - Cairo.fillPreserve - Cairo.clip - Cairo.newPath - -- draw all the messages within the clipping region of the link - renderMessagesInFlight - (TcpSimVizConfig ptclMessageColor) - now - fromPos - toPos - msgs - Cairo.restore - -- the draw the link border on top (without clipping) - renderPathRoundedRect fromPos toPos 20 - Cairo.setSourceRGB 0 0 0 - Cairo.stroke + Cairo.save + renderPathRoundedRect fromPos toPos 20 + Cairo.setSourceRGB 0.9 0.9 0.9 + Cairo.fillPreserve + Cairo.clip + Cairo.newPath + -- draw all the messages within the clipping region of the link + renderMessagesInFlight + (TcpSimVizConfig ptclMessageColor) + now + fromPos + toPos + msgs + Cairo.restore + -- the draw the link border on top (without clipping) + renderPathRoundedRect fromPos toPos 20 + Cairo.setSourceRGB 0 0 0 + Cairo.stroke | (fromPos, toPos, msgs) <- linksAndMsgs ] -- draw the message labels on top of the links @@ -513,8 +513,8 @@ relaySimVizRenderModel -- draw lines from labels to messages sequence_ [ do - withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) - withPoint Cairo.lineTo msgTrailingEdge + withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) + withPoint Cairo.lineTo msgTrailingEdge | ((_msgLabel, msgforecast), n) <- zip msgLabels [0 ..] , let (msgTrailingEdge, _msgLeadingEdge) = lineMessageInFlight now fromPos toPos msgforecast @@ -524,9 +524,9 @@ relaySimVizRenderModel Cairo.setSourceRGB 0 0 0 sequence_ [ do - withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) - Cairo.showText msgLabel - Cairo.newPath + withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) + Cairo.showText msgLabel + Cairo.newPath | ((msgLabel, _), n) <- zip msgLabels [0 ..] ] Cairo.restore diff --git a/simulation/src/PraosProtocol/VizSimPraos.hs b/simulation/src/PraosProtocol/VizSimPraos.hs index 41bd26cf6..992b02bf4 100644 --- a/simulation/src/PraosProtocol/VizSimPraos.hs +++ b/simulation/src/PraosProtocol/VizSimPraos.hs @@ -90,12 +90,12 @@ data PraosSimVizState = PraosSimVizState , vizNodeLinks :: !(Map Link LinkPoints) , vizMsgsInTransit :: !( Map - (NodeId, NodeId) - [ ( PraosMessage BlockBody - , TcpMsgForecast - , [TcpMsgForecast] - ) - ] + (NodeId, NodeId) + [ ( PraosMessage BlockBody + , TcpMsgForecast + , [TcpMsgForecast] + ) + ] ) , vizNodeTip :: !(Map NodeId FullTip) , -- the Buffer and Queue names are legacy from VizSimRelay. @@ -405,11 +405,11 @@ praosSimVizRenderModel Cairo.setLineWidth 3 sequence_ [ do - Cairo.arc x y 25 0 (pi * 2) - Cairo.setSourceRGB 0.7 0.7 0.7 - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.stroke + Cairo.arc x y 25 0 (pi * 2) + Cairo.setSourceRGB 0.7 0.7 0.7 + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.stroke | (_node, pos) <- Map.toList vizNodePos , let (Point x y) = simPointToPixel worldDimensions screenSize pos ] @@ -421,24 +421,24 @@ praosSimVizRenderModel Cairo.setLineWidth 3 sequence_ [ do - Cairo.save - renderPathRoundedRect fromPos toPos 20 - Cairo.setSourceRGB 0.9 0.9 0.9 - Cairo.fillPreserve - Cairo.clip - Cairo.newPath - -- draw all the messages within the clipping region of the link - renderMessagesInFlight - (TcpSimVizConfig $ either chainSyncMessageColor blockFetchMessageColor . coerce) - now - fromPos - toPos - msgs - Cairo.restore - -- the draw the link border on top (without clipping) - renderPathRoundedRect fromPos toPos 20 - Cairo.setSourceRGB 0 0 0 - Cairo.stroke + Cairo.save + renderPathRoundedRect fromPos toPos 20 + Cairo.setSourceRGB 0.9 0.9 0.9 + Cairo.fillPreserve + Cairo.clip + Cairo.newPath + -- draw all the messages within the clipping region of the link + renderMessagesInFlight + (TcpSimVizConfig $ either chainSyncMessageColor blockFetchMessageColor . coerce) + now + fromPos + toPos + msgs + Cairo.restore + -- the draw the link border on top (without clipping) + renderPathRoundedRect fromPos toPos 20 + Cairo.setSourceRGB 0 0 0 + Cairo.stroke | (fromPos, toPos, msgs) <- linksAndMsgs ] -- draw the message labels on top of the links @@ -479,8 +479,8 @@ praosSimVizRenderModel -- draw lines from labels to messages sequence_ [ do - withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) - withPoint Cairo.lineTo msgTrailingEdge + withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) + withPoint Cairo.lineTo msgTrailingEdge | ((_msgLabel, msgforecast), n) <- zip msgLabels [0 ..] , let (msgTrailingEdge, _msgLeadingEdge) = lineMessageInFlight now fromPos toPos msgforecast @@ -490,9 +490,9 @@ praosSimVizRenderModel Cairo.setSourceRGB 0 0 0 sequence_ [ do - withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) - Cairo.showText msgLabel - Cairo.newPath + withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) + Cairo.showText msgLabel + Cairo.newPath | ((msgLabel, _), n) <- zip msgLabels [0 ..] ] Cairo.restore diff --git a/simulation/src/PraosProtocol/VizSimPraosP2P.hs b/simulation/src/PraosProtocol/VizSimPraosP2P.hs index 54af30ac0..df23622e1 100644 --- a/simulation/src/PraosProtocol/VizSimPraosP2P.hs +++ b/simulation/src/PraosProtocol/VizSimPraosP2P.hs @@ -96,30 +96,30 @@ praosP2PSimVizRenderModel Cairo.setFontSize 10 sequence_ [ do - Cairo.arc x y 10 0 (pi * 2) - Cairo.setSourceRGB r g b - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.stroke - {- - -- Label with message counts, processing and buffer - let qlabel = show nqmsgs ++ "," ++ show rqmsgs ++ "," ++ show tqmsgs - Cairo.moveTo (x-6) (y-5) - Cairo.setSourceRGB 1 1 1 -- white backdrop text for readabilty - Cairo.showText qlabel -- on dark backgrounds - Cairo.moveTo (x-7) (y-4) - Cairo.setSourceRGB 0 0 0 - Cairo.showText qlabel + Cairo.arc x y 10 0 (pi * 2) + Cairo.setSourceRGB r g b + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.stroke + {- + -- Label with message counts, processing and buffer + let qlabel = show nqmsgs ++ "," ++ show rqmsgs ++ "," ++ show tqmsgs + Cairo.moveTo (x-6) (y-5) + Cairo.setSourceRGB 1 1 1 -- white backdrop text for readabilty + Cairo.showText qlabel -- on dark backgrounds + Cairo.moveTo (x-7) (y-4) + Cairo.setSourceRGB 0 0 0 + Cairo.showText qlabel - let blabel = show nbmsgs ++ "," ++ show rbmsgs ++ "," ++ show tbmsgs - Cairo.moveTo (x-6) (y+10) - Cairo.setSourceRGB 1 1 1 -- white backdrop text for readabilty - Cairo.showText blabel -- on dark backgrounds - Cairo.moveTo (x-7) (y+9) - Cairo.setSourceRGB 0 0 0 - Cairo.showText blabel - -} - Cairo.newPath + let blabel = show nbmsgs ++ "," ++ show rbmsgs ++ "," ++ show tbmsgs + Cairo.moveTo (x-6) (y+10) + Cairo.setSourceRGB 1 1 1 -- white backdrop text for readabilty + Cairo.showText blabel -- on dark backgrounds + Cairo.moveTo (x-7) (y+9) + Cairo.setSourceRGB 0 0 0 + Cairo.showText blabel + -} + Cairo.newPath | (node, pos) <- Map.toList vizNodePos , let Point x y = toScreenPoint pos -- qmsgs = fromMaybe [] (Map.lookup node vizMsgsAtNodeQueue) @@ -145,84 +145,84 @@ praosP2PSimVizRenderModel Cairo.save sequence_ [ case classifyInFlightMsgs msgs of - -- We don't even draw links that are inactive - MsgsInFlightNone -> return () - -- Similarly, all links will have boring control messages - -- it'd be too much details - MsgsInFlightControl -> return () - -- We draw with a dotted line - MsgsInFlightNonBallistic -> - case catMaybes [ptclMessageColor msg | (msg, _, _) <- msgs] of - [] -> return () - ((r, g, b) : _) -> do - Cairo.setSourceRGB r g b - Cairo.setLineWidth 1 - Cairo.setDash [10, 5] 0 - case vizNodeLinks !!! (fromNode, toNode) of - LinkPointsNoWrap fromPos toPos -> do - withPoint Cairo.moveTo (toScreenPoint fromPos) - withPoint Cairo.lineTo (toScreenPoint toPos) - Cairo.stroke - LinkPointsWrap fromPos toPos fromPos' toPos' -> do - withPoint Cairo.moveTo (toScreenPoint fromPos) - withPoint Cairo.lineTo (toScreenPoint toPos) - Cairo.stroke - withPoint Cairo.moveTo (toScreenPoint fromPos') - withPoint Cairo.lineTo (toScreenPoint toPos') - Cairo.stroke + -- We don't even draw links that are inactive + MsgsInFlightNone -> return () + -- Similarly, all links will have boring control messages + -- it'd be too much details + MsgsInFlightControl -> return () + -- We draw with a dotted line + MsgsInFlightNonBallistic -> + case catMaybes [ptclMessageColor msg | (msg, _, _) <- msgs] of + [] -> return () + ((r, g, b) : _) -> do + Cairo.setSourceRGB r g b + Cairo.setLineWidth 1 + Cairo.setDash [10, 5] 0 + case vizNodeLinks !!! (fromNode, toNode) of + LinkPointsNoWrap fromPos toPos -> do + withPoint Cairo.moveTo (toScreenPoint fromPos) + withPoint Cairo.lineTo (toScreenPoint toPos) + Cairo.stroke + LinkPointsWrap fromPos toPos fromPos' toPos' -> do + withPoint Cairo.moveTo (toScreenPoint fromPos) + withPoint Cairo.lineTo (toScreenPoint toPos) + Cairo.stroke + withPoint Cairo.moveTo (toScreenPoint fromPos') + withPoint Cairo.lineTo (toScreenPoint toPos') + Cairo.stroke - -- We draw with a full line - MsgsInFlightBallistic -> - case catMaybes [ptclMessageColor msg | (msg, _, _) <- msgs] of - [] -> return () - ((r, g, b) : _) -> do - Cairo.setSourceRGB r g b - Cairo.setDash [] 0 - Cairo.setLineWidth 2 - case vizNodeLinks !!! (fromNode, toNode) of - LinkPointsNoWrap fromPos toPos -> do - withPoint Cairo.moveTo (toScreenPoint fromPos) - withPoint Cairo.lineTo (toScreenPoint toPos) - Cairo.stroke - LinkPointsWrap fromPos toPos fromPos' toPos' -> do - withPoint Cairo.moveTo (toScreenPoint fromPos) - withPoint Cairo.lineTo (toScreenPoint toPos) - Cairo.stroke - withPoint Cairo.moveTo (toScreenPoint fromPos') - withPoint Cairo.lineTo (toScreenPoint toPos') - Cairo.stroke + -- We draw with a full line + MsgsInFlightBallistic -> + case catMaybes [ptclMessageColor msg | (msg, _, _) <- msgs] of + [] -> return () + ((r, g, b) : _) -> do + Cairo.setSourceRGB r g b + Cairo.setDash [] 0 + Cairo.setLineWidth 2 + case vizNodeLinks !!! (fromNode, toNode) of + LinkPointsNoWrap fromPos toPos -> do + withPoint Cairo.moveTo (toScreenPoint fromPos) + withPoint Cairo.lineTo (toScreenPoint toPos) + Cairo.stroke + LinkPointsWrap fromPos toPos fromPos' toPos' -> do + withPoint Cairo.moveTo (toScreenPoint fromPos) + withPoint Cairo.lineTo (toScreenPoint toPos) + Cairo.stroke + withPoint Cairo.moveTo (toScreenPoint fromPos') + withPoint Cairo.lineTo (toScreenPoint toPos') + Cairo.stroke | ((fromNode, toNode), msgs) <- Map.toList vizMsgsInTransit ] Cairo.restore -- draw the messages in flight on top sequence_ [ case vizNodeLinks !!! (fromNode, toNode) of - LinkPointsNoWrap fromPos toPos -> do - let (msgTrailingEdge, _msgLeadingEdge) = - lineMessageInFlight now fromPos toPos msgforecast - Point x y = toScreenPoint msgTrailingEdge - Cairo.rectangle (x - 8) (y - 8) 16 16 - Cairo.setSourceRGB r g b - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.stroke - LinkPointsWrap fromPos toPos fromPos' toPos' -> do - let (msgTrailingEdge, _msgLeadingEdge) = - lineMessageInFlight now fromPos toPos msgforecast - Point x y = toScreenPoint msgTrailingEdge - Cairo.rectangle (x - 8) (y - 8) 16 16 - Cairo.setSourceRGB r g b - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.stroke - let (msgTrailingEdge', _msgLeadingEdge) = - lineMessageInFlight now fromPos' toPos' msgforecast - Point x' y' = toScreenPoint msgTrailingEdge' - Cairo.rectangle (x' - 8) (y' - 8) 16 16 - Cairo.setSourceRGB r g b - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.stroke + LinkPointsNoWrap fromPos toPos -> do + let (msgTrailingEdge, _msgLeadingEdge) = + lineMessageInFlight now fromPos toPos msgforecast + Point x y = toScreenPoint msgTrailingEdge + Cairo.rectangle (x - 8) (y - 8) 16 16 + Cairo.setSourceRGB r g b + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.stroke + LinkPointsWrap fromPos toPos fromPos' toPos' -> do + let (msgTrailingEdge, _msgLeadingEdge) = + lineMessageInFlight now fromPos toPos msgforecast + Point x y = toScreenPoint msgTrailingEdge + Cairo.rectangle (x - 8) (y - 8) 16 16 + Cairo.setSourceRGB r g b + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.stroke + let (msgTrailingEdge', _msgLeadingEdge) = + lineMessageInFlight now fromPos' toPos' msgforecast + Point x' y' = toScreenPoint msgTrailingEdge' + Cairo.rectangle (x' - 8) (y' - 8) 16 16 + Cairo.setSourceRGB r g b + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.stroke | ((fromNode, toNode), msgs) <- Map.toList vizMsgsInTransit , (msg, msgforecast, _msgforecasts) <- msgs , now >= msgSendTrailingEdge msgforecast @@ -279,12 +279,12 @@ chartDiffusionLatency PraosP2PSimVizConfig{nodeMessageColor} = \_ _ ( SimVizModel - _ - PraosSimVizState - { vizNodePos - , vizMsgsDiffusionLatency - } - ) -> + _ + PraosSimVizState + { vizNodePos + , vizMsgsDiffusionLatency + } + ) -> (Chart.def :: Chart.Layout DiffTime Chart.Percent) { Chart._layout_title = "Diffusion latency" , Chart._layout_title_style = Chart.def{Chart._font_size = 15} @@ -300,14 +300,14 @@ chartDiffusionLatency PraosP2PSimVizConfig{nodeMessageColor} = } , Chart._layout_plots = [ Chart.toPlot $ - Chart.def - { Chart._plot_lines_values = [timeseries] - , Chart._plot_lines_style = - let (r, g, b) = nodeMessageColor blk - in Chart.def - { Chart._line_color = Chart.opaque (Colour.sRGB r g b) - } - } + Chart.def + { Chart._plot_lines_values = [timeseries] + , Chart._plot_lines_style = + let (r, g, b) = nodeMessageColor blk + in Chart.def + { Chart._line_color = Chart.opaque (Colour.sRGB r g b) + } + } | let nnodes = Map.size vizNodePos , (blk, _nid, created, arrivals) <- Map.elems vizMsgsDiffusionLatency , let timeseries = @@ -347,14 +347,14 @@ chartDiffusionImperfection } , Chart._layout_plots = [ Chart.toPlot $ - Chart.def - { Chart._plot_lines_values = [timeseries] - , Chart._plot_lines_style = - let (r, g, b) = nodeMessageColor blk - in Chart.def - { Chart._line_color = Chart.opaque (Colour.sRGB r g b) - } - } + Chart.def + { Chart._plot_lines_values = [timeseries] + , Chart._plot_lines_style = + let (r, g, b) = nodeMessageColor blk + in Chart.def + { Chart._line_color = Chart.opaque (Colour.sRGB r g b) + } + } | (blk, nid, created, arrivals) <- Map.elems vizMsgsDiffusionLatency , let timeseries = [ (latencyActual, imperfection) @@ -385,12 +385,12 @@ chartBandwidth = \_ _ ( SimVizModel - _ - PraosSimVizState - { vizMsgsAtNodeRecentQueue - , vizMsgsAtNodeRecentBuffer - } - ) -> + _ + PraosSimVizState + { vizMsgsAtNodeRecentQueue + , vizMsgsAtNodeRecentBuffer + } + ) -> (Chart.def :: Chart.Layout Double Double) { Chart._layout_title = "Distribution of block frequency" , Chart._layout_title_style = Chart.def{Chart._font_size = 15} @@ -408,21 +408,21 @@ chartBandwidth = } , Chart._layout_plots = [ bandwidthHistPlot - "CPU (block validation completion)" - Chart.red - ( map - ((fromIntegral :: Int -> Double) . recentRate) - (Map.elems vizMsgsAtNodeRecentBuffer) - ) + "CPU (block validation completion)" + Chart.red + ( map + ((fromIntegral :: Int -> Double) . recentRate) + (Map.elems vizMsgsAtNodeRecentBuffer) + ) | not (Map.null vizMsgsAtNodeRecentBuffer) ] ++ [ bandwidthHistPlot - "Network (block arrival)" - Chart.blue - ( map - ((fromIntegral :: Int -> Double) . recentRate) - (Map.elems vizMsgsAtNodeRecentQueue) - ) + "Network (block arrival)" + Chart.blue + ( map + ((fromIntegral :: Int -> Double) . recentRate) + (Map.elems vizMsgsAtNodeRecentQueue) + ) | not (Map.null vizMsgsAtNodeRecentQueue) ] } @@ -455,11 +455,11 @@ chartLinkUtilisation = \_ _ ( SimVizModel - _ - PraosSimVizState - { vizMsgsInTransit - } - ) -> + _ + PraosSimVizState + { vizMsgsInTransit + } + ) -> let counts :: UArray MsgsInFlightClassification Int counts = accumArray diff --git a/simulation/src/RelayProtocol.hs b/simulation/src/RelayProtocol.hs index 5102f0431..cc1f8f7df 100644 --- a/simulation/src/RelayProtocol.hs +++ b/simulation/src/RelayProtocol.hs @@ -317,8 +317,8 @@ relayClient -- non-recent, but recent ones still oldest to newest). sequence_ [ do - writeChan chan (MsgReqBlock blkid) - writeChan chan MsgReqBlockIdsNonBlocking + writeChan chan (MsgReqBlock blkid) + writeChan chan MsgReqBlockIdsNonBlocking | (blkid, _ttl) <- sortBy (compare `on` snd) newBlkIds ] idle (nreplies - 1 + 2 * length newBlkIds) diff --git a/simulation/src/SimRelayP2P.hs b/simulation/src/SimRelayP2P.hs index 2c545f905..1bf145f2a 100644 --- a/simulation/src/SimRelayP2P.hs +++ b/simulation/src/SimRelayP2P.hs @@ -56,11 +56,11 @@ traceRelayP2P runConcurrently $ sequenceA_ [ Concurrently $ - relayNode - (nodeTracer nid) - (relayConfig rng) - (Map.findWithDefault [] nid chansToDownstream) - (Map.findWithDefault [] nid chansToUpstream) + relayNode + (nodeTracer nid) + (relayConfig rng) + (Map.findWithDefault [] nid chansToDownstream) + (Map.findWithDefault [] nid chansToUpstream) | (nid, rng) <- zip (Map.keys p2pNodes) diff --git a/simulation/src/SimTCPLinks.hs b/simulation/src/SimTCPLinks.hs index 934671d0f..a6e55938d 100644 --- a/simulation/src/SimTCPLinks.hs +++ b/simulation/src/SimTCPLinks.hs @@ -109,9 +109,9 @@ generatorNode tracer (UniformTrafficPattern nmsgs msgsz mdelay) chan = do ] sequence_ [ do - writeChan chan msg - traceWith tracer (MsgDepart msg) - maybe (return ()) threadDelay mdelay + writeChan chan msg + traceWith tracer (MsgDepart msg) + maybe (return ()) threadDelay mdelay | msg <- map (flip TestMessage msgsz) [0 .. nmsgs - 1] ] diff --git a/simulation/src/Viz.hs b/simulation/src/Viz.hs index 45aac94ae..6abfefe18 100644 --- a/simulation/src/Viz.hs +++ b/simulation/src/Viz.hs @@ -175,8 +175,8 @@ layoutTiles allocToplevel = takeUpTo h (map (snd . reqSize . Tree.rootLabel) lps) | otherwise = [ if expand - then rh' + dh + (if i < dhrem then 1 else 0) - else rh' + then rh' + dh + (if i < dhrem then 1 else 0) + else rh' | let ( nexpand , iprops ) = enumerateExpanding (map rootLabel lps) @@ -204,8 +204,8 @@ layoutTiles allocToplevel = takeUpTo w (map (fst . reqSize . Tree.rootLabel) lps) | otherwise = [ if expand - then rw' + dw + (if i < dwrem then 1 else 0) - else rw' + then rw' + dw + (if i < dwrem then 1 else 0) + else rw' | let ( nexpand , iprops ) = enumerateExpanding (map rootLabel lps) diff --git a/simulation/src/VizSimRelay.hs b/simulation/src/VizSimRelay.hs index 8b4048101..c6c29dcba 100644 --- a/simulation/src/VizSimRelay.hs +++ b/simulation/src/VizSimRelay.hs @@ -42,12 +42,12 @@ data RelaySimVizState = RelaySimVizState , vizNodeLinks :: !(Map Link LinkPoints) , vizMsgsInTransit :: !( Map - (NodeId, NodeId) - [ ( TestBlockRelayMessage - , TcpMsgForecast - , [TcpMsgForecast] - ) - ] + (NodeId, NodeId) + [ ( TestBlockRelayMessage + , TcpMsgForecast + , [TcpMsgForecast] + ) + ] ) , vizMsgsAtNodeQueue :: !(Map NodeId [TestBlock]) , vizMsgsAtNodeBuffer :: !(Map NodeId [TestBlock]) @@ -339,11 +339,11 @@ relaySimVizRenderModel Cairo.setLineWidth 3 sequence_ [ do - Cairo.arc x y 25 0 (pi * 2) - Cairo.setSourceRGB 0.7 0.7 0.7 - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.stroke + Cairo.arc x y 25 0 (pi * 2) + Cairo.setSourceRGB 0.7 0.7 0.7 + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.stroke | (_node, pos) <- Map.toList vizNodePos , let (Point x y) = simPointToPixel worldDimensions screenSize pos ] @@ -353,18 +353,18 @@ relaySimVizRenderModel Cairo.save sequence_ [ do - Cairo.setSourceRGB r g b - Cairo.arc (x - 10) y' 10 0 (2 * pi) - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.setLineWidth 1 - Cairo.stroke - case nodeMessageText msg of - Nothing -> return () - Just txt -> do - Cairo.moveTo (x - 32) (y' + 5) - Cairo.showText txt - Cairo.newPath + Cairo.setSourceRGB r g b + Cairo.arc (x - 10) y' 10 0 (2 * pi) + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.setLineWidth 1 + Cairo.stroke + case nodeMessageText msg of + Nothing -> return () + Just txt -> do + Cairo.moveTo (x - 32) (y' + 5) + Cairo.showText txt + Cairo.newPath | (node, msgs) <- Map.toList vizMsgsAtNodeQueue , (n, msg) <- zip [1 ..] msgs , let (Point x y) = @@ -377,18 +377,18 @@ relaySimVizRenderModel ] sequence_ [ do - Cairo.setSourceRGB r g b - Cairo.arc (x + 10) y' 10 0 (2 * pi) - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.setLineWidth 1 - Cairo.stroke - case nodeMessageText msg of - Nothing -> return () - Just txt -> do - Cairo.moveTo (x + 22) (y' + 5) - Cairo.showText txt - Cairo.newPath + Cairo.setSourceRGB r g b + Cairo.arc (x + 10) y' 10 0 (2 * pi) + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.setLineWidth 1 + Cairo.stroke + case nodeMessageText msg of + Nothing -> return () + Just txt -> do + Cairo.moveTo (x + 22) (y' + 5) + Cairo.showText txt + Cairo.newPath | (node, msgs) <- Map.toList vizMsgsAtNodeBuffer , (n, msg) <- zip [1 ..] msgs , let (Point x y) = @@ -407,24 +407,24 @@ relaySimVizRenderModel Cairo.setLineWidth 3 sequence_ [ do - Cairo.save - renderPathRoundedRect fromPos toPos 20 - Cairo.setSourceRGB 0.9 0.9 0.9 - Cairo.fillPreserve - Cairo.clip - Cairo.newPath - -- draw all the messages within the clipping region of the link - renderMessagesInFlight - (TcpSimVizConfig ptclMessageColor) - now - fromPos - toPos - msgs - Cairo.restore - -- the draw the link border on top (without clipping) - renderPathRoundedRect fromPos toPos 20 - Cairo.setSourceRGB 0 0 0 - Cairo.stroke + Cairo.save + renderPathRoundedRect fromPos toPos 20 + Cairo.setSourceRGB 0.9 0.9 0.9 + Cairo.fillPreserve + Cairo.clip + Cairo.newPath + -- draw all the messages within the clipping region of the link + renderMessagesInFlight + (TcpSimVizConfig ptclMessageColor) + now + fromPos + toPos + msgs + Cairo.restore + -- the draw the link border on top (without clipping) + renderPathRoundedRect fromPos toPos 20 + Cairo.setSourceRGB 0 0 0 + Cairo.stroke | (fromPos, toPos, msgs) <- linksAndMsgs ] -- draw the message labels on top of the links @@ -465,8 +465,8 @@ relaySimVizRenderModel -- draw lines from labels to messages sequence_ [ do - withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) - withPoint Cairo.lineTo msgTrailingEdge + withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) + withPoint Cairo.lineTo msgTrailingEdge | ((_msgLabel, msgforecast), n) <- zip msgLabels [0 ..] , let (msgTrailingEdge, _msgLeadingEdge) = lineMessageInFlight now fromPos toPos msgforecast @@ -476,9 +476,9 @@ relaySimVizRenderModel Cairo.setSourceRGB 0 0 0 sequence_ [ do - withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) - Cairo.showText msgLabel - Cairo.newPath + withPoint Cairo.moveTo (labelsOrigin `addP` Vector 0 (n * 10)) + Cairo.showText msgLabel + Cairo.newPath | ((msgLabel, _), n) <- zip msgLabels [0 ..] ] Cairo.restore diff --git a/simulation/src/VizSimRelayP2P.hs b/simulation/src/VizSimRelayP2P.hs index 342f8a4af..f1feade5c 100644 --- a/simulation/src/VizSimRelayP2P.hs +++ b/simulation/src/VizSimRelayP2P.hs @@ -95,30 +95,30 @@ relayP2PSimVizRenderModel Cairo.setFontSize 10 sequence_ [ do - Cairo.arc x y 10 0 (pi * 2) - Cairo.setSourceRGB r g b - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.stroke - {- - -- Label with message counts, processing and buffer - let qlabel = show nqmsgs ++ "," ++ show rqmsgs ++ "," ++ show tqmsgs - Cairo.moveTo (x-6) (y-5) - Cairo.setSourceRGB 1 1 1 -- white backdrop text for readabilty - Cairo.showText qlabel -- on dark backgrounds - Cairo.moveTo (x-7) (y-4) - Cairo.setSourceRGB 0 0 0 - Cairo.showText qlabel + Cairo.arc x y 10 0 (pi * 2) + Cairo.setSourceRGB r g b + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.stroke + {- + -- Label with message counts, processing and buffer + let qlabel = show nqmsgs ++ "," ++ show rqmsgs ++ "," ++ show tqmsgs + Cairo.moveTo (x-6) (y-5) + Cairo.setSourceRGB 1 1 1 -- white backdrop text for readabilty + Cairo.showText qlabel -- on dark backgrounds + Cairo.moveTo (x-7) (y-4) + Cairo.setSourceRGB 0 0 0 + Cairo.showText qlabel - let blabel = show nbmsgs ++ "," ++ show rbmsgs ++ "," ++ show tbmsgs - Cairo.moveTo (x-6) (y+10) - Cairo.setSourceRGB 1 1 1 -- white backdrop text for readabilty - Cairo.showText blabel -- on dark backgrounds - Cairo.moveTo (x-7) (y+9) - Cairo.setSourceRGB 0 0 0 - Cairo.showText blabel - -} - Cairo.newPath + let blabel = show nbmsgs ++ "," ++ show rbmsgs ++ "," ++ show tbmsgs + Cairo.moveTo (x-6) (y+10) + Cairo.setSourceRGB 1 1 1 -- white backdrop text for readabilty + Cairo.showText blabel -- on dark backgrounds + Cairo.moveTo (x-7) (y+9) + Cairo.setSourceRGB 0 0 0 + Cairo.showText blabel + -} + Cairo.newPath | (node, pos) <- Map.toList vizNodePos , let Point x y = toScreenPoint pos qmsgs = fromMaybe [] (Map.lookup node vizMsgsAtNodeQueue) @@ -144,84 +144,84 @@ relayP2PSimVizRenderModel Cairo.save sequence_ [ case classifyInFlightMsgs msgs of - -- We don't even draw links that are inactive - MsgsInFlightNone -> return () - -- Similarly, all links will have boring control messages - -- it'd be too much details - MsgsInFlightControl -> return () - -- We draw with a dotted line - MsgsInFlightNonBallistic -> - case catMaybes [ptclMessageColor msg | (msg, _, _) <- msgs] of - [] -> return () - ((r, g, b) : _) -> do - Cairo.setSourceRGB r g b - Cairo.setLineWidth 1 - Cairo.setDash [10, 5] 0 - case vizNodeLinks !!! (fromNode, toNode) of - LinkPointsNoWrap fromPos toPos -> do - withPoint Cairo.moveTo (toScreenPoint fromPos) - withPoint Cairo.lineTo (toScreenPoint toPos) - Cairo.stroke - LinkPointsWrap fromPos toPos fromPos' toPos' -> do - withPoint Cairo.moveTo (toScreenPoint fromPos) - withPoint Cairo.lineTo (toScreenPoint toPos) - Cairo.stroke - withPoint Cairo.moveTo (toScreenPoint fromPos') - withPoint Cairo.lineTo (toScreenPoint toPos') - Cairo.stroke + -- We don't even draw links that are inactive + MsgsInFlightNone -> return () + -- Similarly, all links will have boring control messages + -- it'd be too much details + MsgsInFlightControl -> return () + -- We draw with a dotted line + MsgsInFlightNonBallistic -> + case catMaybes [ptclMessageColor msg | (msg, _, _) <- msgs] of + [] -> return () + ((r, g, b) : _) -> do + Cairo.setSourceRGB r g b + Cairo.setLineWidth 1 + Cairo.setDash [10, 5] 0 + case vizNodeLinks !!! (fromNode, toNode) of + LinkPointsNoWrap fromPos toPos -> do + withPoint Cairo.moveTo (toScreenPoint fromPos) + withPoint Cairo.lineTo (toScreenPoint toPos) + Cairo.stroke + LinkPointsWrap fromPos toPos fromPos' toPos' -> do + withPoint Cairo.moveTo (toScreenPoint fromPos) + withPoint Cairo.lineTo (toScreenPoint toPos) + Cairo.stroke + withPoint Cairo.moveTo (toScreenPoint fromPos') + withPoint Cairo.lineTo (toScreenPoint toPos') + Cairo.stroke - -- We draw with a full line - MsgsInFlightBallistic -> - case catMaybes [ptclMessageColor msg | (msg, _, _) <- msgs] of - [] -> return () - ((r, g, b) : _) -> do - Cairo.setSourceRGB r g b - Cairo.setDash [] 0 - Cairo.setLineWidth 2 - case vizNodeLinks !!! (fromNode, toNode) of - LinkPointsNoWrap fromPos toPos -> do - withPoint Cairo.moveTo (toScreenPoint fromPos) - withPoint Cairo.lineTo (toScreenPoint toPos) - Cairo.stroke - LinkPointsWrap fromPos toPos fromPos' toPos' -> do - withPoint Cairo.moveTo (toScreenPoint fromPos) - withPoint Cairo.lineTo (toScreenPoint toPos) - Cairo.stroke - withPoint Cairo.moveTo (toScreenPoint fromPos') - withPoint Cairo.lineTo (toScreenPoint toPos') - Cairo.stroke + -- We draw with a full line + MsgsInFlightBallistic -> + case catMaybes [ptclMessageColor msg | (msg, _, _) <- msgs] of + [] -> return () + ((r, g, b) : _) -> do + Cairo.setSourceRGB r g b + Cairo.setDash [] 0 + Cairo.setLineWidth 2 + case vizNodeLinks !!! (fromNode, toNode) of + LinkPointsNoWrap fromPos toPos -> do + withPoint Cairo.moveTo (toScreenPoint fromPos) + withPoint Cairo.lineTo (toScreenPoint toPos) + Cairo.stroke + LinkPointsWrap fromPos toPos fromPos' toPos' -> do + withPoint Cairo.moveTo (toScreenPoint fromPos) + withPoint Cairo.lineTo (toScreenPoint toPos) + Cairo.stroke + withPoint Cairo.moveTo (toScreenPoint fromPos') + withPoint Cairo.lineTo (toScreenPoint toPos') + Cairo.stroke | ((fromNode, toNode), msgs) <- Map.toList vizMsgsInTransit ] Cairo.restore -- draw the messages in flight on top sequence_ [ case vizNodeLinks !!! (fromNode, toNode) of - LinkPointsNoWrap fromPos toPos -> do - let (msgTrailingEdge, _msgLeadingEdge) = - lineMessageInFlight now fromPos toPos msgforecast - Point x y = toScreenPoint msgTrailingEdge - Cairo.rectangle (x - 8) (y - 8) 16 16 - Cairo.setSourceRGB r g b - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.stroke - LinkPointsWrap fromPos toPos fromPos' toPos' -> do - let (msgTrailingEdge, _msgLeadingEdge) = - lineMessageInFlight now fromPos toPos msgforecast - Point x y = toScreenPoint msgTrailingEdge - Cairo.rectangle (x - 8) (y - 8) 16 16 - Cairo.setSourceRGB r g b - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.stroke - let (msgTrailingEdge', _msgLeadingEdge) = - lineMessageInFlight now fromPos' toPos' msgforecast - Point x' y' = toScreenPoint msgTrailingEdge' - Cairo.rectangle (x' - 8) (y' - 8) 16 16 - Cairo.setSourceRGB r g b - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.stroke + LinkPointsNoWrap fromPos toPos -> do + let (msgTrailingEdge, _msgLeadingEdge) = + lineMessageInFlight now fromPos toPos msgforecast + Point x y = toScreenPoint msgTrailingEdge + Cairo.rectangle (x - 8) (y - 8) 16 16 + Cairo.setSourceRGB r g b + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.stroke + LinkPointsWrap fromPos toPos fromPos' toPos' -> do + let (msgTrailingEdge, _msgLeadingEdge) = + lineMessageInFlight now fromPos toPos msgforecast + Point x y = toScreenPoint msgTrailingEdge + Cairo.rectangle (x - 8) (y - 8) 16 16 + Cairo.setSourceRGB r g b + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.stroke + let (msgTrailingEdge', _msgLeadingEdge) = + lineMessageInFlight now fromPos' toPos' msgforecast + Point x' y' = toScreenPoint msgTrailingEdge' + Cairo.rectangle (x' - 8) (y' - 8) 16 16 + Cairo.setSourceRGB r g b + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.stroke | ((fromNode, toNode), msgs) <- Map.toList vizMsgsInTransit , (msg, msgforecast, _msgforecasts) <- msgs , now >= msgSendTrailingEdge msgforecast @@ -270,12 +270,12 @@ chartDiffusionLatency RelayP2PSimVizConfig{nodeMessageColor} = \_ _ ( SimVizModel - _ - RelaySimVizState - { vizNodePos - , vizMsgsDiffusionLatency - } - ) -> + _ + RelaySimVizState + { vizNodePos + , vizMsgsDiffusionLatency + } + ) -> (Chart.def :: Chart.Layout DiffTime Chart.Percent) { Chart._layout_title = "Diffusion latency" , Chart._layout_title_style = Chart.def{Chart._font_size = 15} @@ -291,14 +291,14 @@ chartDiffusionLatency RelayP2PSimVizConfig{nodeMessageColor} = } , Chart._layout_plots = [ Chart.toPlot $ - Chart.def - { Chart._plot_lines_values = [timeseries] - , Chart._plot_lines_style = - let (r, g, b) = nodeMessageColor blk - in Chart.def - { Chart._line_color = Chart.opaque (Colour.sRGB r g b) - } - } + Chart.def + { Chart._plot_lines_values = [timeseries] + , Chart._plot_lines_style = + let (r, g, b) = nodeMessageColor blk + in Chart.def + { Chart._line_color = Chart.opaque (Colour.sRGB r g b) + } + } | let nnodes = Map.size vizNodePos , (blk, _nid, created, arrivals) <- Map.elems vizMsgsDiffusionLatency , let timeseries = @@ -343,14 +343,14 @@ chartDiffusionImperfection } , Chart._layout_plots = [ Chart.toPlot $ - Chart.def - { Chart._plot_lines_values = [timeseries] - , Chart._plot_lines_style = - let (r, g, b) = nodeMessageColor blk - in Chart.def - { Chart._line_color = Chart.opaque (Colour.sRGB r g b) - } - } + Chart.def + { Chart._plot_lines_values = [timeseries] + , Chart._plot_lines_style = + let (r, g, b) = nodeMessageColor blk + in Chart.def + { Chart._line_color = Chart.opaque (Colour.sRGB r g b) + } + } | (blk, nid, created, arrivals) <- Map.elems vizMsgsDiffusionLatency , let timeseries = [ (latencyActual, imperfection) @@ -381,12 +381,12 @@ chartBandwidth = \_ _ ( SimVizModel - _ - RelaySimVizState - { vizMsgsAtNodeRecentQueue - , vizMsgsAtNodeRecentBuffer - } - ) -> + _ + RelaySimVizState + { vizMsgsAtNodeRecentQueue + , vizMsgsAtNodeRecentBuffer + } + ) -> (Chart.def :: Chart.Layout Double Double) { Chart._layout_title = "Distribution of block frequency" , Chart._layout_title_style = Chart.def{Chart._font_size = 15} @@ -404,21 +404,21 @@ chartBandwidth = } , Chart._layout_plots = [ bandwidthHistPlot - "CPU (block validation completion)" - Chart.red - ( map - ((fromIntegral :: Int -> Double) . recentRate) - (Map.elems vizMsgsAtNodeRecentBuffer) - ) + "CPU (block validation completion)" + Chart.red + ( map + ((fromIntegral :: Int -> Double) . recentRate) + (Map.elems vizMsgsAtNodeRecentBuffer) + ) | not (Map.null vizMsgsAtNodeRecentBuffer) ] ++ [ bandwidthHistPlot - "Network (block arrival)" - Chart.blue - ( map - ((fromIntegral :: Int -> Double) . recentRate) - (Map.elems vizMsgsAtNodeRecentQueue) - ) + "Network (block arrival)" + Chart.blue + ( map + ((fromIntegral :: Int -> Double) . recentRate) + (Map.elems vizMsgsAtNodeRecentQueue) + ) | not (Map.null vizMsgsAtNodeRecentQueue) ] } @@ -451,11 +451,11 @@ chartLinkUtilisation = \_ _ ( SimVizModel - _ - RelaySimVizState - { vizMsgsInTransit - } - ) -> + _ + RelaySimVizState + { vizMsgsInTransit + } + ) -> let counts :: UArray MsgsInFlightClassification Int counts = accumArray diff --git a/simulation/src/VizSimTCP.hs b/simulation/src/VizSimTCP.hs index 0cb83e906..9e428ffc1 100644 --- a/simulation/src/VizSimTCP.hs +++ b/simulation/src/VizSimTCP.hs @@ -162,11 +162,11 @@ tcpSimVizRenderModel Cairo.setLineWidth 3 sequence_ [ do - Cairo.arc x y 25 0 (pi * 2) - Cairo.setSourceRGB 0.7 0.7 0.7 - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.stroke + Cairo.arc x y 25 0 (pi * 2) + Cairo.setSourceRGB 0.7 0.7 0.7 + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.stroke | (_node, Point x y) <- Map.toList vizNodePos ] Cairo.restore @@ -175,12 +175,12 @@ tcpSimVizRenderModel Cairo.save sequence_ [ do - Cairo.setSourceRGB r g b - Cairo.arc x y' 10 0 (2 * pi) - Cairo.fillPreserve - Cairo.setSourceRGB 0 0 0 - Cairo.setLineWidth 1 - Cairo.stroke + Cairo.setSourceRGB r g b + Cairo.arc x y' 10 0 (2 * pi) + Cairo.fillPreserve + Cairo.setSourceRGB 0 0 0 + Cairo.setLineWidth 1 + Cairo.stroke | (node, msgs) <- Map.toList vizMsgsAtNode , (n, msg) <- zip [1 ..] msgs , let Point x y = vizNodePos Map.! node @@ -195,19 +195,19 @@ tcpSimVizRenderModel Cairo.setLineWidth 3 sequence_ [ do - Cairo.save - renderPathRoundedRect fromPos toPos 20 - Cairo.setSourceRGB 0.9 0.9 0.9 - Cairo.fillPreserve - Cairo.clip - Cairo.newPath - -- draw all the messages within the clipping region of the link - renderMessagesInFlight config now fromPos toPos msgs - Cairo.restore - -- the draw the link border on top (without clipping) - renderPathRoundedRect fromPos toPos 20 - Cairo.setSourceRGB 0 0 0 - Cairo.stroke + Cairo.save + renderPathRoundedRect fromPos toPos 20 + Cairo.setSourceRGB 0.9 0.9 0.9 + Cairo.fillPreserve + Cairo.clip + Cairo.newPath + -- draw all the messages within the clipping region of the link + renderMessagesInFlight config now fromPos toPos msgs + Cairo.restore + -- the draw the link border on top (without clipping) + renderPathRoundedRect fromPos toPos 20 + Cairo.setSourceRGB 0 0 0 + Cairo.stroke | (fromPos, toPos, msgs) <- linksAndMsgs ] Cairo.restore @@ -245,37 +245,37 @@ renderMessagesInFlight :: renderMessagesInFlight TcpSimVizConfig{messageColor} now fromPos toPos msgs = do sequence_ [ do - -- The overall message - withPoint Cairo.moveTo msgTrailingEdge - withPoint Cairo.lineTo msgLeadingEdge - Cairo.setSourceRGBA r g b 0.4 - Cairo.setLineWidth 10 - Cairo.stroke - -- The TCP message fragments - sequence_ - [ do - withPoint Cairo.moveTo (msgfragTrailingEdge `addP` offset) - withPoint Cairo.lineTo (msgfragLeadingEdge `addP` offset) - withPoint Cairo.lineTo (msgfragLeadingEdge `addP` negateV offset) - withPoint Cairo.lineTo (msgfragTrailingEdge `addP` negateV offset) - Cairo.closePath - | msgfragforecast <- msgforecasts - , now >= msgSendLeadingEdge msgfragforecast - , now <= msgRecvTrailingEdge msgfragforecast - , let (msgfragTrailingEdge, msgfragLeadingEdge) = - lineMessageInFlight now fromPos toPos msgfragforecast - offset = - scaleV (18 / 2) $ - unitV $ - normalV $ - vector - msgfragTrailingEdge - msgfragLeadingEdge - ] - Cairo.setSourceRGB r g b - Cairo.fillPreserve - Cairo.setLineWidth 2 - Cairo.stroke + -- The overall message + withPoint Cairo.moveTo msgTrailingEdge + withPoint Cairo.lineTo msgLeadingEdge + Cairo.setSourceRGBA r g b 0.4 + Cairo.setLineWidth 10 + Cairo.stroke + -- The TCP message fragments + sequence_ + [ do + withPoint Cairo.moveTo (msgfragTrailingEdge `addP` offset) + withPoint Cairo.lineTo (msgfragLeadingEdge `addP` offset) + withPoint Cairo.lineTo (msgfragLeadingEdge `addP` negateV offset) + withPoint Cairo.lineTo (msgfragTrailingEdge `addP` negateV offset) + Cairo.closePath + | msgfragforecast <- msgforecasts + , now >= msgSendLeadingEdge msgfragforecast + , now <= msgRecvTrailingEdge msgfragforecast + , let (msgfragTrailingEdge, msgfragLeadingEdge) = + lineMessageInFlight now fromPos toPos msgfragforecast + offset = + scaleV (18 / 2) $ + unitV $ + normalV $ + vector + msgfragTrailingEdge + msgfragLeadingEdge + ] + Cairo.setSourceRGB r g b + Cairo.fillPreserve + Cairo.setLineWidth 2 + Cairo.stroke | (msg, msgforecast, msgforecasts) <- msgs , now <= msgRecvTrailingEdge msgforecast , let (r, g, b) = messageColor msg