diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 942ce1bb..24371c03 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -63,8 +63,10 @@ jobs: # Defaults, added for clarity: cabal-version: "latest" cabal-update: true + - name: Install libraries - run: sudo apt-get install -y libpango1.0-dev libgtk-3-dev + run: sudo apt-get install -y graphviz libpango1.0-dev libgtk-3-dev + - name: Configure the build run: | cabal configure --enable-tests --enable-benchmarks --disable-documentation diff --git a/.vscode/settings.json b/.vscode/settings.json index 088c0dd2..240eb50e 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -4,5 +4,5 @@ "source.organizeImports": "explicit", }, "editor.formatOnSave": true, - "haskell.formattingProvider": "fourmolu", // Disable default formatter if ESLint is handling formatting + "haskell.formattingProvider": "fourmolu" } \ No newline at end of file diff --git a/cabal.project b/cabal.project index 81c7ed1c..e317583b 100644 --- a/cabal.project +++ b/cabal.project @@ -17,6 +17,8 @@ index-state: packages: simulation +tests: True + source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-network.git diff --git a/data/BenchTopology/topology-dense-52-simple.json b/data/BenchTopology/topology-dense-52-simple.json index 596ffa71..e5ba3089 100644 --- a/data/BenchTopology/topology-dense-52-simple.json +++ b/data/BenchTopology/topology-dense-52-simple.json @@ -1 +1,680 @@ -{"nodes":[{"name":"node-0","nodeId":0,"producers":{"node-1":90.48097222222222,"node-18":0.34729027777777777,"node-2":276.09305555555557,"node-3":0.33942222222222224,"node-36":0.36672916666666666,"node-51":0.3451125},"region":"eu-central-1"},{"name":"node-3","nodeId":3,"producers":{"node-0":0.33942222222222224,"node-21":0.3384861111111111,"node-39":0.3381104166666667,"node-4":90.1570138888889,"node-5":273.1090277777778,"node-6":0.3698152777777778},"region":"eu-central-1"},{"name":"node-6","nodeId":6,"producers":{"node-24":0.3770319444444445,"node-3":0.3698152777777778,"node-42":0.37234999999999996,"node-7":90.4257638888889,"node-8":276.0777777777778,"node-9":0.3701597222222222},"region":"eu-central-1"},{"name":"node-9","nodeId":9,"producers":{"node-10":89.86812499999999,"node-11":266.03055555555557,"node-12":0.3476326388888889,"node-27":0.3396375,"node-45":0.3419902777777778,"node-6":0.3701597222222222},"region":"eu-central-1"},{"name":"node-12","nodeId":12,"producers":{"node-13":90.55194444444444,"node-14":272.0201388888889,"node-15":0.3478527777777778,"node-30":0.34171527777777777,"node-48":0.3484048611111111,"node-9":0.3476326388888889},"region":"eu-central-1"},{"name":"node-15","nodeId":15,"producers":{"node-12":0.3478527777777778,"node-16":90.26118055555555,"node-17":269.13958333333335,"node-18":0.35902083333333334,"node-33":0.37824652777777773,"node-51":0.36318263888888885},"region":"eu-central-1"},{"name":"node-18","nodeId":18,"producers":{"node-0":0.34729027777777777,"node-15":0.35902083333333334,"node-19":90.23027777777777,"node-20":269.02222222222224,"node-21":0.34589583333333335,"node-36":0.36012638888888887},"region":"eu-central-1"},{"name":"node-21","nodeId":21,"producers":{"node-18":0.34589583333333335,"node-22":90.50819444444444,"node-23":272.34375,"node-24":0.3671020833333333,"node-3":0.3384861111111111,"node-39":0.3440388888888889},"region":"eu-central-1"},{"name":"node-24","nodeId":24,"producers":{"node-21":0.3671020833333333,"node-25":90.23666666666666,"node-26":276.87361111111113,"node-27":0.3590743055555556,"node-42":0.41380069444444445,"node-6":0.3770319444444445},"region":"eu-central-1"},{"name":"node-27","nodeId":27,"producers":{"node-24":0.3590743055555556,"node-28":90.10763888888889,"node-29":275.97083333333336,"node-30":0.34027291666666665,"node-45":0.3246284722222222,"node-9":0.3396375},"region":"eu-central-1"},{"name":"node-30","nodeId":30,"producers":{"node-12":0.34171527777777777,"node-27":0.34027291666666665,"node-31":89.86743055555556,"node-32":274.01666666666665,"node-33":0.3622180555555556,"node-48":0.36622638888888887},"region":"eu-central-1"},{"name":"node-33","nodeId":33,"producers":{"node-15":0.37824652777777773,"node-30":0.3622180555555556,"node-34":90.56423611111111,"node-35":276.6513888888889,"node-36":0.3805534722222222,"node-51":0.36927708333333337},"region":"eu-central-1"},{"name":"node-36","nodeId":36,"producers":{"node-0":0.36672916666666666,"node-18":0.36012638888888887,"node-33":0.3805534722222222,"node-37":90.55347222222223,"node-38":275.0180555555556,"node-39":0.35533194444444444},"region":"eu-central-1"},{"name":"node-39","nodeId":39,"producers":{"node-21":0.3440388888888889,"node-3":0.3381104166666667,"node-36":0.35533194444444444,"node-40":90.50875,"node-41":268.34236111111113,"node-42":0.36125069444444446},"region":"eu-central-1"},{"name":"node-42","nodeId":42,"producers":{"node-24":0.41380069444444445,"node-39":0.36125069444444446,"node-43":90.08180555555556,"node-44":271.04791666666665,"node-45":0.3530006944444445,"node-6":0.37234999999999996},"region":"eu-central-1"},{"name":"node-45","nodeId":45,"producers":{"node-27":0.3246284722222222,"node-42":0.3530006944444445,"node-46":90.23340277777777,"node-47":273.0229166666667,"node-48":0.3433902777777778,"node-9":0.3419902777777778},"region":"eu-central-1"},{"name":"node-48","nodeId":48,"producers":{"node-12":0.3484048611111111,"node-30":0.36622638888888887,"node-45":0.3433902777777778,"node-49":91.12368055555557,"node-50":276.0125,"node-51":0.36017916666666666},"region":"eu-central-1"},{"name":"node-51","nodeId":51,"producers":{"node-0":0.3451125,"node-1":90.67888888888889,"node-15":0.36318263888888885,"node-2":273.34305555555557,"node-33":0.36927708333333337,"node-48":0.36017916666666666},"region":"eu-central-1"},{"name":"node-1","nodeId":1,"producers":{"node-0":90.48097222222222,"node-16":0.4342461752433936,"node-2":202.01805555555555,"node-34":0.44832361111111113,"node-4":0.43855347222222224,"node-49":0.401975},"region":"us-east-1"},{"name":"node-4","nodeId":4,"producers":{"node-1":0.43855347222222224,"node-19":0.36819861111111113,"node-3":90.1570138888889,"node-37":0.35801944444444445,"node-5":199.38125,"node-7":0.4622944444444444},"region":"us-east-1"},{"name":"node-7","nodeId":7,"producers":{"node-10":0.45094097222222224,"node-22":0.4226,"node-4":0.4622944444444444,"node-40":0.44392777777777775,"node-6":90.4257638888889,"node-8":200.3486111111111},"region":"us-east-1"},{"name":"node-10","nodeId":10,"producers":{"node-11":199.62847222222223,"node-13":0.45004166666666673,"node-25":0.3849277777777778,"node-43":0.32893055555555556,"node-7":0.45094097222222224,"node-9":89.86812499999999},"region":"us-east-1"},{"name":"node-13","nodeId":13,"producers":{"node-10":0.45004166666666673,"node-12":90.55194444444444,"node-14":200.19027777777777,"node-16":0.4033861111111111,"node-28":0.41853749999999995,"node-46":0.42039027777777777},"region":"us-east-1"},{"name":"node-16","nodeId":16,"producers":{"node-13":0.4033861111111111,"node-15":90.26118055555555,"node-17":200.10208333333333,"node-19":0.42593472222222223,"node-31":0.40844583333333334,"node-49":0.39644444444444443},"region":"us-east-1"},{"name":"node-19","nodeId":19,"producers":{"node-1":0.4690611111111111,"node-16":0.42593472222222223,"node-18":90.23027777777777,"node-20":199.3513888888889,"node-22":0.4565236111111111,"node-34":0.4409930555555555},"region":"us-east-1"},{"name":"node-22","nodeId":22,"producers":{"node-19":0.4565236111111111,"node-21":90.50819444444444,"node-23":200.39236111111111,"node-25":0.4571909722222222,"node-37":0.36644305555555556,"node-4":0.37163888888888885},"region":"us-east-1"},{"name":"node-25","nodeId":25,"producers":{"node-22":0.4571909722222222,"node-24":90.23666666666666,"node-26":200.34166666666667,"node-28":0.4533548611111111,"node-40":0.46544166666666664,"node-7":0.4283694444444444},"region":"us-east-1"},{"name":"node-28","nodeId":28,"producers":{"node-10":0.36070416666666666,"node-25":0.4533548611111111,"node-27":90.10763888888889,"node-29":201.00208333333333,"node-31":0.41357916666666666,"node-43":0.4270708333333333},"region":"us-east-1"},{"name":"node-31","nodeId":31,"producers":{"node-13":0.3942583333333333,"node-28":0.41357916666666666,"node-30":89.86743055555556,"node-32":200.3486111111111,"node-34":0.4138222222222222,"node-46":0.3897652777777778},"region":"us-east-1"},{"name":"node-34","nodeId":34,"producers":{"node-16":0.42515000000000003,"node-31":0.4138222222222222,"node-33":90.56423611111111,"node-35":200.9701388888889,"node-37":0.37951874999999996,"node-49":0.45670694444444443},"region":"us-east-1"},{"name":"node-37","nodeId":37,"producers":{"node-1":0.44497361111111117,"node-19":0.46741527777777775,"node-34":0.37951874999999996,"node-36":90.55347222222223,"node-38":199.34722222222223,"node-40":0.3961284722222222},"region":"us-east-1"},{"name":"node-40","nodeId":40,"producers":{"node-22":0.45707083333333337,"node-37":0.3961284722222222,"node-39":90.50875,"node-4":0.39042638888888886,"node-41":200.03333333333333,"node-43":0.41828125000000005},"region":"us-east-1"},{"name":"node-43","nodeId":43,"producers":{"node-25":0.39931944444444445,"node-40":0.41828125000000005,"node-42":90.08180555555556,"node-44":200.00555555555556,"node-46":0.42706805555555555,"node-7":0.4627111111111111},"region":"us-east-1"},{"name":"node-46","nodeId":46,"producers":{"node-10":0.4064361111111111,"node-28":0.39627361111111115,"node-43":0.42706805555555555,"node-45":90.23340277777777,"node-47":200.34166666666667,"node-49":0.4398472222222222},"region":"us-east-1"},{"name":"node-49","nodeId":49,"producers":{"node-1":0.401975,"node-13":0.39808888888888894,"node-31":0.3299930555555556,"node-46":0.4398472222222222,"node-48":91.12368055555557,"node-50":200.34305555555557},"region":"us-east-1"},{"name":"node-2","nodeId":2,"producers":{"node-0":276.09305555555557,"node-1":202.01805555555555,"node-17":0.30009305555555554,"node-35":0.29759305555555554,"node-5":0.30771944444444443,"node-50":0.29913333333333336},"region":"ap-southeast-2"},{"name":"node-5","nodeId":5,"producers":{"node-2":0.30771944444444443,"node-20":0.30049722222222225,"node-3":273.1090277777778,"node-38":0.2899819444444445,"node-4":199.38125,"node-8":0.3110354166666667},"region":"ap-southeast-2"},{"name":"node-8","nodeId":8,"producers":{"node-11":0.29304930555555553,"node-23":0.3052527777777778,"node-41":0.31074444444444443,"node-5":0.3110354166666667,"node-6":276.0777777777778,"node-7":200.3486111111111},"region":"ap-southeast-2"},{"name":"node-11","nodeId":11,"producers":{"node-10":199.62847222222223,"node-14":0.2842951388888889,"node-26":0.2888,"node-44":0.29482777777777774,"node-8":0.29304930555555553,"node-9":266.03055555555557},"region":"ap-southeast-2"},{"name":"node-14","nodeId":14,"producers":{"node-11":0.2842951388888889,"node-12":272.0201388888889,"node-13":200.19027777777777,"node-17":0.3536597222222222,"node-29":0.30080416666666665,"node-47":0.301875},"region":"ap-southeast-2"},{"name":"node-17","nodeId":17,"producers":{"node-14":0.3536597222222222,"node-15":269.13958333333335,"node-16":200.10208333333333,"node-20":0.29487916666666664,"node-32":0.2978263888888889,"node-50":0.3177625},"region":"ap-southeast-2"},{"name":"node-20","nodeId":20,"producers":{"node-17":0.29487916666666664,"node-18":269.02222222222224,"node-19":199.3513888888889,"node-2":0.3029972222222222,"node-23":0.30144375,"node-35":0.28387083333333335},"region":"ap-southeast-2"},{"name":"node-23","nodeId":23,"producers":{"node-20":0.30144375,"node-21":272.34375,"node-22":200.39236111111111,"node-26":0.31067638888888893,"node-38":0.2914986111111111,"node-5":0.3067},"region":"ap-southeast-2"},{"name":"node-26","nodeId":26,"producers":{"node-23":0.31067638888888893,"node-24":276.87361111111113,"node-25":200.34166666666667,"node-29":0.2872277777777778,"node-41":0.30625694444444446,"node-8":0.30330833333333335},"region":"ap-southeast-2"},{"name":"node-29","nodeId":29,"producers":{"node-11":0.33129027777777775,"node-26":0.2872277777777778,"node-27":275.97083333333336,"node-28":201.00208333333333,"node-32":0.2966520833333333,"node-44":0.3023875},"region":"ap-southeast-2"},{"name":"node-32","nodeId":32,"producers":{"node-14":0.32953194444444445,"node-29":0.2966520833333333,"node-30":274.01666666666665,"node-31":200.3486111111111,"node-35":0.30365763888888886,"node-47":0.30419861111111113},"region":"ap-southeast-2"},{"name":"node-35","nodeId":35,"producers":{"node-17":0.2954305555555556,"node-32":0.30365763888888886,"node-33":276.6513888888889,"node-34":200.9701388888889,"node-38":0.2971423611111111,"node-50":0.28720694444444445},"region":"ap-southeast-2"},{"name":"node-38","nodeId":38,"producers":{"node-2":0.30064722222222223,"node-20":0.28146944444444444,"node-35":0.2971423611111111,"node-36":275.0180555555556,"node-37":199.34722222222223,"node-41":0.2886277777777778},"region":"ap-southeast-2"},{"name":"node-41","nodeId":41,"producers":{"node-23":0.31827777777777777,"node-38":0.2886277777777778,"node-39":268.34236111111113,"node-40":200.03333333333333,"node-44":0.29804583333333334,"node-5":0.3122888888888889},"region":"ap-southeast-2"},{"name":"node-44","nodeId":44,"producers":{"node-26":0.2924027777777778,"node-41":0.29804583333333334,"node-42":271.04791666666665,"node-43":200.00555555555556,"node-47":0.2969333333333333,"node-8":0.30822777777777777},"region":"ap-southeast-2"},{"name":"node-47","nodeId":47,"producers":{"node-11":0.28497361111111114,"node-29":0.2937902777777778,"node-44":0.2969333333333333,"node-45":273.0229166666667,"node-46":200.34166666666667,"node-50":0.30041666666666667},"region":"ap-southeast-2"},{"name":"node-50","nodeId":50,"producers":{"node-14":0.2870027777777778,"node-2":0.29913333333333336,"node-32":0.29109166666666664,"node-47":0.30041666666666667,"node-48":276.0125,"node-49":200.34305555555557},"region":"ap-southeast-2"}]} \ No newline at end of file +{ + "nodes": [ + { + "name": "node-0", + "nodeId": 0, + "producers": { + "node-1": 90.48097222222222, + "node-18": 0.34729027777777777, + "node-2": 276.09305555555557, + "node-3": 0.33942222222222224, + "node-36": 0.36672916666666666, + "node-51": 0.3451125 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-3", + "nodeId": 3, + "producers": { + "node-0": 0.33942222222222224, + "node-21": 0.3384861111111111, + "node-39": 0.3381104166666667, + "node-4": 90.1570138888889, + "node-5": 273.1090277777778, + "node-6": 0.3698152777777778 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-6", + "nodeId": 6, + "producers": { + "node-24": 0.3770319444444445, + "node-3": 0.3698152777777778, + "node-42": 0.37234999999999996, + "node-7": 90.4257638888889, + "node-8": 276.0777777777778, + "node-9": 0.3701597222222222 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-9", + "nodeId": 9, + "producers": { + "node-10": 89.86812499999999, + "node-11": 266.03055555555557, + "node-12": 0.3476326388888889, + "node-27": 0.3396375, + "node-45": 0.3419902777777778, + "node-6": 0.3701597222222222 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-12", + "nodeId": 12, + "producers": { + "node-13": 90.55194444444444, + "node-14": 272.0201388888889, + "node-15": 0.3478527777777778, + "node-30": 0.34171527777777777, + "node-48": 0.3484048611111111, + "node-9": 0.3476326388888889 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-15", + "nodeId": 15, + "producers": { + "node-12": 0.3478527777777778, + "node-16": 90.26118055555555, + "node-17": 269.13958333333335, + "node-18": 0.35902083333333334, + "node-33": 0.37824652777777773, + "node-51": 0.36318263888888885 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-18", + "nodeId": 18, + "producers": { + "node-0": 0.34729027777777777, + "node-15": 0.35902083333333334, + "node-19": 90.23027777777777, + "node-20": 269.02222222222224, + "node-21": 0.34589583333333335, + "node-36": 0.36012638888888887 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-21", + "nodeId": 21, + "producers": { + "node-18": 0.34589583333333335, + "node-22": 90.50819444444444, + "node-23": 272.34375, + "node-24": 0.3671020833333333, + "node-3": 0.3384861111111111, + "node-39": 0.3440388888888889 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-24", + "nodeId": 24, + "producers": { + "node-21": 0.3671020833333333, + "node-25": 90.23666666666666, + "node-26": 276.87361111111113, + "node-27": 0.3590743055555556, + "node-42": 0.41380069444444445, + "node-6": 0.3770319444444445 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-27", + "nodeId": 27, + "producers": { + "node-24": 0.3590743055555556, + "node-28": 90.10763888888889, + "node-29": 275.97083333333336, + "node-30": 0.34027291666666665, + "node-45": 0.3246284722222222, + "node-9": 0.3396375 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-30", + "nodeId": 30, + "producers": { + "node-12": 0.34171527777777777, + "node-27": 0.34027291666666665, + "node-31": 89.86743055555556, + "node-32": 274.01666666666665, + "node-33": 0.3622180555555556, + "node-48": 0.36622638888888887 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-33", + "nodeId": 33, + "producers": { + "node-15": 0.37824652777777773, + "node-30": 0.3622180555555556, + "node-34": 90.56423611111111, + "node-35": 276.6513888888889, + "node-36": 0.3805534722222222, + "node-51": 0.36927708333333337 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-36", + "nodeId": 36, + "producers": { + "node-0": 0.36672916666666666, + "node-18": 0.36012638888888887, + "node-33": 0.3805534722222222, + "node-37": 90.55347222222223, + "node-38": 275.0180555555556, + "node-39": 0.35533194444444444 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-39", + "nodeId": 39, + "producers": { + "node-21": 0.3440388888888889, + "node-3": 0.3381104166666667, + "node-36": 0.35533194444444444, + "node-40": 90.50875, + "node-41": 268.34236111111113, + "node-42": 0.36125069444444446 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-42", + "nodeId": 42, + "producers": { + "node-24": 0.41380069444444445, + "node-39": 0.36125069444444446, + "node-43": 90.08180555555556, + "node-44": 271.04791666666665, + "node-45": 0.3530006944444445, + "node-6": 0.37234999999999996 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-45", + "nodeId": 45, + "producers": { + "node-27": 0.3246284722222222, + "node-42": 0.3530006944444445, + "node-46": 90.23340277777777, + "node-47": 273.0229166666667, + "node-48": 0.3433902777777778, + "node-9": 0.3419902777777778 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-48", + "nodeId": 48, + "producers": { + "node-12": 0.3484048611111111, + "node-30": 0.36622638888888887, + "node-45": 0.3433902777777778, + "node-49": 91.12368055555557, + "node-50": 276.0125, + "node-51": 0.36017916666666666 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-51", + "nodeId": 51, + "producers": { + "node-0": 0.3451125, + "node-1": 90.67888888888889, + "node-15": 0.36318263888888885, + "node-2": 273.34305555555557, + "node-33": 0.36927708333333337, + "node-48": 0.36017916666666666 + }, + "clusterName": "eu-central-1" + }, + { + "name": "node-1", + "nodeId": 1, + "producers": { + "node-0": 90.48097222222222, + "node-16": 0.4342461752433936, + "node-2": 202.01805555555555, + "node-34": 0.44832361111111113, + "node-4": 0.43855347222222224, + "node-49": 0.401975 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-4", + "nodeId": 4, + "producers": { + "node-1": 0.43855347222222224, + "node-19": 0.36819861111111113, + "node-3": 90.1570138888889, + "node-37": 0.35801944444444445, + "node-5": 199.38125, + "node-7": 0.4622944444444444 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-7", + "nodeId": 7, + "producers": { + "node-10": 0.45094097222222224, + "node-22": 0.4226, + "node-4": 0.4622944444444444, + "node-40": 0.44392777777777775, + "node-6": 90.4257638888889, + "node-8": 200.3486111111111 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-10", + "nodeId": 10, + "producers": { + "node-11": 199.62847222222223, + "node-13": 0.45004166666666673, + "node-25": 0.3849277777777778, + "node-43": 0.32893055555555556, + "node-7": 0.45094097222222224, + "node-9": 89.86812499999999 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-13", + "nodeId": 13, + "producers": { + "node-10": 0.45004166666666673, + "node-12": 90.55194444444444, + "node-14": 200.19027777777777, + "node-16": 0.4033861111111111, + "node-28": 0.41853749999999995, + "node-46": 0.42039027777777777 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-16", + "nodeId": 16, + "producers": { + "node-13": 0.4033861111111111, + "node-15": 90.26118055555555, + "node-17": 200.10208333333333, + "node-19": 0.42593472222222223, + "node-31": 0.40844583333333334, + "node-49": 0.39644444444444443 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-19", + "nodeId": 19, + "producers": { + "node-1": 0.4690611111111111, + "node-16": 0.42593472222222223, + "node-18": 90.23027777777777, + "node-20": 199.3513888888889, + "node-22": 0.4565236111111111, + "node-34": 0.4409930555555555 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-22", + "nodeId": 22, + "producers": { + "node-19": 0.4565236111111111, + "node-21": 90.50819444444444, + "node-23": 200.39236111111111, + "node-25": 0.4571909722222222, + "node-37": 0.36644305555555556, + "node-4": 0.37163888888888885 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-25", + "nodeId": 25, + "producers": { + "node-22": 0.4571909722222222, + "node-24": 90.23666666666666, + "node-26": 200.34166666666667, + "node-28": 0.4533548611111111, + "node-40": 0.46544166666666664, + "node-7": 0.4283694444444444 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-28", + "nodeId": 28, + "producers": { + "node-10": 0.36070416666666666, + "node-25": 0.4533548611111111, + "node-27": 90.10763888888889, + "node-29": 201.00208333333333, + "node-31": 0.41357916666666666, + "node-43": 0.4270708333333333 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-31", + "nodeId": 31, + "producers": { + "node-13": 0.3942583333333333, + "node-28": 0.41357916666666666, + "node-30": 89.86743055555556, + "node-32": 200.3486111111111, + "node-34": 0.4138222222222222, + "node-46": 0.3897652777777778 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-34", + "nodeId": 34, + "producers": { + "node-16": 0.42515000000000003, + "node-31": 0.4138222222222222, + "node-33": 90.56423611111111, + "node-35": 200.9701388888889, + "node-37": 0.37951874999999996, + "node-49": 0.45670694444444443 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-37", + "nodeId": 37, + "producers": { + "node-1": 0.44497361111111117, + "node-19": 0.46741527777777775, + "node-34": 0.37951874999999996, + "node-36": 90.55347222222223, + "node-38": 199.34722222222223, + "node-40": 0.3961284722222222 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-40", + "nodeId": 40, + "producers": { + "node-22": 0.45707083333333337, + "node-37": 0.3961284722222222, + "node-39": 90.50875, + "node-4": 0.39042638888888886, + "node-41": 200.03333333333333, + "node-43": 0.41828125000000005 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-43", + "nodeId": 43, + "producers": { + "node-25": 0.39931944444444445, + "node-40": 0.41828125000000005, + "node-42": 90.08180555555556, + "node-44": 200.00555555555556, + "node-46": 0.42706805555555555, + "node-7": 0.4627111111111111 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-46", + "nodeId": 46, + "producers": { + "node-10": 0.4064361111111111, + "node-28": 0.39627361111111115, + "node-43": 0.42706805555555555, + "node-45": 90.23340277777777, + "node-47": 200.34166666666667, + "node-49": 0.4398472222222222 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-49", + "nodeId": 49, + "producers": { + "node-1": 0.401975, + "node-13": 0.39808888888888894, + "node-31": 0.3299930555555556, + "node-46": 0.4398472222222222, + "node-48": 91.12368055555557, + "node-50": 200.34305555555557 + }, + "clusterName": "us-east-1" + }, + { + "name": "node-2", + "nodeId": 2, + "producers": { + "node-0": 276.09305555555557, + "node-1": 202.01805555555555, + "node-17": 0.30009305555555554, + "node-35": 0.29759305555555554, + "node-5": 0.30771944444444443, + "node-50": 0.29913333333333336 + }, + "clusterName": "ap-southeast-2" + }, + { + "name": "node-5", + "nodeId": 5, + "producers": { + "node-2": 0.30771944444444443, + "node-20": 0.30049722222222225, + "node-3": 273.1090277777778, + "node-38": 0.2899819444444445, + "node-4": 199.38125, + "node-8": 0.3110354166666667 + }, + "clusterName": "ap-southeast-2" + }, + { + "name": "node-8", + "nodeId": 8, + "producers": { + "node-11": 0.29304930555555553, + "node-23": 0.3052527777777778, + "node-41": 0.31074444444444443, + "node-5": 0.3110354166666667, + "node-6": 276.0777777777778, + "node-7": 200.3486111111111 + }, + "clusterName": "ap-southeast-2" + }, + { + "name": "node-11", + "nodeId": 11, + "producers": { + "node-10": 199.62847222222223, + "node-14": 0.2842951388888889, + "node-26": 0.2888, + "node-44": 0.29482777777777774, + "node-8": 0.29304930555555553, + "node-9": 266.03055555555557 + }, + "clusterName": "ap-southeast-2" + }, + { + "name": "node-14", + "nodeId": 14, + "producers": { + "node-11": 0.2842951388888889, + "node-12": 272.0201388888889, + "node-13": 200.19027777777777, + "node-17": 0.3536597222222222, + "node-29": 0.30080416666666665, + "node-47": 0.301875 + }, + "clusterName": "ap-southeast-2" + }, + { + "name": "node-17", + "nodeId": 17, + "producers": { + "node-14": 0.3536597222222222, + "node-15": 269.13958333333335, + "node-16": 200.10208333333333, + "node-20": 0.29487916666666664, + "node-32": 0.2978263888888889, + "node-50": 0.3177625 + }, + "clusterName": "ap-southeast-2" + }, + { + "name": "node-20", + "nodeId": 20, + "producers": { + "node-17": 0.29487916666666664, + "node-18": 269.02222222222224, + "node-19": 199.3513888888889, + "node-2": 0.3029972222222222, + "node-23": 0.30144375, + "node-35": 0.28387083333333335 + }, + "clusterName": "ap-southeast-2" + }, + { + "name": "node-23", + "nodeId": 23, + "producers": { + "node-20": 0.30144375, + "node-21": 272.34375, + "node-22": 200.39236111111111, + "node-26": 0.31067638888888893, + "node-38": 0.2914986111111111, + "node-5": 0.3067 + }, + "clusterName": "ap-southeast-2" + }, + { + "name": "node-26", + "nodeId": 26, + "producers": { + "node-23": 0.31067638888888893, + "node-24": 276.87361111111113, + "node-25": 200.34166666666667, + "node-29": 0.2872277777777778, + "node-41": 0.30625694444444446, + "node-8": 0.30330833333333335 + }, + "clusterName": "ap-southeast-2" + }, + { + "name": "node-29", + "nodeId": 29, + "producers": { + "node-11": 0.33129027777777775, + "node-26": 0.2872277777777778, + "node-27": 275.97083333333336, + "node-28": 201.00208333333333, + "node-32": 0.2966520833333333, + "node-44": 0.3023875 + }, + "clusterName": "ap-southeast-2" + }, + { + "name": "node-32", + "nodeId": 32, + "producers": { + "node-14": 0.32953194444444445, + "node-29": 0.2966520833333333, + "node-30": 274.01666666666665, + "node-31": 200.3486111111111, + "node-35": 0.30365763888888886, + "node-47": 0.30419861111111113 + }, + "clusterName": "ap-southeast-2" + }, + { + "name": "node-35", + "nodeId": 35, + "producers": { + "node-17": 0.2954305555555556, + "node-32": 0.30365763888888886, + "node-33": 276.6513888888889, + "node-34": 200.9701388888889, + "node-38": 0.2971423611111111, + "node-50": 0.28720694444444445 + }, + "clusterName": "ap-southeast-2" + }, + { + "name": "node-38", + "nodeId": 38, + "producers": { + "node-2": 0.30064722222222223, + "node-20": 0.28146944444444444, + "node-35": 0.2971423611111111, + "node-36": 275.0180555555556, + "node-37": 199.34722222222223, + "node-41": 0.2886277777777778 + }, + "clusterName": "ap-southeast-2" + }, + { + "name": "node-41", + "nodeId": 41, + "producers": { + "node-23": 0.31827777777777777, + "node-38": 0.2886277777777778, + "node-39": 268.34236111111113, + "node-40": 200.03333333333333, + "node-44": 0.29804583333333334, + "node-5": 0.3122888888888889 + }, + "clusterName": "ap-southeast-2" + }, + { + "name": "node-44", + "nodeId": 44, + "producers": { + "node-26": 0.2924027777777778, + "node-41": 0.29804583333333334, + "node-42": 271.04791666666665, + "node-43": 200.00555555555556, + "node-47": 0.2969333333333333, + "node-8": 0.30822777777777777 + }, + "clusterName": "ap-southeast-2" + }, + { + "name": "node-47", + "nodeId": 47, + "producers": { + "node-11": 0.28497361111111114, + "node-29": 0.2937902777777778, + "node-44": 0.2969333333333333, + "node-45": 273.0229166666667, + "node-46": 200.34166666666667, + "node-50": 0.30041666666666667 + }, + "clusterName": "ap-southeast-2" + }, + { + "name": "node-50", + "nodeId": 50, + "producers": { + "node-14": 0.2870027777777778, + "node-2": 0.29913333333333336, + "node-32": 0.29109166666666664, + "node-47": 0.30041666666666667, + "node-48": 276.0125, + "node-49": 200.34305555555557 + }, + "clusterName": "ap-southeast-2" + } + ] +} \ No newline at end of file diff --git a/hooks/pre-commit b/hooks/pre-commit index f3c3f40f..74bda638 100755 --- a/hooks/pre-commit +++ b/hooks/pre-commit @@ -7,10 +7,13 @@ # Check for fourmolu fourmolu_required_version="0.15.0.0" -fourmolu="$(which fourmolu)" +fourmolu="$(which fourmolu-0.15.0.0)" if [ "${fourmolu}" = "" ]; then - echo "pre-commit: Requires fourmolu version ${fourmolu_required_version}; no version found" - exit 1 + fourmolu="$(which fourmolu)" + if [ "${fourmolu}" = "" ]; then + echo "pre-commit: Requires fourmolu version ${fourmolu_required_version}; no version found" + exit 1 + fi fi fourmolu_installed_version="$($fourmolu --version | head -n 1 | cut -d' ' -f2)" if [ ! "${fourmolu_installed_version}" = "${fourmolu_required_version}" ]; then @@ -28,7 +31,7 @@ fi # Check Haskell files with fourmolu echo "Formatting Haskell source files with fourmolu version ${fourmolu_required_version}" -if ! git ls-files --exclude-standard --no-deleted --deduplicate '*.hs' | xargs -L 1 fourmolu --mode=check --quiet; then - git ls-files --exclude-standard --no-deleted --deduplicate '*.hs' | xargs -L 1 fourmolu --mode=inplace --quiet +if ! git ls-files --exclude-standard --no-deleted --deduplicate '*.hs' | xargs -L 1 "${fourmolu}" --mode=check --quiet; then + git ls-files --exclude-standard --no-deleted --deduplicate '*.hs' | xargs -L 1 "${fourmolu}" --mode=inplace --quiet exit 1 fi diff --git a/simulation/ouroboros-leios-sim.cabal b/simulation/ouroboros-leios-sim.cabal index 2c404549..1e68a52f 100644 --- a/simulation/ouroboros-leios-sim.cabal +++ b/simulation/ouroboros-leios-sim.cabal @@ -19,6 +19,9 @@ maintainer: duncan@well-typed.com -- category: build-type: Simple extra-source-files: CHANGELOG.md +data-files: + test/data/BenchTopology/topology-dense-52.json + test/data/BenchTopology/latency.sqlite3.gz flag perf description: Ghc options for improved performance, disables asserts. @@ -166,3 +169,27 @@ executable ols default-language: Haskell2010 ghc-options: -Wall + +test-suite ols-test + if flag(perf) + import: performance-opts + + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + , base + , directory + , fgl + , fgl-arbitrary + , ouroboros-leios-sim + , QuickCheck + , random + , tasty + , tasty-hunit + , tasty-quickcheck + , text + other-modules: + Paths_ouroboros_leios_sim + Test.Topology + default-language: Haskell2010 diff --git a/simulation/src/Main.hs b/simulation/src/Main.hs index 39e26e12..fa08ff6a 100644 --- a/simulation/src/Main.hs +++ b/simulation/src/Main.hs @@ -17,8 +17,9 @@ import qualified PraosProtocol.ExamplesPraosP2P as VizPraosP2P import qualified PraosProtocol.VizSimBlockFetch as VizBlockFetch import qualified PraosProtocol.VizSimChainSync as VizChainSync import qualified PraosProtocol.VizSimPraos as VizPraos +import SimTypes (WorldShape (..)) import TimeCompat (DiffTime, Time (..)) -import Topology (readP2PTopography, readSimpleTopologyFromBenchTopologyAndLatency, writeSimpleTopology) +import Topology (defaultParams, readP2PTopography, readSimpleTopologyFromBenchTopologyAndLatency, writeSimpleTopology) import Viz main :: IO () @@ -227,8 +228,8 @@ vizOptionsToViz VizCommandWithOptions{..} = case vizSubCommand of VizPBF1 -> pure VizBlockFetch.example1 VizPraos1 -> pure VizPraos.example1 VizPraosP2P1{..} -> do - let worldDimensions = (1200, 1000) - maybeP2PTopography <- traverse (readP2PTopography worldDimensions) maybeTopologyFile + let worldShape = WorldShape (1200, 1000) True + maybeP2PTopography <- traverse (readP2PTopography defaultParams worldShape) maybeTopologyFile pure $ VizPraosP2P.example1 seed blockInterval maybeP2PTopography VizPraosP2P2 -> pure VizPraosP2P.example2 VizRelayTest1 -> pure VizSimTestRelay.example1 diff --git a/simulation/src/P2P.hs b/simulation/src/P2P.hs index c9029b9a..4f2a7855 100644 --- a/simulation/src/P2P.hs +++ b/simulation/src/P2P.hs @@ -25,8 +25,8 @@ import Data.List (mapAccumL, sort, unfoldr) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import GHC.Generics (Generic) +import GHC.Stack (HasCallStack) import SimTypes (NodeId (..), Point (..), WorldShape (..)) -import System.Random (StdGen) import qualified System.Random as Random data P2PTopography = P2PTopography @@ -34,7 +34,7 @@ data P2PTopography = P2PTopography , p2pLinks :: !(Map (NodeId, NodeId) Latency) , p2pWorldShape :: !WorldShape } - deriving (Show, Generic) + deriving (Eq, Show, Generic) instance ToJSON P2PTopography where toEncoding = genericToEncoding defaultOptions @@ -56,7 +56,7 @@ data P2PTopographyCharacteristics = P2PTopographyCharacteristics -- ^ Per-node upstream links picked as random peers, e.g. 5 of 10 total , p2pNodeLinksRandom :: Int } - deriving (Show, Generic) + deriving (Eq, Show, Generic) instance ToJSON P2PTopographyCharacteristics where toEncoding = genericToEncoding defaultOptions @@ -77,8 +77,10 @@ instance FromJSON P2PTopographyCharacteristics -- * The latency of each link will be chosen based on the shortest distance -- between the nodes: connecting over the "date line" if necessary. genArbitraryP2PTopography :: + forall g. + (HasCallStack, Random.RandomGen g) => P2PTopographyCharacteristics -> - StdGen -> + g -> P2PTopography genArbitraryP2PTopography P2PTopographyCharacteristics @@ -107,7 +109,7 @@ genArbitraryP2PTopography nodePositions = Map.fromList $ snd $ mapAccumL genNodePos rngNodes nodes where - genNodePos :: StdGen -> NodeId -> (StdGen, (NodeId, Point)) + genNodePos :: g -> NodeId -> (g, (NodeId, Point)) genNodePos rng nodeid = (rng'', (nodeid, Point x y)) where @@ -143,7 +145,7 @@ genArbitraryP2PTopography linkLatencySquared [(p, n) | (n, p) <- Map.toList nodePositions] - pickNodeLinksRandom :: NodeId -> StdGen -> [NodeId] + pickNodeLinksRandom :: NodeId -> g -> [NodeId] pickNodeLinksRandom nid rng = take p2pNodeLinksRandom diff --git a/simulation/src/SimTypes.hs b/simulation/src/SimTypes.hs index 3e26c5ec..4cc445f3 100644 --- a/simulation/src/SimTypes.hs +++ b/simulation/src/SimTypes.hs @@ -24,11 +24,12 @@ data LabelLink e = LabelLink NodeId NodeId e deriving (Show) -- | Position in simulation world coordinates data Point = Point {_1 :: !Double, _2 :: !Double} - deriving (Show, Generic) + deriving (Eq, Show, Generic) -- | Path in simulation world newtype Path = Path [Point] - deriving (Show, Generic) + deriving (Eq, Show, Generic) + deriving newtype (Semigroup, Monoid) instance ToJSON Point where toEncoding = genericToEncoding defaultOptions @@ -46,7 +47,7 @@ data WorldShape = WorldShape -- to the West edge, or if the world is a rectangle, with no wrapping at -- the edges. This affects the latencies. } - deriving (Show, Generic) + deriving (Eq, Show, Generic) instance ToJSON WorldShape where toEncoding = genericToEncoding defaultOptions diff --git a/simulation/src/Topology.hs b/simulation/src/Topology.hs index 32359c36..357006a2 100644 --- a/simulation/src/Topology.hs +++ b/simulation/src/Topology.hs @@ -4,13 +4,14 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeSynonymInstances #-} module Topology where @@ -18,28 +19,29 @@ module Topology where import Codec.Compression.GZip as GZip (decompress) import Control.Arrow (Arrow ((&&&)), second) import Control.Exception (assert) -import Control.Monad (forM_, void, (<=<)) +import Control.Monad (forM_, (<=<)) import Data.Aeson (encode) import Data.Aeson.Decoding (throwDecode) import Data.Aeson.Types (FromJSON (..), FromJSONKey, Options (..), ToJSON (..), ToJSONKey, defaultOptions, genericParseJSON, genericToEncoding) import qualified Data.ByteString.Lazy as BSL import Data.Coerce (coerce) +import Data.Function (on) import qualified Data.Graph.Inductive.Graph as G import Data.Graph.Inductive.PatriciaTree (Gr) -import Data.GraphViz (GraphvizParams (..), X11Color (..)) +import Data.GraphViz (GraphvizParams (..)) import qualified Data.GraphViz as GV -import qualified Data.GraphViz.Attributes as GVA -import qualified Data.GraphViz.Attributes.Complete as GVAC -import qualified Data.GraphViz.Commands as GVC +import qualified Data.GraphViz.Attributes.Complete as GV import qualified Data.GraphViz.Types as GVT (PrintDot) import qualified Data.GraphViz.Types.Generalised as GVTG import Data.IORef (atomicModifyIORef', newIORef, readIORef) +import Data.List (sort, sortBy, uncons) import Data.Map (Map) import qualified Data.Map.Strict as M -import Data.Maybe (maybeToList) -import qualified Data.Sequence as Seq +import Data.Maybe (fromMaybe, mapMaybe, maybeToList) +import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) +import qualified Data.Text as T import Data.Text.Lazy (LazyText) import qualified Data.Text.Lazy as TL import Data.Vector (Vector) @@ -48,7 +50,6 @@ import Database.SQLite.Simple (NamedParam (..)) import qualified Database.SQLite.Simple as SQLlite import qualified Database.SQLite.Simple.ToField as SQLite (ToField) import GHC.Generics (Generic) -import GHC.Records (HasField) import P2P (Latency, P2PTopography (..)) import SimTypes (NodeId (..), Path (..), Point (..), WorldDimensions, WorldShape (..)) import System.FilePath (dropExtension, takeDirectory, takeExtension, takeExtensions, takeFileName) @@ -63,68 +64,97 @@ import Text.Printf (PrintfArg, printf) -------------------------------------------------------------------------------- newtype NodeName = NodeName {unNodeName :: Text} - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) deriving newtype (FromJSON, ToJSON, FromJSONKey, ToJSONKey) deriving newtype (GVT.PrintDot) deriving newtype (SQLite.ToField) deriving newtype (PrintfArg) newtype OrgName = OrgName {unOrgName :: Text} - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) deriving newtype (FromJSON, ToJSON) newtype RegionName = RegionName {unRegionName :: Text} - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) + deriving newtype (FromJSON, ToJSON) + +newtype LatencyInMiliseconds = LatencyInMiliseconds {unLatencyInMiliseconds :: Double} + deriving stock (Show, Eq, Ord) deriving newtype (FromJSON, ToJSON) data BenchTopologyNode = BenchTopologyNode { name :: !NodeName , nodeId :: !NodeId - , org :: !OrgName + , org :: !(Maybe OrgName) , pools :: !(Maybe Int) , producers :: !(Vector NodeName) - , region :: !RegionName - , stakePool :: !Bool + , region :: !(Maybe RegionName) + , stakePool :: !(Maybe Bool) } - deriving (Show, Generic) + deriving (Eq, Show, Generic) + +benchTopologyOptions :: Options +benchTopologyOptions = defaultOptions{unwrapUnaryRecords = False} instance ToJSON BenchTopologyNode where - toEncoding = genericToEncoding defaultOptions + toEncoding = genericToEncoding benchTopologyOptions instance FromJSON BenchTopologyNode newtype BenchTopology = BenchTopology { coreNodes :: Vector BenchTopologyNode } - deriving (Show, Generic) + deriving (Eq, Show, Generic) instance ToJSON BenchTopology where - toEncoding = - genericToEncoding - defaultOptions - { unwrapUnaryRecords = False - } + toEncoding = genericToEncoding benchTopologyOptions instance FromJSON BenchTopology where - parseJSON = - genericParseJSON - defaultOptions - { unwrapUnaryRecords = False - } + parseJSON = genericParseJSON benchTopologyOptions readBenchTopology :: FilePath -> IO BenchTopology readBenchTopology = throwDecode <=< BSL.readFile +-- | Helper for testing. Sorts the list of producers and the list of core nodes by node name. +sortBenchTopology :: BenchTopology -> BenchTopology +sortBenchTopology benchTopology = + BenchTopology + { coreNodes = V.fromList . sortBy (compare `on` (.name)) . V.toList . fmap sortBenchTopologyNode $ benchTopology.coreNodes + } + where + sortBenchTopologyNode :: BenchTopologyNode -> BenchTopologyNode + sortBenchTopologyNode BenchTopologyNode{..} = + BenchTopologyNode + { producers = V.fromList . sort . V.toList $ producers + , .. + } + +-- | Helper for testing. Forgets fields that are not represented by `SimpleTopology`. +forgetUnusedFieldsInBenchTopology :: BenchTopology -> BenchTopology +forgetUnusedFieldsInBenchTopology benchTopology = + BenchTopology + { coreNodes = forgetUnusedFieldsInBenchTopologyNode <$> benchTopology.coreNodes + } + where + forgetUnusedFieldsInBenchTopologyNode :: BenchTopologyNode -> BenchTopologyNode + forgetUnusedFieldsInBenchTopologyNode BenchTopologyNode{..} = + BenchTopologyNode + { org = Nothing + , pools = Nothing + , stakePool = Nothing + , .. + } + -------------------------------------------------------------------------------- -- Latencies -- -- As provided in 'data/BenchTopology/latency.sqlite3.gz'. -------------------------------------------------------------------------------- -type Latencies = Map NodeName (Map NodeName Latency) +type LatenciesInMiliseconds = Map NodeName (Map NodeName LatencyInMiliseconds) -readLatencies :: BenchTopology -> FilePath -> IO Latencies +readLatencies :: BenchTopology -> FilePath -> IO LatenciesInMiliseconds readLatencies topology latencyFile = case takeExtensions latencyFile of ".sqlite3" -> @@ -134,7 +164,7 @@ readLatencies topology latencyFile = _otherwise -> error $ printf "unknown latency file format %s" (takeFileName latencyFile) -readLatenciesSqlite3Gz :: BenchTopology -> FilePath -> IO Latencies +readLatenciesSqlite3Gz :: BenchTopology -> FilePath -> IO LatenciesInMiliseconds readLatenciesSqlite3Gz topology latencySqliteGzFile = assert (takeExtension latencySqliteGzFile == ".gz") $ do let latencySqliteDirectory = takeDirectory latencySqliteGzFile @@ -146,7 +176,7 @@ readLatenciesSqlite3Gz topology latencySqliteGzFile = hClose latencySqliteHandle readLatencies topology latencySqliteFile -readLatenciesSqlite3 :: BenchTopology -> FilePath -> IO Latencies +readLatenciesSqlite3 :: BenchTopology -> FilePath -> IO LatenciesInMiliseconds readLatenciesSqlite3 topology latencySqliteFile = do let queryAvgTime = "select avg(time) from ping \ @@ -160,9 +190,10 @@ readLatenciesSqlite3 topology latencySqliteFile = do forM_ consumer.producers $ \producerName -> do SQLlite.queryNamed conn queryAvgTime [":consumer" := consumer.name, ":producer" := producerName] >>= \case [] -> error $ printf "missing latency for connection between %s and %s" consumer.name producerName - [[latency :: Double]] -> + [[latencyInMiliseconds :: Double]] -> atomicModifyIORef' latenciesRef $ \latencies -> - (M.adjust (M.insert producerName latency) consumer.name latencies, ()) + let latency = LatencyInMiliseconds latencyInMiliseconds + in (M.adjust (M.insert producerName latency) consumer.name latencies, ()) _otherwise -> error "impossible: SQL query for average returned multiple rows" readIORef latenciesRef @@ -173,374 +204,360 @@ readLatenciesSqlite3 topology latencySqliteFile = do -- latency from Latencies. -------------------------------------------------------------------------------- +newtype ClusterName = ClusterName {unClusterName :: Text} + deriving stock (Show, Eq, Ord) + deriving newtype (FromJSON, ToJSON) + data SimpleNode = SimpleNode { name :: !NodeName , nodeId :: !NodeId - , producers :: !(Map NodeName Latency) - , region :: !RegionName + , producers :: !(Map NodeName LatencyInMiliseconds) + , clusterName :: !(Maybe ClusterName) } - deriving (Show, Generic) + deriving (Eq, Show, Generic) + +simpleNodeOptions :: Options +simpleNodeOptions = defaultOptions{unwrapUnaryRecords = False} instance ToJSON SimpleNode where - toEncoding = - genericToEncoding - defaultOptions - { unwrapUnaryRecords = False - } + toEncoding = genericToEncoding simpleNodeOptions instance FromJSON SimpleNode where - parseJSON = - genericParseJSON - defaultOptions - { unwrapUnaryRecords = False - } + parseJSON = genericParseJSON simpleNodeOptions newtype SimpleTopology = SimpleTopology { nodes :: Vector SimpleNode } - deriving (Show, Generic) + deriving (Eq, Show, Generic) instance ToJSON SimpleTopology where - toEncoding = - genericToEncoding - defaultOptions - { unwrapUnaryRecords = False - } + toEncoding = genericToEncoding simpleNodeOptions instance FromJSON SimpleTopology where - parseJSON = - genericParseJSON - defaultOptions - { unwrapUnaryRecords = False - } - -benchTopologyNodeToSimpleNode :: Latencies -> BenchTopologyNode -> SimpleNode -benchTopologyNodeToSimpleNode latencies benchTopologyNode = - SimpleNode - { name = benchTopologyNode.name - , nodeId = benchTopologyNode.nodeId - , producers = latencies M.! benchTopologyNode.name - , region = benchTopologyNode.region - } + parseJSON = genericParseJSON simpleNodeOptions -benchTopologyToSimpleTopology :: Latencies -> BenchTopology -> SimpleTopology +-- | Convert a 'BenchTopology' to a 'SimpleTopology' using the 'Latencies' read from the latency database. +benchTopologyToSimpleTopology :: LatenciesInMiliseconds -> BenchTopology -> SimpleTopology benchTopologyToSimpleTopology latencies benchTopology = - SimpleTopology{nodes = benchTopologyNodeToSimpleNode latencies <$> benchTopology.coreNodes} + SimpleTopology{nodes = benchTopologyNodeToSimpleNode <$> benchTopology.coreNodes} + where + benchTopologyNodeToSimpleNode :: BenchTopologyNode -> SimpleNode + benchTopologyNodeToSimpleNode benchTopologyNode = + SimpleNode + { name = benchTopologyNode.name + , nodeId = benchTopologyNode.nodeId + , producers = latencies M.! benchTopologyNode.name + , clusterName = regionNameToClusterName <$> benchTopologyNode.region + } +-- | Helper for testing. Partial inverse of 'benchTopologyToSimpleTopology'. +simpleTopologyToBenchTopology :: SimpleTopology -> BenchTopology +simpleTopologyToBenchTopology simpleTopology = + BenchTopology + { coreNodes = simpleNodeToBenchTopologyNode <$> simpleTopology.nodes + } + where + simpleNodeToBenchTopologyNode :: SimpleNode -> BenchTopologyNode + simpleNodeToBenchTopologyNode simpleNode = + BenchTopologyNode + { name = simpleNode.name + , nodeId = simpleNode.nodeId + , org = Nothing + , pools = Nothing + , producers = V.fromList . M.keys $ simpleNode.producers + , region = clusterNameToRegionName <$> simpleNode.clusterName + , stakePool = Nothing + } + +-- | Read a 'SimpleTopology' from a 'BenchTopology' file and a 'Latencies' database. readSimpleTopologyFromBenchTopologyAndLatency :: FilePath -> FilePath -> IO SimpleTopology readSimpleTopologyFromBenchTopologyAndLatency benchTopologyFile latencyFile = do benchTopology <- readBenchTopology benchTopologyFile latencies <- readLatencies benchTopology latencyFile pure $ benchTopologyToSimpleTopology latencies benchTopology +-- | Read a 'SimpleTopology' from a JSON file. readSimpleTopology :: FilePath -> IO SimpleTopology readSimpleTopology = throwDecode <=< BSL.readFile +-- | Write a 'SimpleTopology' to a JSON file. writeSimpleTopology :: FilePath -> SimpleTopology -> IO () writeSimpleTopology simpleTopologyFile = BSL.writeFile simpleTopologyFile . encode +-- | Get the set of cluster names in a 'SimpleTopology'. +clusterSet :: SimpleTopology -> Set (Maybe ClusterName) +clusterSet = S.fromList . map (.clusterName) . V.toList . (.nodes) + +-- | Get the list of unique cluster names in a 'SimpleTopology'. +clusters :: SimpleTopology -> [Maybe ClusterName] +clusters = S.toList . clusterSet + +regionNameToClusterName :: RegionName -> ClusterName +regionNameToClusterName = ClusterName . unRegionName + +clusterNameToRegionName :: ClusterName -> RegionName +clusterNameToRegionName = RegionName . unClusterName + -------------------------------------------------------------------------------- --- General Topology --- --- Abstraction over Bench Topology and Simple Topology +-- Conversion between SimpleTopology and FGL Graph -------------------------------------------------------------------------------- -class - ( HasField "name" node NodeName - , HasField "nodeId" node NodeId - , HasField "region" node RegionName - ) => - Node node edge - | node -> edge - where - outgoingEdges :: node -> Map NodeName edge - - adjacentNodes :: node -> [NodeName] - adjacentNodes = M.keys . outgoingEdges +data SimpleNodeInfo = SimpleNodeInfo + { name :: NodeName + , clusterName :: Maybe ClusterName + } + deriving (Eq, Show) -instance Node BenchTopologyNode () where - outgoingEdges node = - M.fromList [(producerName, ()) | producerName <- V.toList node.producers] +-- | Convert a 'SimpleTopology' to an FGL 'Gr'. +simpleTopologyToGr :: + SimpleTopology -> + Gr SimpleNodeInfo LatencyInMiliseconds +simpleTopologyToGr topology = G.mkGraph graphNodes graphEdges + where + nameToIdMap = + M.fromList + [ (node.name, node.nodeId) + | node <- V.toList topology.nodes + ] + graphNodes = + [ (nodeIdToNode nodeId, SimpleNodeInfo{..}) + | SimpleNode{..} <- V.toList topology.nodes + ] + graphEdges = + [ (producerId, consumerId, latency) + | consumer <- V.toList topology.nodes + , let consumerId = nodeIdToNode consumer.nodeId + , (producerName, latency) <- M.toList consumer.producers + , let producerId = nodeIdToNode $ nameToIdMap M.! producerName + ] -instance Node SimpleNode Latency where - outgoingEdges = (.producers) +-- | Helper for testing. Convert an an FGL 'Gr' to a 'SimpleTopology'. +grToSimpleTopology :: + Gr SimpleNodeInfo LatencyInMiliseconds -> + SimpleTopology +grToSimpleTopology gr = SimpleTopology{nodes} + where + nodes = + V.fromList $ + [ SimpleNode{name, nodeId, producers, clusterName} + | (node, SimpleNodeInfo{..}) <- G.labNodes gr + , let nodeId = nodeToNodeId node + , let producers = M.findWithDefault M.empty name producersMap + ] + producersMap :: Map NodeName (Map NodeName LatencyInMiliseconds) + producersMap = + M.unionsWith (<>) $ + [ M.singleton consumerName (M.singleton producerName latency) + | (producer, consumer, latency) <- G.labEdges gr + , let producerId = nodeToNodeId producer + , let consumerId = nodeToNodeId consumer + , let producerName = nodeIdToNodeNameMap M.! producerId + , let consumerName = nodeIdToNodeNameMap M.! consumerId + ] + nodeIdToNodeNameMap :: Map NodeId NodeName + nodeIdToNodeNameMap = + M.fromList $ + [ (nodeId, name) + | (node, SimpleNodeInfo{..}) <- G.labNodes gr + , let nodeId = nodeToNodeId node + ] -class Node node edge => Topology topology node edge | topology -> node where - allNodes :: topology -> [node] +addNodeNames :: Gr (Maybe ClusterName) b -> Gr SimpleNodeInfo b +addNodeNames = G.gmap (\(inEdges, node, clusterName, outEdges) -> (inEdges, node, SimpleNodeInfo{name = nodeToNodeName node, ..}, outEdges)) - allRegions :: topology -> [RegionName] - allRegions = S.toList . foldr (S.insert . (.region)) S.empty . allNodes +nodeToNodeName :: G.Node -> NodeName +nodeToNodeName = NodeName . T.pack . ("node-" <>) . show @Int -instance Topology BenchTopology BenchTopologyNode () where - allNodes = V.toList . (.coreNodes) +nodeIdToNode :: NodeId -> G.Node +nodeIdToNode = coerce -instance Topology SimpleTopology SimpleNode Latency where - allNodes = V.toList . (.nodes) +nodeToNodeId :: G.Node -> NodeId +nodeToNodeId = coerce -------------------------------------------------------------------------------- --- Conversion to GraphViz Graph +-- Augmentation with Position Information -------------------------------------------------------------------------------- -regionNameToLazyText :: RegionName -> LazyText -regionNameToLazyText = TL.fromStrict . unRegionName - -regionNameToGraphID :: RegionName -> GVTG.GraphID -regionNameToGraphID = GVTG.Str . regionNameToLazyText - --- NOTE: Taken from https://sashamaps.net/docs/resources/20-colors/ -simpleDistinctColors :: [X11Color] -simpleDistinctColors = - cycle - [ Red - , Green - , Yellow - , Blue - , Orange - , Purple - , Cyan - , Magenta - , LimeGreen - , Pink - , Turquoise - , Lavender - , Brown - , Beige - , Maroon - , MintCream - , OliveDrab - , Coral - , Navy - , Gray - , White - , Black - ] +clusterByClusterName :: G.LNode SimpleNodeInfo -> GV.NodeCluster ClusterName (G.LNode SimpleNodeInfo) +clusterByClusterName node@(_, nodeInfo) = case nodeInfo.clusterName of + Nothing -> GV.N node + Just nodeClusterName -> GV.C nodeClusterName (GV.N node) + +clusterNameToLazyText :: ClusterName -> LazyText +clusterNameToLazyText = TL.fromStrict . unClusterName + +clusterNameToGraphID :: ClusterName -> GVTG.GraphID +clusterNameToGraphID = GVTG.Str . clusterNameToLazyText + +defaultParams :: GraphvizParams G.Node SimpleNodeInfo edge ClusterName SimpleNodeInfo +defaultParams = + Params + { isDirected = True + , globalAttributes = [] + , clusterBy = clusterByClusterName + , isDotCluster = const True + , clusterID = clusterNameToGraphID + , fmtCluster = const [] + , fmtNode = const [] + , fmtEdge = const [] + } -toDotGraphAsTorus :: - Topology topology node edge => - topology -> - GVTG.DotGraph NodeName -toDotGraphAsTorus topology = - GVTG.DotGraph True True Nothing . Seq.fromList $ - globalStatements : nodeStatements <> edgeStatements +augmentWithPosition :: + GraphvizParams G.Node SimpleNodeInfo edge ClusterName SimpleNodeInfo -> + WorldDimensions -> + Gr SimpleNodeInfo edge -> + IO (Gr (SimpleNodeInfo, Point) (edge, Path)) +augmentWithPosition params1 worldDimensions gr1 = do + -- Add world dimension and edge IDs + let params2 = + params1 + { fmtEdge = GV.setEdgeIDAttribute params1.fmtEdge + } + let gr2 = GV.addEdgeIDs gr1 + let dg2 = GV.graphToDot params2 gr2 + gr3 <- GV.dotAttributes params2.isDirected gr2 dg2 + let gr4 = G.nemap unsafeUnpackAttributeNode unsafeUnpackAttributeEdge gr3 + let gr5 = rescaleGraph worldDimensions gr4 + pure gr5 + +unsafeUnpackAttributeNode :: GV.AttributeNode a -> (a, Point) +unsafeUnpackAttributeNode (attrs, x) = (x, fromMaybe errorMessage $ maybeGetPoint attrs) where - globalStatements = - GVTG.GA . GVTG.GraphAttrs $ - [ GVAC.Smoothing GVAC.Spring - , GVAC.K 0.5 - , GVAC.RepulsiveForce 2.0 - ] - nodeStatements = - [ GVTG.DN . GVTG.DotNode nodeName $ - [ GVA.style GVA.filled - , GVA.fillColor nodeRegionColor - ] - | node <- allNodes topology - , let nodeName = node.name - , let nodeRegionColor = regionColorMap M.! node.region - ] - edgeStatements = - [ GVTG.DE . GVTG.DotEdge producerName consumerName $ - [ GVA.fillColor producerRegionColor - ] - | consumer <- allNodes topology - , let consumerName = consumer.name - , producerName <- adjacentNodes consumer - , let producerRegionColor = regionColorMap M.! (nodeRegionMap M.! producerName) - ] - nodeRegionMap = - M.fromList [(node.name, node.region) | node <- allNodes topology] - regionColorMap = - M.fromList $ zip (allRegions topology) simpleDistinctColors - -toDotGraphByRegion :: - Topology topology node edge => - topology -> - GVTG.DotGraph NodeName -toDotGraphByRegion topology = - GVTG.DotGraph True True Nothing . Seq.fromList $ - graphAttributes : subGraphStatements <> edgeStatements + errorMessage = error $ "post-condition of dotizeGraph violated; yielded attributes " <> show attrs + maybeGetPoint :: GV.Attributes -> Maybe Point + maybeGetPoint = fmap fst . uncons . mapMaybe maybeToPoint + where + maybeToPoint :: GV.Attribute -> Maybe Point + maybeToPoint (GV.Pos (GV.PointPos point)) = Just (pointToPoint point) + maybeToPoint _ = Nothing + +unsafeUnpackAttributeEdge :: GV.AttributeEdge a -> (a, Path) +unsafeUnpackAttributeEdge (attrs, x) = (x, fromMaybe errorMessage $ maybeGetPath attrs) where - graphAttributes = - GVTG.GA . GVTG.GraphAttrs $ - [] - subGraphStatements = - [ GVTG.SG . GVTG.DotSG True (Just subGraphId) . Seq.fromList $ - subGraphAttributtes : subGraphNodeStatements <> subGraphEdgeStatements - | regionName <- allRegions topology - , let subGraphId = regionNameToGraphID regionName - , let subGraphAttributtes = - GVTG.GA . GVTG.GraphAttrs $ - [ GVA.textLabel (regionNameToLazyText regionName) - ] - , let subGraphNodeStatements = - [ GVTG.DN . GVTG.DotNode nodeName $ - [ GVA.style GVA.filled - , GVA.fillColor nodeRegionColor - ] - | node <- allNodes topology - , let nodeName = node.name - , let nodeRegionName = node.region - , nodeRegionName == regionName - , let nodeRegionColor = regionColorMap M.! nodeRegionName - ] - , let subGraphEdgeStatements = - [ GVTG.DE . GVTG.DotEdge producerName consumerName $ - [ GVA.fillColor producerRegionColor - ] - | consumer <- allNodes topology - , let consumerName = consumer.name - , let consumerRegionName = consumer.region - , consumerRegionName == regionName - , producerName <- adjacentNodes consumer - , let producerRegionName = nodeRegionMap M.! producerName - , producerRegionName == regionName - , let producerRegionColor = regionColorMap M.! producerRegionName - ] - ] - edgeStatements = - [ GVTG.DE . GVTG.DotEdge producerName consumerName $ - [ GVA.fillColor producerRegionColor - ] - | consumer <- allNodes topology - , let consumerName = consumer.name - , let consumerRegionName = consumer.region - , producerName <- adjacentNodes consumer - , let producerRegionName = nodeRegionMap M.! producerName - , let producerRegionColor = regionColorMap M.! producerRegionName - , consumerRegionName /= producerRegionName - ] - nodeRegionMap = - M.fromList [(node.name, node.region) | node <- allNodes topology] - regionColorMap = - M.fromList $ zip (allRegions topology) simpleDistinctColors + errorMessage = error $ "post-condition of dotizeGraph violated; yielded attributes " <> show attrs + maybeGetPath :: GV.Attributes -> Maybe Path + maybeGetPath = fmap fst . uncons . mapMaybe maybeToPath + where + maybeToPath :: GV.Attribute -> Maybe Path + maybeToPath (GV.Pos (GV.SplinePos splines)) + | null splines = Nothing + | otherwise = Just $ mconcat (splineToPath <$> splines) + maybeToPath _ = Nothing + +pointToPoint :: GV.Point -> Point +pointToPoint (GV.Point x y _z _3d) = Point x y -renderTopologyAsTorus :: - Topology topology node edge => FilePath -> topology -> IO () -renderTopologyAsTorus outputFile topology = - void $ GVC.runGraphvizCommand GVC.Sfdp (toDotGraphAsTorus topology) GVC.Png outputFile +splineToPath :: GV.Spline -> Path +splineToPath (GV.Spline maybeEnd maybeStart points) = + Path . map pointToPoint . concat $ [maybeToList maybeStart, points, maybeToList maybeEnd] -renderTopologyByRegion :: - Topology topology node edge => FilePath -> topology -> IO () -renderTopologyByRegion outputFile topology = - void $ GVC.runGraphvizCommand GVC.Dot (toDotGraphByRegion topology) GVC.Png outputFile +rescaleGraph :: WorldDimensions -> Gr (node, Point) (edge, Path) -> Gr (node, Point) (edge, Path) +rescaleGraph (w, h) gr = G.nmap (second rescalePoint) gr + where + rescalePoint p = Point (rescaleX p._1) (rescaleY p._2) + where + ps0 = fmap (snd . snd) (G.labNodes gr) + rescaleX x = xPad + (x - x0l) / w0 * (w - 2 * xPad) + where + xPad = 0.05 * w + (x0l, x0u) = (minimum &&& maximum) (fmap _1 ps0) + w0 = x0u - x0l + rescaleY y = yPad + (y - y0l) / h0 * (h - 2 * yPad) + where + yPad = 0.05 * h + (y0l, y0u) = (minimum &&& maximum) (fmap _2 ps0) + h0 = y0u - y0l + +forgetPoints :: Gr (a, Point) b -> Gr a b +forgetPoints = G.nmap fst + +forgetPaths :: Gr a (b, Path) -> Gr a b +forgetPaths = G.emap fst + +forgetPosition :: Gr (a, Point) (b, Path) -> Gr a b +forgetPosition = forgetPoints . forgetPaths + +forgetSimpleNodeInfo :: Gr (SimpleNodeInfo, a) b -> Gr a b +forgetSimpleNodeInfo = G.nemap snd id -------------------------------------------------------------------------------- --- Conversion to FGL Graph +-- Conversion between FGL Graph and P2PTopography -------------------------------------------------------------------------------- -toGraph :: - Topology topology node edge => - topology -> - Gr node edge -toGraph topology = G.mkGraph graphNodes graphEdges +latencyFromSecondsToMiliseconds :: + Gr a Latency -> + Gr a LatencyInMiliseconds +latencyFromSecondsToMiliseconds = + G.emap (LatencyInMiliseconds . (* 1000.0)) + +latencyFromMilisecondsToSeconds :: + Gr a LatencyInMiliseconds -> + Gr a Latency +latencyFromMilisecondsToSeconds = + G.emap ((/ 1000.0) . unLatencyInMiliseconds) + +grToP2PTopography :: + WorldShape -> + Gr Point Latency -> + P2PTopography +grToP2PTopography p2pWorldShape gr = P2PTopography{..} where - nameToIdMap = + nodeInfoMap = M.fromList - [ (node.name, node.nodeId) - | node <- allNodes topology + [ (n, nodeInfo) + | (n, nodeInfo) <- G.labNodes gr + ] + edgeInfoMap = + M.fromList + [ ((n1, n2), edgeInfo) + | (n1, n2, edgeInfo) <- G.labEdges gr + ] + p2pNodes = + M.fromList + [ (nodeToNodeId node, point) + | (node, point) <- M.assocs nodeInfoMap + ] + p2pLinks = + M.fromList + [ ((nodeToNodeId node1, nodeToNodeId node2), latencyInseconds) + | ((node1, node2), latencyInseconds) <- M.assocs edgeInfoMap ] - graphNodes = - [ (consumerId, consumer) - | consumer <- allNodes topology - , let consumerId = coerce consumer.nodeId - ] - graphEdges = - [ (consumerId, producerId, producerLatency) - | consumer <- allNodes topology - , let consumerId = coerce consumer.nodeId - , (producerName, producerLatency) <- M.toList (outgoingEdges consumer) - , let producerId = coerce $ nameToIdMap M.! producerName - ] -toGraphWithPositionInformation :: - forall topology node edge. - Topology topology node edge => - WorldDimensions -> - topology -> - IO (Gr (node, Point) (edge, Path)) -toGraphWithPositionInformation (w, h) topology = do - let gr0 = toGraph topology - let gr1 = GV.dotizeGraph params gr0 - let gr2 = G.nemap unsafeUnpackAttributeNode unsafeUnpackAttributeEdge gr1 - let gr3 = rescale gr2 - pure gr3 +p2pTopologyToGr :: + P2PTopography -> + Gr Point Latency +p2pTopologyToGr P2PTopography{..} = G.mkGraph nodes edges where - params = - GV.defaultParams - { globalAttributes = [GV.GraphAttrs [GVAC.Layout GVC.Neato]] - , clusterBy = clusterByRegion - , clusterID = regionNameToGraphID - } + nodes = + [ (nodeIdToNode nodeId, point) + | (nodeId, point) <- M.assocs p2pNodes + ] + edges = + [ (nodeIdToNode nodeId1, nodeIdToNode nodeId2, latencyInSeconds) + | ((nodeId1, nodeId2), latencyInSeconds) <- M.assocs p2pLinks + ] - rescale :: Gr (node, Point) (edge, Path) -> Gr (node, Point) (edge, Path) - rescale gr = G.nmap (second rescalePoint) gr - where - rescalePoint p = Point (rescaleX p._1) (rescaleY p._2) - where - ps0 = fmap (snd . snd) (G.labNodes gr) - rescaleX x = xPad + (x - x0l) / w0 * (w - 2 * xPad) - where - xPad = 0.05 * w - (x0l, x0u) = (minimum &&& maximum) (fmap _1 ps0) - w0 = x0u - x0l - rescaleY y = yPad + (y - y0l) / h0 * (h - 2 * yPad) - where - yPad = 0.05 * h - (y0l, y0u) = (minimum &&& maximum) (fmap _2 ps0) - h0 = y0u - y0l - - unsafeUnpackAttributeNode :: GV.AttributeNode a -> (a, Point) - unsafeUnpackAttributeNode ([GVAC.Pos (GVAC.PointPos point)], x) = (x, unsafeToPoint point) - unsafeUnpackAttributeNode _ = error "post-condition of dotizeGraph violated" - - unsafeToPoint :: GVAC.Point -> Point - unsafeToPoint (GVAC.Point x y _z False) = Point x y - unsafeToPoint _ = error "post-condition of dotizeGraph violated" - - unsafeUnpackAttributeEdge :: GV.AttributeEdge a -> (a, Path) - unsafeUnpackAttributeEdge ([GVAC.Pos (GVAC.SplinePos splines)], x) = (x, unsafeToPath splines) - unsafeUnpackAttributeEdge _ = error "post-condition of dotizeGraph violated" - - unsafeToPath :: [GVAC.Spline] -> Path - unsafeToPath = Path . concatMap toPoints - where - toPoints :: GVAC.Spline -> [Point] - toPoints (GVAC.Spline maybeEnd maybeStart points) = - fmap unsafeToPoint . concat $ - [ maybeToList maybeStart - , points - , maybeToList maybeEnd - ] - - clusterByRegion :: G.LNode node -> GV.NodeCluster RegionName (G.LNode node) - clusterByRegion lnode@(_, node) = GV.C node.region (GV.N lnode) - -toP2PTopography :: - WorldDimensions -> - SimpleTopology -> +readP2PTopography :: + GraphvizParams G.Node SimpleNodeInfo LatencyInMiliseconds ClusterName SimpleNodeInfo -> + WorldShape -> + FilePath -> IO P2PTopography -toP2PTopography worldDimensions topology = do - graphWithInfo <- toGraphWithPositionInformation worldDimensions topology - let nodeInfoMap = M.fromList [(n, nodeInfo) | (n, nodeInfo) <- G.labNodes graphWithInfo] - let edgeInfoMap = M.fromList [((n1, n2), edgeInfo) | (n1, n2, edgeInfo) <- G.labEdges graphWithInfo] - let p2pNodes = - M.fromList - [ (node.nodeId, point) - | (node, point) <- M.elems nodeInfoMap - ] - let p2pLinks = - M.fromList - [ ((node1.nodeId, node2.nodeId), latency) - | ((n1, n2), (latency, _path)) <- M.assocs edgeInfoMap - , let (node1, _point1) = nodeInfoMap M.! n1 - , let (node2, _point2) = nodeInfoMap M.! n2 - ] - let p2pWorldShape = WorldShape{worldIsCylinder = True, ..} - pure P2PTopography{..} - -readP2PTopography :: WorldDimensions -> FilePath -> IO P2PTopography -readP2PTopography worldDimensions simpleTopologyFile = do +readP2PTopography params worldShape@WorldShape{..} simpleTopologyFile = do simpleTopology <- readSimpleTopology simpleTopologyFile - toP2PTopography worldDimensions simpleTopology + let gr = simpleTopologyToGr simpleTopology + grWithPosition <- forgetSimpleNodeInfo . forgetPaths <$> augmentWithPosition params worldDimensions gr + pure $ grToP2PTopography worldShape . latencyFromMilisecondsToSeconds $ grWithPosition + +readP2PTopographyFromBenchTopologyAndLatency :: + GraphvizParams G.Node SimpleNodeInfo LatencyInMiliseconds ClusterName SimpleNodeInfo -> + WorldShape -> + FilePath -> + FilePath -> + IO P2PTopography +readP2PTopographyFromBenchTopologyAndLatency params worldShape@WorldShape{..} benchTopologyFile latencyFile = do + simpleTopology <- readSimpleTopologyFromBenchTopologyAndLatency benchTopologyFile latencyFile + let gr = simpleTopologyToGr simpleTopology + grWithPosition <- forgetSimpleNodeInfo . forgetPaths <$> augmentWithPosition params worldDimensions gr + pure $ grToP2PTopography worldShape . latencyFromMilisecondsToSeconds $ grWithPosition diff --git a/simulation/test/Main.hs b/simulation/test/Main.hs new file mode 100644 index 00000000..e2ac5302 --- /dev/null +++ b/simulation/test/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import Test.Tasty (defaultMain, testGroup) +import qualified Test.Topology + +main :: IO () +main = + defaultMain . testGroup "ouroboros-leios-sim" $ + [ Test.Topology.tests + ] diff --git a/simulation/test/Test/Topology.hs b/simulation/test/Test/Topology.hs new file mode 100644 index 00000000..aebf8c2f --- /dev/null +++ b/simulation/test/Test/Topology.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Topology where + +import Data.Bifunctor (Bifunctor (..)) +import Data.Graph.Inductive (Gr) +import qualified Data.Graph.Inductive as G +import Data.Graph.Inductive.Arbitrary (NoLoops (..), NoMultipleEdges (..), SimpleGraph) +import qualified Data.Text as T +import P2P (Latency, P2PTopography (..), P2PTopographyCharacteristics (..), genArbitraryP2PTopography) +import Paths_ouroboros_leios_sim (getDataFileName) +import SimTypes (WorldDimensions, WorldShape (..)) +import System.Directory (doesFileExist) +import Test.QuickCheck (Arbitrary (..), Gen, NonNegative (..), Positive (..), Property, ioProperty) +import Test.QuickCheck.Gen (Gen (..)) +import Test.QuickCheck.Random (QCGen (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, testCase) +import Test.Tasty.QuickCheck (Small (..), testProperty) +import Topology (ClusterName (..), LatencyInMiliseconds (..), NodeName (..), addNodeNames, augmentWithPosition, benchTopologyToSimpleTopology, defaultParams, forgetPaths, forgetPoints, forgetPosition, forgetSimpleNodeInfo, forgetUnusedFieldsInBenchTopology, grToP2PTopography, grToSimpleTopology, p2pTopologyToGr, readBenchTopology, readLatenciesSqlite3Gz, readSimpleTopologyFromBenchTopologyAndLatency, simpleTopologyToBenchTopology, simpleTopologyToGr, sortBenchTopology) + +tests :: TestTree +tests = + testGroup + "Topology" + [ testCase "test_benchTopologyToSimpleTopologyPreservesTopology" test_benchTopologyToSimpleTopologyPreservesTopology + , testCase "test_benchTopologyIsConnected" test_benchTopologyIsConnected + , testProperty "prop_grToSimpleTopologyPreservesTopology" prop_grToSimpleTopologyPreservesTopology + , testProperty "prop_augmentWithPositionPreservesTopology" prop_augmentWithPositionPreservesTopology + , testProperty "prop_grToP2PTopographyPreservesTopology" prop_grToP2PTopographyPreservesTopology + -- NOTE: Disabled, as `genArbitraryP2PTopography` appears to loop for certain inputs. + -- , testProperty "prop_p2pTopographyToGrPreservesTopology" prop_p2pTopographyToGrPreservesTopology + ] + +-------------------------------------------------------------------------------- +-- Conversion between BenchTopology and SimpleTopology +-------------------------------------------------------------------------------- + +-- | Test that the conversion between BenchTopology and SimpleTopology preserves the topology. +test_benchTopologyToSimpleTopologyPreservesTopology :: Assertion +test_benchTopologyToSimpleTopologyPreservesTopology = do + -- Find test/data/BenchTopology/topology-dense-52.json + benchTopologyFile <- getDataFileName "test/data/BenchTopology/topology-dense-52.json" + doesBenchTopologyFileExist <- doesFileExist benchTopologyFile + assertBool "File data/BenchTopology/topology-dense-52.json does not exist" doesBenchTopologyFileExist + -- Find test/data/BenchTopology/latency.sqlite3.gz + latenciesSqlite3GzFile <- getDataFileName "test/data/BenchTopology/latency.sqlite3.gz" + doesLatenciesFileExit <- doesFileExist latenciesSqlite3GzFile + assertBool "File data/BenchTopology/latency.sqlite3.gz does not exist" doesLatenciesFileExit + -- Read bench topology + benchTopology1 <- sortBenchTopology . forgetUnusedFieldsInBenchTopology <$> readBenchTopology benchTopologyFile + -- Read latencies + latencies <- readLatenciesSqlite3Gz benchTopology1 latenciesSqlite3GzFile + -- Test conversion to/from simple topology + let simpleTopology = benchTopologyToSimpleTopology latencies benchTopology1 + let benchTopology2 = sortBenchTopology . simpleTopologyToBenchTopology $ simpleTopology + assertEqual "Conversion to/from SimpleTopology does not preserve topology" benchTopology1 benchTopology2 + +test_benchTopologyIsConnected :: Assertion +test_benchTopologyIsConnected = do + -- Find test/data/BenchTopology/topology-dense-52.json + benchTopologyFile <- getDataFileName "test/data/BenchTopology/topology-dense-52.json" + doesBenchTopologyFileExist <- doesFileExist benchTopologyFile + assertBool "File data/BenchTopology/topology-dense-52.json does not exist" doesBenchTopologyFileExist + -- Find test/data/BenchTopology/latency.sqlite3.gz + latenciesSqlite3GzFile <- getDataFileName "test/data/BenchTopology/latency.sqlite3.gz" + doesLatenciesFileExit <- doesFileExist latenciesSqlite3GzFile + assertBool "File data/BenchTopology/latency.sqlite3.gz does not exist" doesLatenciesFileExit + -- Read bench topology + benchTopology1 <- sortBenchTopology . forgetUnusedFieldsInBenchTopology <$> readBenchTopology benchTopologyFile + -- Read latencies + latencies <- readLatenciesSqlite3Gz benchTopology1 latenciesSqlite3GzFile + -- Test conversion to/from simple topology + let simpleTopology = benchTopologyToSimpleTopology latencies benchTopology1 + let gr = simpleTopologyToGr simpleTopology + assertBool "BenchTopology is not connected" (G.isConnected gr) + +-------------------------------------------------------------------------------- +-- Conversion between SimpleTopology and FGL Graph +-------------------------------------------------------------------------------- + +-- | Test that the conversion between SimpleTopology and FGL Graphs preserves the topology. +prop_grToSimpleTopologyPreservesTopology :: SimpleGraph Gr (Maybe ClusterName) LatencyInMiliseconds -> Bool +prop_grToSimpleTopologyPreservesTopology gr = do + let gr1 = addNodeNames . nmeGraph . looplessGraph $ gr + let gr2 = simpleTopologyToGr . grToSimpleTopology $ gr1 + gr1 == gr2 + +-------------------------------------------------------------------------------- +-- Augmentation with Position Information +-------------------------------------------------------------------------------- + +prop_augmentWithPositionPreservesTopology :: + WorldDimensions -> + SimpleGraph Gr (Maybe ClusterName) LatencyInMiliseconds -> + Property +prop_augmentWithPositionPreservesTopology wordDimensions gr = ioProperty $ do + let gr1 = addNodeNames . nmeGraph . looplessGraph $ gr + gr2 <- augmentWithPosition defaultParams wordDimensions gr1 + let gr3 = forgetPosition gr2 + pure $ gr1 == gr3 + +-------------------------------------------------------------------------------- +-- Conversion between FGL Graph and P2P Topography +-------------------------------------------------------------------------------- + +-- | Test that the conversion between SimpleTopology and FGL Graphs preserves the topology. +prop_grToP2PTopographyPreservesTopology :: + WorldShape -> + SimpleGraph Gr (Maybe ClusterName) Latency -> + Property +prop_grToP2PTopographyPreservesTopology worldShape@WorldShape{..} gr = ioProperty $ do + let gr1 = addNodeNames . nmeGraph . looplessGraph $ gr + gr2 <- forgetSimpleNodeInfo . forgetPaths <$> augmentWithPosition defaultParams worldDimensions gr1 + let gr3 = grToP2PTopography worldShape gr2 + let gr4 = p2pTopologyToGr gr3 + let forgetPoints = G.nmap (const ()) + pure $ forgetPoints gr2 == forgetPoints gr4 + +-- | Test that the conversion between SimpleTopology and FGL Graphs preserves the topology. +prop_p2pTopographyToGrPreservesTopology :: + P2PTopography -> + Bool +prop_p2pTopographyToGrPreservesTopology gr1@P2PTopography{..} = do + let gr2 = p2pTopologyToGr gr1 + let gr3 = grToP2PTopography p2pWorldShape gr2 + gr1 == gr3 + +-------------------------------------------------------------------------------- +-- Instances +-------------------------------------------------------------------------------- + +instance Arbitrary ClusterName where + arbitrary :: Gen ClusterName + arbitrary = ClusterName . T.pack . ("cluster-" <>) . show @Int . getSmall . getNonNegative <$> arbitrary + +instance Arbitrary LatencyInMiliseconds where + arbitrary :: Gen LatencyInMiliseconds + arbitrary = LatencyInMiliseconds . getPositive <$> arbitrary + +instance Arbitrary WorldShape where + arbitrary :: Gen WorldShape + arbitrary = do + worldDimensions <- bimap getPositive getPositive <$> arbitrary + worldIsCylinder <- arbitrary + pure $ WorldShape{..} + +instance Arbitrary P2PTopographyCharacteristics where + arbitrary :: Gen P2PTopographyCharacteristics + arbitrary = do + p2pWorldShape <- arbitrary + p2pNumNodes <- getPositive <$> arbitrary + p2pNodeLinksClose <- getSmall . getPositive <$> arbitrary + p2pNodeLinksRandom <- getSmall . getPositive <$> arbitrary + pure P2PTopographyCharacteristics{..} + +instance Arbitrary P2PTopography where + arbitrary :: Gen P2PTopography + arbitrary = arbitraryP2PTopography =<< arbitrary + where + -- TODO: This appears to loop for some inputs. + arbitraryP2PTopography :: P2PTopographyCharacteristics -> Gen P2PTopography + arbitraryP2PTopography p2pTopographyCharacteristics = MkGen $ \gen size -> + genArbitraryP2PTopography p2pTopographyCharacteristics gen diff --git a/simulation/test/data b/simulation/test/data new file mode 120000 index 00000000..e67b4559 --- /dev/null +++ b/simulation/test/data @@ -0,0 +1 @@ +../../data \ No newline at end of file