voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

ghc-9.6.6 + updated db-pipe

This commit is contained in:
Dmitry Zuikov 2024-09-25 11:27:29 +03:00
parent c240b8ad9e
commit 835c01bfaa
48 changed files with 242 additions and 408 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

395
flake.lock
View File

@ -1,47 +1,87 @@
{
"nodes": {
"bytestring-mmap": {
"flake": false,
"locked": {
"lastModified": 1727193872,
"narHash": "sha256-L39kMCMry/BNJngt0+yvSIMnJJzWR9ZoyXbEyniEfwU=",
"owner": "ivanovs-4",
"repo": "bytestring-mmap",
"rev": "f43e5e06718ed904487f17e7725c12098773c12f",
"type": "github"
},
"original": {
"owner": "ivanovs-4",
"repo": "bytestring-mmap",
"type": "github"
}
},
"db-pipe": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils",
"haskell-flake-utils": [
"haskell-flake-utils"
],
"nixpkgs": [
"nixpkgs"
]
},
"locked": {
"lastModified": 1713359411,
"narHash": "sha256-BzOZ6xU+Li5nIe71Wy4p+lOEQlYK/e94T0gBcP8IKgE=",
"ref": "generic-sql",
"rev": "03635c54b2e2bd809ec1196bc9082447279f6f24",
"lastModified": 1727252661,
"narHash": "sha256-8vmgF0Atw+m7a+2Wmlnwjjyw8nSYv0QMT+zN9R3DljQ=",
"ref": "refs/heads/master",
"rev": "8b614540a7f30f0227cb18ef2ad4c8d84db4a75c",
"revCount": 9,
"type": "git",
"url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
},
"original": {
"ref": "generic-sql",
"type": "git",
"url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
}
},
"db-pipe_2": {
"inputs": {
"haskell-flake-utils": [
"lsm",
"haskell-flake-utils"
],
"nixpkgs": [
"lsm",
"nixpkgs"
]
},
"locked": {
"lastModified": 1713519608,
"narHash": "sha256-MBBsIdK1am/usgdBYr6ZoKm1pwv7u9ujS/tiNRrn0m8=",
"ref": "refs/heads/master",
"rev": "b755977dd737ff367c7eb19efd9e273d1bd37ed7",
"revCount": 8,
"type": "git",
"url": "http://git.hbs2/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
},
"original": {
"type": "git",
"url": "http://git.hbs2/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
}
},
"fixme": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils_2",
"nixpkgs": [
"nixpkgs"
],
"nixpkgs": "nixpkgs",
"suckless-conf": "suckless-conf"
},
"locked": {
"lastModified": 1697356303,
"narHash": "sha256-hJbJZtx7gdcXaKL8n5J8b/eVyoYe9VxM+037ZK7q8Gw=",
"ref": "refs/heads/master",
"rev": "e9b1dcfd78dc766a2255a8125c14b24f0d728c0e",
"revCount": 139,
"type": "git",
"url": "https://git.hbs2.net/Fujv1Uy4W5d9Z7REEArMxbXSJ8nLLn4dYuvaAs8b86hr"
"lastModified": 1714707469,
"narHash": "sha256-uL3j7NmCWADN0rIyVr3bv0JFMPgYgrnb1wiJW5tZ9jU=",
"owner": "voidlizard",
"repo": "fixme",
"rev": "51485aa169c7b2040b6e2b8d096f38ed77146482",
"type": "github"
},
"original": {
"type": "git",
"url": "https://git.hbs2.net/Fujv1Uy4W5d9Z7REEArMxbXSJ8nLLn4dYuvaAs8b86hr"
"owner": "voidlizard",
"repo": "fixme",
"type": "github"
}
},
"flake-utils": {
@ -89,109 +129,21 @@
"type": "github"
}
},
"flake-utils_4": {
"locked": {
"lastModified": 1644229661,
"narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"flake-utils_5": {
"locked": {
"lastModified": 1644229661,
"narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"flake-utils_6": {
"locked": {
"lastModified": 1644229661,
"narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"flake-utils_7": {
"locked": {
"lastModified": 1644229661,
"narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"flake-utils_8": {
"locked": {
"lastModified": 1644229661,
"narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"flake-utils_9": {
"locked": {
"lastModified": 1644229661,
"narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"fuzzy": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils_4",
"haskell-flake-utils": [
"haskell-flake-utils"
],
"nixpkgs": [
"nixpkgs"
]
},
"locked": {
"lastModified": 1715919110,
"narHash": "sha256-moioa3ixAZb0y/xxyxUVjSvXoSiDGXy/vAx6B70d2yM=",
"lastModified": 1727197542,
"narHash": "sha256-BF9Xd2fa8L5Xju9NTaoUjmzUEJfrRMMKULYQieBjbKo=",
"ref": "refs/heads/master",
"rev": "5a55c22750589b357e50b759d2a754df058446d6",
"revCount": 40,
"rev": "a834b152e29d632c816eefe117036e5d9330bd03",
"revCount": 43,
"type": "git",
"url": "https://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
},
@ -200,39 +152,21 @@
"url": "https://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
}
},
"fuzzy_2": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils_8",
"nixpkgs": "nixpkgs_2"
},
"locked": {
"lastModified": 1715918584,
"narHash": "sha256-moioa3ixAZb0y/xxyxUVjSvXoSiDGXy/vAx6B70d2yM=",
"rev": "831879978213a1aed15ac70aa116c33bcbe964b8",
"revCount": 63,
"type": "git",
"url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?tag=0.1.3.1"
},
"original": {
"rev": "831879978213a1aed15ac70aa116c33bcbe964b8",
"type": "git",
"url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?tag=0.1.3.1"
}
},
"haskell-flake-utils": {
"inputs": {
"flake-utils": "flake-utils"
},
"locked": {
"lastModified": 1698938553,
"narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=",
"lastModified": 1707809372,
"narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=",
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"rev": "19b273b5dc401a0a565e7f75cf50a593871b80c9",
"rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2",
"type": "github"
},
"original": {
"owner": "ivanovs-4",
"ref": "master",
"repo": "haskell-flake-utils",
"type": "github"
}
@ -273,119 +207,11 @@
"type": "github"
}
},
"haskell-flake-utils_4": {
"inputs": {
"flake-utils": "flake-utils_4"
},
"locked": {
"lastModified": 1707809372,
"narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=",
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2",
"type": "github"
},
"original": {
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"type": "github"
}
},
"haskell-flake-utils_5": {
"inputs": {
"flake-utils": "flake-utils_5"
},
"locked": {
"lastModified": 1698938553,
"narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=",
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"rev": "19b273b5dc401a0a565e7f75cf50a593871b80c9",
"type": "github"
},
"original": {
"owner": "ivanovs-4",
"ref": "master",
"repo": "haskell-flake-utils",
"type": "github"
}
},
"haskell-flake-utils_6": {
"inputs": {
"flake-utils": "flake-utils_6"
},
"locked": {
"lastModified": 1672412555,
"narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
"type": "github"
},
"original": {
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
"type": "github"
}
},
"haskell-flake-utils_7": {
"inputs": {
"flake-utils": "flake-utils_7"
},
"locked": {
"lastModified": 1698938553,
"narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=",
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"rev": "19b273b5dc401a0a565e7f75cf50a593871b80c9",
"type": "github"
},
"original": {
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"type": "github"
}
},
"haskell-flake-utils_8": {
"inputs": {
"flake-utils": "flake-utils_8"
},
"locked": {
"lastModified": 1707809372,
"narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=",
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2",
"type": "github"
},
"original": {
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"type": "github"
}
},
"haskell-flake-utils_9": {
"inputs": {
"flake-utils": "flake-utils_9"
},
"locked": {
"lastModified": 1672412555,
"narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
"type": "github"
},
"original": {
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"type": "github"
}
},
"hspup": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils_6",
"haskell-flake-utils": [
"haskell-flake-utils"
],
"nixpkgs": [
"nixpkgs"
]
@ -406,17 +232,21 @@
},
"lsm": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils_7",
"db-pipe": "db-pipe_2",
"fixme": "fixme",
"haskell-flake-utils": [
"haskell-flake-utils"
],
"nixpkgs": [
"nixpkgs"
]
},
"locked": {
"lastModified": 1711033804,
"narHash": "sha256-z9cb5yuWfuZmGukxsZebXhc6KUZoPVT60oXxQ6j6ML8=",
"lastModified": 1715418443,
"narHash": "sha256-uhc9bf6myVz0Nx8Aoyc6/03FBQVyMqa78ByZzlrvKvY=",
"ref": "refs/heads/master",
"rev": "0e8286a43da5b9e54c4f3ecdb994173fe77351db",
"revCount": 26,
"rev": "e9aab0bcb79f4c811b5fb795f878b38874218809",
"revCount": 57,
"type": "git",
"url": "https://git.hbs2.net/5BCaH95cWsVKBmWaDNLWQr2umxzzT5kqRRKNTm2J15Ls"
},
@ -427,11 +257,27 @@
},
"nixpkgs": {
"locked": {
"lastModified": 1707451808,
"narHash": "sha256-UwDBUNHNRsYKFJzyTMVMTF5qS4xeJlWoeyJf+6vvamU=",
"lastModified": 1697009197,
"narHash": "sha256-viVRhBTFT8fPJTb1N3brQIpFZnttmwo3JVKNuWRVc3s=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "01441e14af5e29c9d27ace398e6dd0b293e25a54",
"type": "github"
},
"original": {
"owner": "NixOS",
"ref": "nixpkgs-unstable",
"repo": "nixpkgs",
"type": "github"
}
},
"nixpkgs_2": {
"locked": {
"lastModified": 1727089097,
"narHash": "sha256-ZMHMThPsthhUREwDebXw7GX45bJnBCVbfnH1g5iuSPc=",
"owner": "nixos",
"repo": "nixpkgs",
"rev": "442d407992384ed9c0e6d352de75b69079904e4e",
"rev": "568bfef547c14ca438c56a0bece08b8bb2b71a9c",
"type": "github"
},
"original": {
@ -441,31 +287,15 @@
"type": "github"
}
},
"nixpkgs_2": {
"locked": {
"lastModified": 1707451808,
"narHash": "sha256-UwDBUNHNRsYKFJzyTMVMTF5qS4xeJlWoeyJf+6vvamU=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "442d407992384ed9c0e6d352de75b69079904e4e",
"type": "github"
},
"original": {
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "442d407992384ed9c0e6d352de75b69079904e4e",
"type": "github"
}
},
"root": {
"inputs": {
"bytestring-mmap": "bytestring-mmap",
"db-pipe": "db-pipe",
"fixme": "fixme",
"fuzzy": "fuzzy",
"haskell-flake-utils": "haskell-flake-utils_5",
"haskell-flake-utils": "haskell-flake-utils",
"hspup": "hspup",
"lsm": "lsm",
"nixpkgs": "nixpkgs",
"nixpkgs": "nixpkgs_2",
"saltine": "saltine",
"suckless-conf": "suckless-conf_2"
}
@ -491,6 +321,7 @@
"inputs": {
"haskell-flake-utils": "haskell-flake-utils_3",
"nixpkgs": [
"lsm",
"fixme",
"nixpkgs"
]
@ -511,22 +342,26 @@
},
"suckless-conf_2": {
"inputs": {
"fuzzy": "fuzzy_2",
"haskell-flake-utils": "haskell-flake-utils_9",
"fuzzy": [
"fuzzy"
],
"haskell-flake-utils": [
"haskell-flake-utils"
],
"nixpkgs": [
"nixpkgs"
]
},
"locked": {
"lastModified": 1724740155,
"narHash": "sha256-dHAWLoQ0uZ2FckV/93qbXo6aYCTY+jARXiiTgUt6fcA=",
"rev": "b6c5087312e6c09e5c27082da47846f377f73756",
"revCount": 38,
"lastModified": 1727200798,
"narHash": "sha256-esabG5zoApNLbirx0mCj1+3ZPFU9Ckod9wSn9MHc0mo=",
"ref": "refs/heads/master",
"rev": "ff6f1a2e053005a52af5c7375fb66e8bb89bce2d",
"revCount": 40,
"type": "git",
"url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"
},
"original": {
"rev": "b6c5087312e6c09e5c27082da47846f377f73756",
"type": "git",
"url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"
}

45
flake.nix
View File

@ -8,30 +8,37 @@ inputs = {
haskell-flake-utils.url = "github:ivanovs-4/haskell-flake-utils/master";
hspup.url = "github:voidlizard/hspup";
hspup.inputs.nixpkgs.follows = "nixpkgs";
hspup.inputs.haskell-flake-utils.follows = "haskell-flake-utils";
fixme.url = "git+https://git.hbs2.net/Fujv1Uy4W5d9Z7REEArMxbXSJ8nLLn4dYuvaAs8b86hr";
#fixme.url = "git+file:///home/dmz/w/fixme?ref=dev-0.2";
fixme.inputs.nixpkgs.follows = "nixpkgs";
suckless-conf.url =
"git+https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ?rev=b6c5087312e6c09e5c27082da47846f377f73756";
suckless-conf.url = "git+https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ";
suckless-conf.inputs.nixpkgs.follows = "nixpkgs";
suckless-conf.inputs.fuzzy.follows = "fuzzy";
suckless-conf.inputs.haskell-flake-utils.follows = "haskell-flake-utils";
db-pipe.url = "git+https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft?ref=generic-sql";
db-pipe.url = "git+https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft";
db-pipe.inputs.nixpkgs.follows = "nixpkgs";
db-pipe.inputs.haskell-flake-utils.follows = "haskell-flake-utils";
lsm.url = "git+https://git.hbs2.net/5BCaH95cWsVKBmWaDNLWQr2umxzzT5kqRRKNTm2J15Ls";
lsm.inputs.nixpkgs.follows = "nixpkgs";
lsm.inputs.haskell-flake-utils.follows = "haskell-flake-utils";
# fuzzy.url = "git+file:/home/iv/haskell/p2p/hex-offgrid/fuzzy-parse"; # tmp
fuzzy.url = "git+https://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA";
fuzzy.inputs.nixpkgs.follows = "nixpkgs";
fuzzy.inputs.haskell-flake-utils.follows = "haskell-flake-utils";
saltine = {
url = "github:tel/saltine/3d3a54cf46f78b71b4b55653482fb6f4cee6b77d";
flake = false;
};
bytestring-mmap = {
url = "github:ivanovs-4/bytestring-mmap";
flake = false;
};
};
outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
@ -78,10 +85,27 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
"fixme-new" = "./fixme-new";
};
hpPreOverrides = {pkgs, ...}: final: prev: with pkgs; {
hpPreOverrides = {pkgs, ...}: final: prev: ((with pkgs; {
saltine = prev.callCabal2nix "saltine" inputs.saltine { inherit (pkgs) libsodium; };
scotty = final.callHackage "scotty" "0.21" { };
};
bytestring-mmap = prev.callCabal2nix "bytestring-mmap" inputs.bytestring-mmap {};
skylighting-lucid = final.callHackage "skylighting-lucid" "1.0.4" { };
# wai-app-file-cgi = final.callHackage "wai-app-file-cgi" "3.1.11" { };
# htags = final.callHackage "htags" "1.0.1" { };
}) //
(with haskell-flake-utils.lib;
with pkgs.haskell.lib;
let
donts = [
(jailbreakUnbreak pkgs)
# dontBenchmark
dontCoverage
dontCheck
];
in tunePackages pkgs prev {
wai-app-file-cgi = donts;
}
));
packagePostOverrides = { pkgs }: with pkgs; with haskell.lib; [
disableExecutableProfiling
@ -115,7 +139,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
cabal-install
haskell-language-server
hoogle
htags
# htags
text-icu
magic
pkgs.icu72
@ -125,7 +149,6 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
++
[ pkgs.pkg-config
inputs.hspup.packages.${pkgs.system}.default
inputs.fixme.packages.${pkgs.system}.default
]
);

4
hbs2-core/lib/HBS2/Actors.hs
View File

@ -7,16 +7,12 @@ module HBS2.Actors
) where
import HBS2.Prelude
import HBS2.Clock
import Control.Concurrent.STM
import Control.Concurrent.STM.TBMQueue qualified as TBMQ
import Control.Concurrent.STM.TBMQueue (TBMQueue)
import Control.Concurrent.STM.TVar qualified as TVar
import Control.Monad
import Control.Concurrent.Async
import Data.Function
import Data.Functor
import Data.Kind
import Control.Concurrent

12
hbs2-core/lib/HBS2/Actors/Peer.hs
View File

@ -17,8 +17,6 @@ import HBS2.Events
import HBS2.Net.Auth.Credentials
import HBS2.Net.Messaging
import HBS2.Net.PeerLocator
import HBS2.Net.PeerLocator.Static
import HBS2.Net.Proto
import HBS2.Net.Proto.Sessions
import HBS2.Prelude.Plated
import HBS2.Storage
@ -26,6 +24,7 @@ import HBS2.System.Logger.Simple
import Data.Config.Suckless.KeyValue (HasConf(..))
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Concurrent.Async
import Control.Monad.Reader
@ -33,7 +32,6 @@ import Data.ByteString.Lazy (ByteString)
import Data.Cache (Cache)
import Data.Cache qualified as Cache
import Data.Dynamic
import Data.Foldable hiding (find)
import Data.Map qualified as Map
import Data.Maybe
import GHC.TypeLits
@ -264,7 +262,7 @@ instance ( MonadIO m
) => Request e msg m where
request peer_e msg = do
let proto = protoId @e @msg (Proxy @msg)
pipe <- getFabriq @e
pip <- getFabriq @e
me <- ownPeer @e
-- TODO: check if a request were sent to peer and timeout is here
@ -281,7 +279,7 @@ instance ( MonadIO m
trace $ "REQUEST: not allowed to send for proto" <+> viaShow proto
when allowed do
sendTo pipe (To peer_e) (From me) (AnyMessage @(Encoded e) @e proto (encode msg))
sendTo pip (To peer_e) (From me) (AnyMessage @(Encoded e) @e proto (encode msg))
-- trace $ "REQUEST: after sendTo" <+> viaShow peer_e
@ -431,7 +429,7 @@ runProto :: forall e m . ( MonadIO m
runProto hh = do
me <- ownPeer @e @m
pipe <- getFabriq @e
pipf <- getFabriq @e
let resp = [ (pid, a) | a@AnyProtocol { myProtoId = pid } <- hh ]
@ -439,7 +437,7 @@ runProto hh = do
forever $ do
messages <- receive @_ @e pipe (To me)
messages <- receive @_ @e pipf (To me)
for_ messages $ \(From pip, AnyMessage n msg :: AnyMessage (Encoded e) e) -> do

5
hbs2-core/lib/HBS2/Actors/Peer/Types.hs
View File

@ -2,15 +2,10 @@
module HBS2.Actors.Peer.Types where
import HBS2.Prelude
import HBS2.Storage
import HBS2.Net.Proto.Types
import HBS2.Net.Messaging
import HBS2.Hash
import Control.Monad.Trans.Class
import Data.ByteString.Lazy (ByteString)
import Control.Monad
import Codec.Serialise
class HasProtocol e p => HasTimeLimits e p m where
tryLockForPeriod :: Peer e -> p -> m Bool

2
hbs2-core/lib/HBS2/Base58.hs
View File

@ -4,10 +4,8 @@ import Data.ByteString.Base58 (encodeBase58, bitcoinAlphabet, decodeBase58,Alpha
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Char8 (ByteString)
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.ByteString.Lazy qualified as LBS
import Data.Word
import Data.Char (ord)
import Numeric
import Prettyprinter

8
hbs2-core/lib/HBS2/Clock.hs
View File

@ -1,8 +1,9 @@
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module HBS2.Clock
( module HBS2.Clock
, module System.Clock
, POSIXTime, getPOSIXTime, getEpoch
, POSIXTime, getPOSIXTime
)where
import Data.Functor
@ -14,7 +15,6 @@ import Data.Proxy
import Data.Time
import Prettyprinter
import System.Clock
import Data.Time.Clock
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
import Data.Word
@ -50,7 +50,7 @@ instance IsTimeout t => Expired (Timeout t) TimeSpec where
-- expired timeout ts = False
toNominalDiffTime :: IsTimeout t => Timeout t -> NominalDiffTime
toNominalDiffTime = fromRational . (/ (10^6)) . fromIntegral . toMicroSeconds
toNominalDiffTime = fromRational . (/ (10^(6 :: Integer))) . fromIntegral . toMicroSeconds
class IsTimeout a => MonadPause a m where
pause :: Timeout a -> m ()
@ -97,7 +97,7 @@ instance IsTimeout 'Minutes where
toNanoSeconds (TimeoutMin x) = round (x * 60 * 1e9)
instance IsTimeout 'NomDiffTime where
toNanoSeconds (TimeoutNDT t) = round (realToFrac (nominalDiffTimeToSeconds t) * 1e9)
toNanoSeconds (TimeoutNDT t) = round (realToFrac (nominalDiffTimeToSeconds t) * (1e9 :: Double))
instance IsTimeout 'TS where
toNanoSeconds (TimeoutTS s) = fromIntegral $ toNanoSecs s

2
hbs2-core/lib/HBS2/Data/Bundle.hs
View File

@ -178,7 +178,7 @@ instance MonadIO m => ImportBundle HashRef m where
go hd bs
| LBS.null bs = pure $ Right ()
| otherwise = do
let ss = bundleHeadSectionSize hd
let _ss = bundleHeadSectionSize hd
let (bsh, allBsRest) = LBS.splitAt sectionHeadSize bs
case deserialiseOrFail @BundleSection bsh of
Left{} -> do

12
hbs2-core/lib/HBS2/Data/Detect.hs
View File

@ -6,25 +6,25 @@ import HBS2.Data.Types
import HBS2.Merkle
import HBS2.Storage
import HBS2.System.Logger.Simple
-- import HBS2.System.Logger.Simple
import Data.Foldable (for_)
-- import Data.Foldable (for_)
import Control.Monad.Trans.Maybe
import Codec.Serialise (deserialiseOrFail)
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as LBS
import Data.Either
import Data.Function
import Data.Functor
-- import Data.Function
-- import Data.Functor
import Data.Maybe
import Control.Concurrent.STM
import Data.HashMap.Strict qualified as HashMap
import Data.HashMap.Strict (HashMap)
-- import Data.HashMap.Strict (HashMap)
import Data.List qualified as List
import Streaming.Prelude qualified as S
import Streaming qualified as S
-- import Streaming qualified as S
data BlobType = Merkle (MTree [HashRef])
| MerkleAnn (MTreeAnn [HashRef])

3
hbs2-core/lib/HBS2/Data/KeyRing.hs
View File

@ -9,7 +9,6 @@ import System.FilePath
import System.Directory
import Data.List as L
import Data.Maybe
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString qualified as BS
import Lens.Micro.Platform
import UnliftIO
@ -23,7 +22,7 @@ splitPattern fp = (pref, flt)
pref = joinPath pref'
flt = case flt' of
[] -> "*"
xs -> joinPath flt'
_xs -> joinPath flt'
(pref', flt') = L.span isNotP (splitDirectories fp)
isNotP s = isNothing (find isP s)
isP c = c `elem` ("?*" :: [Char])

1
hbs2-core/lib/HBS2/Data/Types.hs
View File

@ -2,7 +2,6 @@ module HBS2.Data.Types
( module X
-- , module HBS2.Data.Types.Crypto
, AsSyntax(..)
, LoadedRef(..)
)
where

2
hbs2-core/lib/HBS2/Data/Types/Peer.hs
View File

@ -1,14 +1,12 @@
{-# Language UndecidableInstances #-}
module HBS2.Data.Types.Peer where
import Codec.Serialise
import Data.ByteString qualified as BS
import Data.Hashable
import Lens.Micro.Platform
import HBS2.Prelude
import HBS2.Net.Auth.Credentials
import HBS2.Net.Proto.Types
type PingSign e = Signature (Encryption e)

2
hbs2-core/lib/HBS2/Data/Types/Refs.hs
View File

@ -4,7 +4,7 @@
module HBS2.Data.Types.Refs
( module HBS2.Data.Types.Refs
, serialise
, pattern HashLike
-- , pattern HashLike
) where
import HBS2.Base58

6
hbs2-core/lib/HBS2/Hash.hs
View File

@ -16,8 +16,8 @@ import Data.ByteArray qualified as BA
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Short qualified as SB
import Data.ByteString.Short (ShortByteString)
-- import Data.ByteString.Short qualified as SB
-- import Data.ByteString.Short (ShortByteString)
import Data.Data
import Data.Hashable (Hashable)
import Data.Kind
@ -26,7 +26,7 @@ import Data.Text qualified as Text
import GHC.Generics
import Prettyprinter
import Text.InterpolatedString.Perl6 (qc)
import Control.DeepSeq (NFData,force)
import Control.DeepSeq (NFData)
data HbSync = HbSync
deriving stock (Data)

9
hbs2-core/lib/HBS2/Merkle.hs
View File

@ -7,21 +7,18 @@ module HBS2.Merkle where
import HBS2.Prelude
import HBS2.Hash
import Control.Applicative
import Codec.Serialise (serialise, deserialiseOrFail)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Data
import Data.Foldable (forM_, traverse_)
import Data.Foldable (traverse_)
import Data.List qualified as List
import Data.Text (Text)
import Data.Word
import GHC.Generics
import Lens.Micro.Platform
import Control.Monad.Trans.Maybe
import Control.Monad
import Prettyprinter
-- import Prettyprinter
@ -210,7 +207,7 @@ walkMerkle' root flookup sink = go root
either (const $ runWithAnnTree hash bs) runWithTree t1
runWithAnnTree hash bs = do
runWithAnnTree _hash bs = do
let t = deserialiseOrFail @(MTreeAnn a) bs
case t of
Left{} -> pure ()

2
hbs2-core/lib/HBS2/Merkle/MetaData.hs
View File

@ -16,7 +16,7 @@ import Data.Text.Encoding qualified as TE
import Control.Monad.Except
import Control.Monad.Trans.Maybe
import UnliftIO
-- import UnliftIO
{- HLINT ignore "Functor law" -}

2
hbs2-core/lib/HBS2/Net/Auth/Credentials.hs
View File

@ -201,7 +201,7 @@ instance ( Serialise (PeerCredentials e)
)
=> Pretty (AsBase58 (PeerCredentials e)) where
pretty (AsBase58 c@(PeerCredentials s p _)) = pretty $ B8.unpack (toBase58 bs)
pretty (AsBase58 c@(PeerCredentials _s _p _)) = pretty $ B8.unpack (toBase58 bs)
where
bs = LBS.toStrict $ serialise c

1
hbs2-core/lib/HBS2/Net/Auth/Credentials/Sigil.hs
View File

@ -14,7 +14,6 @@ import Crypto.Saltine.Class qualified as Crypto
import Crypto.Saltine.Class (IsEncoding(..))
import Control.Monad.Identity
import Control.Monad.Trans.Maybe
import Data.ByteString.Char8 (ByteString)
import Data.ByteString.Char8 qualified as B8
import Data.ByteString.Lazy.Char8 qualified as LBS
import Data.Maybe

15
hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs
View File

@ -23,7 +23,7 @@ import HBS2.Net.Proto.Types
import HBS2.Storage hiding (Key)
import HBS2.Storage.Operations.Class
import HBS2.Storage.Operations.ByteString
import HBS2.Storage(Storage(..))
-- import HBS2.Storage(Storage(..))
import HBS2.Defaults
@ -56,13 +56,14 @@ import Data.Word (Word64)
import Data.ByteArray()
import Network.ByteOrder qualified as N
import Streaming.Prelude qualified as S
import Lens.Micro.Platform
-- import Lens.Micro.Platform
import Data.Coerce
import Data.Typeable (TypeRep, typeRep)
import Type.Reflection (SomeTypeRep(..), someTypeRep)
-- import Data.Typeable (TypeRep, typeRep)
-- import Type.Reflection (SomeTypeRep(..), someTypeRep)
import Type.Reflection ()
import Streaming qualified as S
import Streaming (Stream(..), Of(..))
-- import Streaming qualified as S
import Streaming (Stream, Of(..))
import System.IO.Unsafe (unsafePerformIO)
@ -197,7 +198,7 @@ instance (ForGroupKeySymm s) => Serialise (GroupKey 'Symm s) where
let compatEncoded = Serialise.encode compat
let version = 2
let ext = (getGroupKeyIdScheme x, getGroupKeyId x, getGroupKeyTimestamp x)
compatEncoded <> Serialise.encode version <> Serialise.encode ext
compatEncoded <> Serialise.encode (version :: Integer) <> Serialise.encode ext
decode = do
GroupKeySymmV1{..} <- Serialise.decode @(GroupKeySymmV1 s)

2
hbs2-core/lib/HBS2/Net/Auth/Schema.hs
View File

@ -12,8 +12,6 @@ import HBS2.Net.Proto.Types
import HBS2.Hash
import HBS2.Net.Messaging.Unix
import Data.Config.Suckless
import Data.Word
import Crypto.Error
import Crypto.PubKey.Ed25519 qualified as Ed

12
hbs2-core/lib/HBS2/Net/IP/Addr.hs
View File

@ -16,8 +16,6 @@ import Control.Monad
import Control.Monad.Trans.Maybe
import Data.Attoparsec.Text as Atto
import Data.Char
import Data.Function
import Data.Functor
import Data.IP
import Data.Maybe
import Data.Text qualified as Text
@ -75,9 +73,9 @@ instance FromStringMaybe (IPAddrPort e) where
po = snd <$> hp
getHostPort :: Text -> Maybe (String, PortNumber)
getHostPort s = parseOnly p s & either (const Nothing) Just
getHostPort s = parseOnly p' s & either (const Nothing) Just
where
p = do
p' = do
(h, p) <- pAddr <|> tcppAddr
pure (Text.unpack h, read (Text.unpack p))
@ -129,8 +127,8 @@ pIP4 = do
hostAddr0 <- replicateM 3 $ do
n <- Atto.takeWhile isDigit
dot <- string "."
pure ( n <> dot )
cdot <- string "."
pure ( n <> cdot )
hostAddr1 <- Atto.takeWhile isDigit
@ -150,6 +148,6 @@ pHostName = do
void $ char ':'
port <- decimal
let host = if Text.null host' then "localhost" else host'
pure (host, Text.pack (show port))
pure (host, Text.pack (show (port :: Integer)))

4
hbs2-core/lib/HBS2/Net/Messaging/Encrypted/ByPass.hs
View File

@ -13,7 +13,6 @@ module HBS2.Net.Messaging.Encrypted.ByPass
import HBS2.Prelude
import HBS2.Hash
import HBS2.Clock hiding (sec)
import HBS2.Net.Messaging
import HBS2.Data.Types.SignedBox
import HBS2.Net.Auth.Credentials()
@ -40,7 +39,6 @@ import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Data.Maybe
import Data.Time.Clock.POSIX
import Data.Word
import System.Random
import System.IO.Unsafe (unsafePerformIO)
@ -317,7 +315,7 @@ instance (ForByPass e, Messaging w e ByteString)
when (isNothing mbx) do
debug $ "HEY: failed to unbox" <+> pretty heyNonceA <+> pretty orig
n <- toMPlus mbx
_n <- toMPlus mbx
(pks, HEYBox t puk) <- toMPlus mbx

8
hbs2-core/lib/HBS2/Net/Messaging/Encrypted/RandomPrefix.hs
View File

@ -11,9 +11,9 @@ module HBS2.Net.Messaging.Encrypted.RandomPrefix
import Data.Word
import Data.Bits
-- import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Lazy (ByteString)
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Data.ByteString.Builder
@ -52,7 +52,7 @@ instance Instruction a => Emittable (Proxy a) where
emit _ = word8 . fromIntegral $ natVal (Proxy @(Opcode a))
instance Emittable OP where
emit (OP op arg) = emit op <> emit arg
emit (OP o arg) = emit o <> emit arg
emit (BYTE w) = word8 w
instance Emittable () where
@ -192,7 +192,7 @@ runCodeLazy s = runState (execStateT (runMaybeT (go s)) Nothing) s
put (Just n)
pure rest
repeatN bs = do
_repeatN bs = do
(n, rest) <- next bs
rest' <- replicateM (min 16 (fromIntegral n)) $ do
@ -223,7 +223,7 @@ instance MonadIO m => RandomPrefix PrefixMethod1 m where
randomPrefix (PrefixMethod1 k a x) = liftIO do
let nums = partsMethod1 k a x
me <- liftIO $ replicateM (length nums) $ randomRIO (0,2)
me <- liftIO $ replicateM (length nums) $ randomRIO (0,2 :: Integer)
opcodes <- forM (zip me nums) $ \z@(_, n) ->
case fst z of
1 -> do

4
hbs2-core/lib/HBS2/Net/Messaging/Fake.hs
View File

@ -31,6 +31,8 @@ newFakeP2P :: (Eq (Peer peer), Hashable (Peer peer)) => Bool -> IO (FakeP2P peer
newFakeP2P block =
FakeP2P block <$> newTVarIO mempty
getChan :: (Hashable (Peer proto)) =>
FakeP2P proto msg -> Peer proto -> IO (TChan (From proto, msg))
getChan bus whom = do
ch <- newTChanIO
atomically $ stateTVar t (alter ch)
@ -45,7 +47,7 @@ instance ( (HasPeer proto, Hashable (Peer proto))
) => Messaging (FakeP2P proto msg) proto msg where
sendTo bus (To whom) who msg = liftIO do
ch <- newTChanIO
_ch <- newTChanIO
chan <- getChan bus whom
atomically $ Chan.writeTChan chan (who, msg)

3
hbs2-core/lib/HBS2/Net/Messaging/Pipe.hs
View File

@ -10,6 +10,7 @@ import HBS2.Actors.Peer.Types
import HBS2.Net.Messaging
import Control.Concurrent.STM qualified as STM
import Control.Monad.Fix
import Control.Monad.Reader
import Data.ByteString.Builder qualified as B
import Data.ByteString.Lazy (ByteString)
@ -49,7 +50,7 @@ newMessagingPipe (pIn,pOut) = do
<$> newTQueueIO
instance Hashable PipeAddr where
hashWithSalt salt (PipeAddr pip) = hashWithSalt salt ("pipe-addr", fd)
hashWithSalt salt (PipeAddr pip) = hashWithSalt salt ("pipe-addr" :: String, fd)
where
fd = unsafePerformIO (handleToFd pip <&> fromIntegral @_ @Word)

4
hbs2-core/lib/HBS2/Net/Messaging/Stream.hs
View File

@ -2,11 +2,9 @@ module HBS2.Net.Messaging.Stream where
import HBS2.Prelude.Plated
import Data.Function
import Control.Exception (try,Exception,SomeException,throwIO)
import Control.Exception (Exception,throwIO)
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as LBS
import Data.Typeable
import Network.Socket hiding (listen,connect)
import Streaming.Prelude qualified as S
import Data.ByteString qualified as BS

6
hbs2-core/lib/HBS2/Net/Messaging/TCP.hs
View File

@ -89,8 +89,8 @@ newMessagingTCP pa = liftIO do
instance Messaging MessagingTCP L4Proto ByteString where
sendTo bus (To p) (From f) msg = liftIO do
let own = view tcpOwnPeer bus
sendTo bus (To p) (From _f) msg = liftIO do
let _own = view tcpOwnPeer bus
co' <- atomically $ readTVar (view tcpPeerConn bus) <&> HashMap.lookup p
@ -369,7 +369,7 @@ runMessagingTCP env = liftIO do
now <- getTimeCoarse
-- FIXME: time-hardcode-again
let expire = filter (\e -> (realToFrac (toNanoSecs (now - fst e)) / 1e9) < 30)
let expire = filter (\e -> (realToFrac (toNanoSecs (now - fst e)) / (1e9 :: Double)) < 30)
atomically $ modifyTVar defs
$ HashMap.mapMaybe
$ \es -> let rs = expire es

7
hbs2-core/lib/HBS2/Net/Messaging/UDP.hs
View File

@ -5,10 +5,10 @@ import HBS2.Clock
import HBS2.Defaults
import HBS2.Net.IP.Addr
import HBS2.Net.Messaging
import HBS2.Net.Proto
-- import HBS2.Net.Proto
import HBS2.Prelude.Plated
import HBS2.System.Logger.Simple
-- import HBS2.System.Logger.Simple
import Data.Function
import Control.Exception
@ -19,7 +19,6 @@ import Control.Concurrent.STM.TQueue qualified as Q0
import Control.Monad
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as LBS
import Data.Functor
import Data.List qualified as L
import Data.Maybe
-- import Data.Text (Text)
@ -100,7 +99,7 @@ newMessagingUDP reuse saddr =
)
where
sorted = L.sortBy ( compare `on` proto)
sorted = L.sortBy ( compare @Integer `on` proto)
proto x = case addrAddress x of
SockAddrInet{} -> 0
SockAddrInet6{} -> 1

12
hbs2-core/lib/HBS2/Net/Messaging/Unix.hs
View File

@ -12,11 +12,11 @@ import HBS2.Net.Proto.Types
import HBS2.Actors.Peer.Types
import HBS2.Net.Messaging
import HBS2.Net.Messaging.Stream
import HBS2.Clock
import HBS2.System.Logger.Simple
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Reader hiding (reader)
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as LBS
@ -34,10 +34,6 @@ import Lens.Micro.Platform
import Control.Monad.Trans.Cont
import UnliftIO
import Streaming.Prelude qualified as S
import Control.Concurrent (myThreadId)
data UNIX = UNIX
deriving (Eq,Ord,Show,Generic)
@ -170,7 +166,7 @@ runMessagingUnix env = do
liftIO $ listen sock 5
forever do
(so, sa) <- liftIO $ accept sock
(so, _sa) <- liftIO $ accept sock
withSession $ flip runContT void do
@ -193,7 +189,7 @@ runMessagingUnix env = do
msg <- liftIO . atomically $ readTQueue q
let len = fromIntegral $ LBS.length msg :: Int
let bs = bytestring32 (fromIntegral len)
let _bs = bytestring32 (fromIntegral len)
liftIO $ sendAll so $ bytestring32 (fromIntegral len)
@ -398,7 +394,7 @@ createQueues env who = liftIO do
instance Messaging MessagingUnix UNIX ByteString where
sendTo bus (To who) (From me) msg = liftIO do
sendTo bus (To who) (From _me) msg = liftIO do
-- createQueues bus who

1
hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs
View File

@ -1,3 +1,4 @@
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module HBS2.Net.PeerLocator.Static
( StaticPeerLocator
, newStaticPeerLocator

5
hbs2-core/lib/HBS2/Net/Proto/Notify.hs
View File

@ -23,7 +23,6 @@ import Control.Concurrent.STM (flushTQueue)
import Data.Maybe
import Data.Either
import UnliftIO
import System.IO (hPrint)
instance (HasProtocol UNIX (NotifyProto ev0 UNIX)) => HasTimeLimits UNIX (NotifyProto ev0 UNIX) IO where
@ -165,7 +164,7 @@ runNotifyWorkerServer env = do
-- FIXNE: timeout-hardcode
let tmo = 60
let tnano = round $ realToFrac tmo * 1e9
let tnano = round $ realToFrac tmo * (1e9 :: Double)
cleanup <- async $ forever do
@ -324,7 +323,7 @@ makeNotifyClient sink what = do
pure w
forM_ waiter $ \wa -> do
r <- try @_ @SomeException $ atomically $ writeTQueue wa ha
_r <- try @_ @SomeException $ atomically $ writeTQueue wa ha
debug $ "NOTIFY CLIENT SUBSCRIBED" <+> viaShow rn
NotifyBye ha -> do

3
hbs2-core/lib/HBS2/Net/Proto/Service.hs
View File

@ -13,13 +13,14 @@ import HBS2.Net.Proto.Types
import HBS2.Prelude.Plated
import Codec.Serialise
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.ByteString.Lazy (ByteString)
import Data.Kind
import Data.List qualified as List
import GHC.TypeLits
import Lens.Micro.Platform
-- import Lens.Micro.Platform
import UnliftIO.Async
import UnliftIO qualified as UIO
import UnliftIO (TVar,TQueue,atomically)

4
hbs2-core/lib/HBS2/Net/Proto/Sessions.hs
View File

@ -1,7 +1,5 @@
module HBS2.Net.Proto.Sessions where
import HBS2.Net.Proto.Types
import Data.Typeable
import Data.Dynamic
import Data.Hashable
@ -27,7 +25,7 @@ instance Hashable SKey where
instance Eq SKey where
(==) (SKey p1 ty1 a) (SKey p2 ty2 b) = ty1 == ty2 && unKey p1 a == unKey p1 b
(==) (SKey p1 ty1 a) (SKey _p2 ty2 b) = ty1 == ty2 && unKey p1 a == unKey p1 b
data family SessionKey e p :: Type

8
hbs2-core/lib/HBS2/Net/Proto/Types.hs
View File

@ -68,7 +68,7 @@ data L4Proto = UDP | TCP
deriving stock (Enum,Bounded)
instance Hashable L4Proto where
hashWithSalt s l = hashWithSalt s ("l4proto", fromEnum l)
hashWithSalt s l = hashWithSalt s ("l4proto" :: String, fromEnum l)
instance Show L4Proto where
show UDP = "udp"
@ -177,9 +177,9 @@ instance AddrPriority (Peer L4Proto) where
instance Hashable (Peer L4Proto) where
hashWithSalt salt p = case _sockAddr p of
SockAddrInet pn h -> hashWithSalt salt (4, fromEnum (_sockType p), fromIntegral pn, h)
SockAddrInet6 pn _ h _ -> hashWithSalt salt (6, fromEnum (_sockType p), fromIntegral pn, h)
SockAddrUnix s -> hashWithSalt salt ("unix", s)
SockAddrInet pn h -> hashWithSalt salt (4 :: Int, fromEnum (_sockType p), fromIntegral pn :: Integer, h)
SockAddrInet6 pn _ h _ -> hashWithSalt salt (6 :: Int, fromEnum (_sockType p), fromIntegral pn :: Integer, h)
SockAddrUnix s -> hashWithSalt salt ("unix" :: String, s)
-- FIXME: support-udp-prefix
instance Pretty (Peer L4Proto) where

1
hbs2-core/lib/HBS2/Polling.hs
View File

@ -1,7 +1,6 @@
module HBS2.Polling where
import HBS2.Prelude.Plated
import HBS2.Clock
import Data.Heap (Entry(..))
import Data.Heap qualified as Heap

4
hbs2-core/lib/HBS2/Prelude.hs
View File

@ -1,6 +1,7 @@
{-# Language FunctionalDependencies #-}
{-# Language PatternSynonyms #-}
{-# Language ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module HBS2.Prelude
( module Data.String
, module Safe
@ -37,6 +38,9 @@ import GHC.Generics as X (Generic)
import Data.ByteString (ByteString)
import Data.String (IsString(..))
import Safe
import Control.Monad as X
import Control.Monad.Fix as X
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Maybe

1
hbs2-core/lib/HBS2/Prelude/Plated.hs
View File

@ -3,7 +3,6 @@ module HBS2.Prelude.Plated
, module HBS2.Prelude
, module Data.Data
, module Data.Generics.Uniplate.Operations
, Generic
) where
import Data.Data

13
hbs2-core/lib/HBS2/ScheduledAction.hs
View File

@ -8,7 +8,6 @@ module HBS2.ScheduledAction
) where
import HBS2.Prelude.Plated
import HBS2.Clock
import Prelude hiding (all)
import Data.Word
@ -54,15 +53,15 @@ runScheduled :: MonadUnliftIO m => Scheduled -> m ()
runScheduled sch = forever do
pause (view scheduleRunPeriod sch)
now <- getTimeCoarse <&> toNanoSecs <&> (/1e9) . realToFrac <&> round
now <- getTimeCoarse <&> toNanoSecs <&> (/ (1e9 :: Double)) . realToFrac <&> round
expired <- atomically do
expireds <- atomically do
all <- readTVar (slots sch) <&> HashMap.toList
let (rest, expired) = List.partition ( (>now) . fst) all
let (rest, expireds) = List.partition ( (>now) . fst) all
writeTVar (slots sch) (HashMap.fromList rest)
pure expired
pure expireds
for_ expired $ \(_, all) -> do
for_ expireds $ \(_, all) -> do
for_ all $ \action -> do
-- TODO: error-logging-maybe
liftIO $ void $ action `E.catch` (\(_ :: E.ArithException) -> pure ())
@ -71,7 +70,7 @@ runScheduled sch = forever do
schedule :: forall a m . (MonadUnliftIO m, Integral a) => Scheduled -> a -> IO () -> m ()
schedule s ttl what = do
now <- getTimeCoarse <&> toNanoSecs <&> (/1e9) . realToFrac <&> round
now <- getTimeCoarse <&> toNanoSecs <&> (/ (1e9 :: Double)) . realToFrac <&> round
let slot = now + fromIntegral ttl
atomically $ modifyTVar (slots s) (HashMap.insertWith (<>) slot [what])

3
hbs2-core/lib/HBS2/Storage/Operations/ByteString.hs
View File

@ -17,12 +17,11 @@ import HBS2.Storage.Operations.Class
import HBS2.Defaults
import Streaming.Prelude qualified as S
import Streaming qualified as S
import Data.Function
import Control.Monad
import Control.Monad.Except
import Control.Exception
import Data.Bifunctor
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as LBS
-- hbs2-core/lib/HBS2/Net/Auth/Credentials.hs

4
hbs2-core/lib/HBS2/Storage/Operations/Missed.hs
View File

@ -7,10 +7,10 @@ import HBS2.Hash
import HBS2.Merkle
import HBS2.Storage
import HBS2.System.Logger.Simple
-- import HBS2.System.Logger.Simple
import Streaming.Prelude qualified as S
import Streaming.Prelude (Stream(..), Of(..))
import Streaming.Prelude (Stream, Of(..))
import Control.Monad.Trans.Maybe
import Control.Monad
import Data.Maybe

2
hbs2-core/lib/HBS2/System/Logger/Simple.hs
View File

@ -41,8 +41,6 @@ import Data.Map (Map)
import Data.Map.Strict qualified as Map
import Control.Concurrent.STM
import Prettyprinter.Render.Terminal
data LoggerType = LoggerStdout
| LoggerStderr
| LoggerFile FilePath

1
hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs
View File

@ -13,6 +13,7 @@ import HBS2.Net.Auth.GroupKeySymm as Symm
import HBS2.System.Dir
import Control.Monad
import Control.Monad.Cont
import DBPipe.SQLite
import Text.InterpolatedString.Perl6 (qc)

3
hbs2-peer/app/PeerMain.hs
View File

@ -122,6 +122,7 @@ import Control.Monad.Trans.Resource
import Streaming.Prelude qualified as S
import Graphics.Vty qualified as Vty
import Graphics.Vty.Platform.Unix qualified as Vty
data GoAgainException = GoAgainException
deriving (Eq,Ord,Show,Typeable)
@ -342,7 +343,7 @@ runCLI = do
liftIO do
when pro $ flip runContT pure do
cfg <- liftIO $ Vty.standardIOConfig
cfg <- pure $ Vty.defaultConfig
vty <- ContT $ bracket (Vty.mkVty cfg) Vty.shutdown
fix \next -> do

1
hbs2-peer/hbs2-peer.cabal
View File

@ -286,6 +286,7 @@ executable hbs2-peer
-- other-extensions:
build-depends: base, hbs2-peer, hbs2-keyman-direct-lib, vty
, vty-unix
hs-source-dirs: app

2
hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs
View File

@ -27,6 +27,8 @@ import HBS2.Peer.Proto.RefChan.Types
import HBS2.System.Logger.Simple
import Codec.Serialise
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Identity
import Control.Monad.Trans.Maybe
import Data.ByteString (ByteString)

1
hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs
View File

@ -20,6 +20,7 @@ import Data.Config.Suckless.Syntax
import Data.Config.Suckless.Parse
import Data.Kind
import Control.Monad
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import UnliftIO

2
hbs2-storage-simple/lib/HBS2/Storage/Compact.hs
View File

@ -51,7 +51,9 @@ import Data.Vector qualified as V
import Codec.Serialise
import GHC.Generics
import Lens.Micro.Platform
import Control.Monad
import Control.Monad.Except
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import UnliftIO

1
hbs2-storage-simple/lib/HBS2/Storage/Simple.hs
View File

@ -19,6 +19,7 @@ import HBS2.System.Logger.Simple
import Control.Concurrent.Async
import Control.Exception
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Except
import Control.Monad.Trans.Maybe
import Data.ByteString.Lazy qualified as LBS