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

boosted download

This commit is contained in:
Dmitry Zuikov 2024-02-14 12:02:03 +03:00
parent 4e136aa08b
commit 83b4d8bff8
33 changed files with 861 additions and 526 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
Makefile
View File

@ -5,11 +5,39 @@ SHELL := bash
MAKEFLAGS += --warn-undefined-variables
MAKEFLAGS += --no-builtin-rules
GHC_VERSION := 9.4.8
BIN_DIR := ./bin
BINS := \
hbs2 \
hbs2-peer \
hbs2-reposync \
hbs2-keyman \
git-remote-hbs2 \
git-hbs2 \
ifeq ($(origin .RECIPEPREFIX), undefined)
$(error This Make does not support .RECIPEPREFIX. Please use GNU Make 4.0 or later)
endif
.RECIPEPREFIX = >
$(BIN_DIR):
> @mkdir -p $@
.PHONY: symlinks
symlinks: $(BIN_DIR)
> @mkdir -p $(BIN_DIR)
> @echo $(BIN_DIR)
> @for bin in $(BINS); do \
> path=`find dist-newstyle -type f -name $$bin -path "*$(GHC_VERSION)*" | head -n 1`; \
> if [ -n "$$path" ]; then \
> echo "Creating symlink for $$bin"; \
> ln -sf $$PWD/$$path $(BIN_DIR)/$$bin; \
> else \
> echo "Binary $$bin for GHC $(GHC_VERSION) not found"; \
> fi; \
> done
.PHONY: build
build:
> nix develop -c cabal build all
@ -21,3 +49,4 @@ test-core:
.PHONY: test-raft
test-raft:
> nix develop -c ghcid -c 'cabal repl' raft-algo -T RaftAlgo.Proto.devTest

7
docs/devlog.md
View File

@ -1,10 +1,15 @@
## 2024-02-06
Новый формат репозиториев и реворк hbs2-git, статус - wip.
## 2023-11-03
PR: hbs2-file-logger-strikes-again
branch: fastpok-file-logger
commit: aa391ccdb3684311ec04905d03d9d6e405427f81
Теперь используется один LoggerSet для каждого LoggerType.
Это исправляет ошибку, из-за которой два логгера не могли писать
Это исправляет ошибку, из-за которой два логгера не могли писать
в один и тот же файл.
Добавлена поддержка ANSI стилей.

2
examples/raft-algo/raft-algo.cabal
View File

@ -10,7 +10,7 @@ license-file: LICENSE
-- copyright:
category: Network
build-type: Simple
extra-doc-files: CHANGELOG.md
-- extra-doc-files: CHANGELOG.md
-- extra-source-files:
common warnings

2
examples/refchan-qblf/refchan-qblf.cabal
View File

@ -10,7 +10,7 @@ license-file: LICENSE
-- copyright:
category: Network
build-type: Simple
extra-doc-files: CHANGELOG.md
-- extra-doc-files: CHANGELOG.md
-- extra-source-files:
common warnings

12
flake.lock
View File

@ -192,11 +192,11 @@
"flake-utils": "flake-utils_4"
},
"locked": {
"lastModified": 1672412555,
"narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
"lastModified": 1698938553,
"narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=",
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
"rev": "19b273b5dc401a0a565e7f75cf50a593871b80c9",
"type": "github"
},
"original": {
@ -266,11 +266,11 @@
},
"nixpkgs": {
"locked": {
"lastModified": 1697009197,
"narHash": "sha256-viVRhBTFT8fPJTb1N3brQIpFZnttmwo3JVKNuWRVc3s=",
"lastModified": 1707451808,
"narHash": "sha256-UwDBUNHNRsYKFJzyTMVMTF5qS4xeJlWoeyJf+6vvamU=",
"owner": "nixos",
"repo": "nixpkgs",
"rev": "01441e14af5e29c9d27ace398e6dd0b293e25a54",
"rev": "442d407992384ed9c0e6d352de75b69079904e4e",
"type": "github"
},
"original": {

7
flake.nix
View File

@ -95,7 +95,11 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
ghcid
cabal-install
haskell-language-server
hoogle
htags
text-icu
pkgs.icu72
pkgs.openssl
])
++
[ pkgs.pkg-config
@ -105,7 +109,8 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
);
shellHook = ''
export GIT_HASH="${self.rev or self.dirtyRev or "dirty"}"
export GIT_HASH="${self.rev or self.dirtyRev or "dirty"}"
export STAN_USE_DEFAULT_CONFIG=True
'';
};

4
hbs2-core/hbs2-core.cabal
View File

@ -10,7 +10,7 @@ license-file: LICENSE
-- copyright:
category: Network
build-type: Simple
extra-doc-files: CHANGELOG.md
-- extra-doc-files: CHANGELOG.md
-- extra-source-files:
common warnings
@ -143,10 +143,12 @@ library
, HBS2.System.Logger.Simple
, HBS2.System.Logger.Simple.ANSI
, HBS2.System.Logger.Simple.Class
, HBS2.System.Dir
, HBS2.Net.Dialog.Core
, HBS2.Net.Dialog.Client
, HBS2.Net.Dialog.Helpers.List
, HBS2.Net.Dialog.Helpers.Streaming
, HBS2.Misc.PrettyStuff
, HBS2.Version

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

@ -35,6 +35,16 @@ class IsTimeout a where
toTimeSpec :: Timeout a -> TimeSpec
toTimeSpec x = fromNanoSecs (fromIntegral (toNanoSeconds x))
class Expired timeout interval where
expired :: timeout -> interval -> Bool
instance IsTimeout t => Expired (Timeout t) TimeSpec where
expired t ts = fromIntegral (toNanoSecs ts) > toNanoSeconds t
-- expired :: IsTimeout t => Timeout 't -> TimeSpec -> Bool
-- expired timeout ts = False
toNominalDiffTime :: IsTimeout t => Timeout t -> NominalDiffTime
toNominalDiffTime = fromRational . (/ (10^6)) . fromIntegral . toMicroSeconds

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

@ -70,7 +70,7 @@ defBlockWipTimeout :: TimeSpec
defBlockWipTimeout = defCookieTimeout
defBlockInfoTimeout :: Timeout 'Seconds
defBlockInfoTimeout = 20
defBlockInfoTimeout = 2
defBlockInfoTimeoutSpec :: TimeSpec
defBlockInfoTimeoutSpec = toTimeSpec defBlockInfoTimeout
@ -81,7 +81,7 @@ defBlockWaitMax = 60 :: Timeout 'Seconds
-- how much time wait for block from peer?
defChunkWaitMax :: Timeout 'Seconds
defChunkWaitMax = 30 :: Timeout 'Seconds
defChunkWaitMax = 10 :: Timeout 'Seconds
defSweepTimeout :: Timeout 'Seconds
defSweepTimeout = 60 -- FIXME: only for debug!

29
hbs2-core/lib/HBS2/Misc/PrettyStuff.hs Normal file
View File

@ -0,0 +1,29 @@
module HBS2.Misc.PrettyStuff
( module HBS2.Misc.PrettyStuff
, hPutDoc
) where
import Data.Text qualified as Text
import Prettyprinter
import Prettyprinter.Render.Terminal
green :: Doc AnsiStyle -> Doc AnsiStyle
green = annotate (color Green)
yellow :: Doc AnsiStyle -> Doc AnsiStyle
yellow = annotate (color Yellow)
red :: Doc AnsiStyle -> Doc AnsiStyle
red = annotate (color Red)
blue :: Doc AnsiStyle -> Doc AnsiStyle
blue = annotate (color Blue)
section :: Doc ann
section = line <> line
toStringANSI :: Doc AnsiStyle -> String
toStringANSI doc = Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions doc

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

@ -303,7 +303,7 @@ instance (ForByPass e, Messaging w e ByteString)
-- FIXME: check-code
guard ( code == Just heySeed )
debug $ "HEY CODE:" <> parens (pretty code) <+> pretty orig
trace $ "HEY CODE:" <> parens (pretty code) <+> pretty orig
guard (not (LBS.null hbs))

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

@ -395,7 +395,7 @@ runNotifySink sink k action = do
-- NOTE: run-notify-sink-cleanup
-- если нас пристрелили --- попрощаться с NotifySink хотя бы
let cleanup = do
trace $ "CLIENT: cleanip and exit" <+> pretty ha
trace $ "CLIENT: cleanup and exit" <+> pretty ha
atomically $ writeTQueue (sinkPipeline sink) (NotifySinkBye ha)
atomically $ modifyTVar (sinkNotify sink) (HashMap.delete ha)
cancel w

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

@ -19,6 +19,7 @@ module HBS2.Prelude
, FromByteString(..)
, Text.Text
, (&), (<&>), for_, for
, HasErrorStatus(..), ErrorStatus(..), SomeError(..)
) where
import Data.Typeable as X
@ -96,6 +97,22 @@ instance Monad m => ToMPlus (MaybeT m) (Either x a) where
toMPlus (Right x) = MaybeT $ pure (Just x)
data ErrorStatus = Complete
| HasIssuesButOkay
| Failed
| SNAFU
| Unknown
deriving stock (Eq,Ord,Show,Enum,Generic)
class HasErrorStatus e where
getStatus :: e -> ErrorStatus
-- instance {-# OVERLAPPABLE #-} HasErrorStatus e where
-- getStatus _ = Unknown
data SomeError = forall e . (Show e, HasErrorStatus e) =>
SomeError e
asyncLinked :: MonadUnliftIO m => m a -> m (Async a)
asyncLinked m = do
l <- async m

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

@ -20,41 +20,8 @@ findMissedBlocks :: (MonadIO m) => AnyStorage -> HashRef -> m [HashRef]
findMissedBlocks sto href = do
-- TODO: limit-recursion-depth?
-- TODO: cache-results-limit-calls-freq
-- trace $ "findMissedBlocks" <+> pretty href
S.toList_ $ do
walkMerkle (fromHashRef href) (lift . getBlock sto) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
case hr of
-- FIXME: investigate-this-wtf
Left hx -> S.yield (HashRef hx)
Right (hrr :: [HashRef]) -> do
forM_ hrr $ \hx -> runMaybeT do
blk <- lift $ getBlock sto (fromHashRef hx)
unless (isJust blk) do
lift $ S.yield hx
maybe1 blk none $ \bs -> do
let w = tryDetect (fromHashRef hx) bs
r <- case w of
Merkle{} -> lift $ lift $ findMissedBlocks sto hx
MerkleAnn t -> lift $ lift do
-- FIXME: make-tail-recursive
b0 <- case _mtaMeta t of
AnnHashRef hm -> findMissedBlocks sto (HashRef hm)
_ -> pure mempty
b1 <- findMissedBlocks sto hx
pure (b0 <> b1)
_ -> pure mempty
lift $ mapM_ S.yield r
S.toList_ $ findMissedBlocks2 sto href
findMissedBlocks2 :: (MonadIO m) => AnyStorage -> HashRef -> Stream (Of HashRef) m ()
findMissedBlocks2 sto href = do

46
hbs2-core/lib/HBS2/System/Dir.hs Normal file
View File

@ -0,0 +1,46 @@
module HBS2.System.Dir
( module HBS2.System.Dir
, module System.FilePath
, module System.FilePattern
, module UnliftIO
) where
import System.FilePath
import System.FilePattern
import System.Directory as D
import UnliftIO hiding (try)
data MkDirOpt = MkDirOptNone
class HasMkDirOptions a where
mkdirOpts :: a -> [MkDirOpt]
instance HasMkDirOptions FilePath where
mkdirOpts = mempty
class ToFilePath a where
toFilePath :: a -> FilePath
instance ToFilePath FilePath where
toFilePath = id
mkdir :: (MonadIO m, ToFilePath a) => a -> m ()
mkdir a = do
liftIO $ createDirectoryIfMissing True (toFilePath a)
pwd :: MonadIO m => m FilePath
pwd = liftIO D.getCurrentDirectory
doesPathExist :: MonadIO m => FilePath -> m Bool
doesPathExist = liftIO . D.doesPathExist
canonicalizePath :: MonadIO m => FilePath -> m FilePath
canonicalizePath = liftIO . D.canonicalizePath
expandPath :: MonadIO m => FilePath -> m FilePath
expandPath = liftIO . D.canonicalizePath
doesDirectoryExist :: MonadIO m => FilePath -> m Bool
doesDirectoryExist = liftIO . D.doesDirectoryExist

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

@ -1,5 +1,5 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module HBS2.System.Logger.Simple.ANSI
module HBS2.System.Logger.Simple.ANSI
( trace
, debug
, err
@ -8,10 +8,14 @@ module HBS2.System.Logger.Simple.ANSI
, info
, AnsiStyle
, ToLogStr(..)
, INFO,NOTICE,WARN,ERROR,DEBUG,TRACE
, setLogging,setLoggingOff
, toStderr,toStdout,logPrefix,defLog
) where
import Prettyprinter.Render.Terminal
import HBS2.System.Logger.Simple qualified as Logger
import HBS2.System.Logger.Simple (INFO,NOTICE,WARN,ERROR,DEBUG,TRACE,setLoggingOff,setLogging,toStderr,toStdout,logPrefix,defLog)
import Control.Monad.IO.Class
import Prettyprinter
import System.Log.FastLogger
@ -35,4 +39,4 @@ info :: MonadIO m => Doc AnsiStyle -> m ()
info = Logger.info @(Doc AnsiStyle)
instance ToLogStr (Doc AnsiStyle) where
toLogStr = toLogStr . renderStrict . layoutPretty defaultLayoutOptions
toLogStr = toLogStr . renderStrict . layoutPretty defaultLayoutOptions

2
hbs2-keyman/hbs2-keyman.cabal
View File

@ -10,7 +10,7 @@ maintainer: dzuikov@gmail.com
-- copyright:
category: Data
build-type: Simple
extra-doc-files: CHANGELOG.md
-- extra-doc-files: CHANGELOG.md
-- extra-source-files:
common warnings

510
hbs2-peer/app/BlockDownload.hs
View File

@ -28,68 +28,23 @@ import PeerInfo
import Brains
import DownloadMon
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Concurrent.STM.TSem
import Control.Concurrent.STM qualified as STM
import Control.Monad.Trans.Cont
import Control.Monad.Reader
import Control.Monad.Trans.Maybe
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as LBS
import Data.Cache qualified as Cache
import Data.Foldable hiding (find)
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet (HashSet)
import Data.HashSet qualified as HashSet
import Data.IntMap (IntMap)
import Data.IntMap qualified as IntMap
import Data.IntSet qualified as IntSet
import Data.List qualified as List
import Data.Maybe
import Lens.Micro.Platform
import System.Random (randomRIO)
import System.Random.Shuffle (shuffleM)
import Codec.Serialise
import Data.Hashable
import System.Random.Shuffle (shuffleM)
import Control.Concurrent (getNumCapabilities)
getBlockForDownload :: forall e m . (MonadIO m, IsPeerAddr e m, MyPeer e, HasStorage m)
=> Peer e
-> BlockDownloadM e m (Maybe (Hash HbSync))
getBlockForDownload peer = do
pa <- lift $ toPeerAddr peer
tinq <- asks (view blockInQ)
brains <- asks (view downloadBrains)
prop <- asks (view blockProposed)
sto <- lift getStorage
inq <- liftIO $ readTVarIO tinq
-- let size = HashMap.size inq
let allBlks = HashMap.keys inq
hs' <- forM allBlks $ \blk -> do
here <- liftIO $ hasBlock sto blk <&> isJust
newOne <- shouldDownloadBlock @e brains peer blk
if not here && newOne then do
pure $ Just blk
else do
po <- shouldPostponeBlock @e brains blk
when po do
postponeBlock blk
pure Nothing
let hs = catMaybes hs'
let size = length hs
if size == 0 then do
pure Nothing
else do
i <- randomRIO (0, size - 1)
let blk = HashMap.keys inq !! i
pure $ Just blk
import UnliftIO
processBlock :: forall e m . ( MonadIO m
@ -253,9 +208,9 @@ downloadFromWithPeer peer thisBkSize h = do
rtt <- medianPeerRTT pinfo <&> fmap ( (/1e9) . realToFrac )
<&> fromMaybe defChunkWaitMax
let w = 4 * rtt * realToFrac (length bursts)
let w = 4 * rtt * 256 -- realToFrac (length bursts)
let burstTime = max defChunkWaitMax $ realToFrac w :: Timeout 'Seconds
let burstTime = min defChunkWaitMax $ realToFrac w :: Timeout 'Seconds
trace $ "BURST TIME" <+> pretty burstTime
@ -272,7 +227,7 @@ downloadFromWithPeer peer thisBkSize h = do
Just (i,chunksN) -> do
let req = BlockGetChunks h chusz (fromIntegral i) (fromIntegral chunksN)
void $ liftIO $ atomically $ flushTQueue chuQ
void $ liftIO $ atomically $ STM.flushTQueue chuQ
lift $ request peer (BlockChunks @e coo req)
@ -283,7 +238,7 @@ downloadFromWithPeer peer thisBkSize h = do
m <- readTVar r
pure (j, IntMap.member j m)
let here = and $ fmap snd hc
let here = all snd hc
if here then do
pure here
@ -291,9 +246,9 @@ downloadFromWithPeer peer thisBkSize h = do
pause rtt
zzz
void $ liftIO $ race ( pause (2 * rtt) ) $ atomically do
void $ liftIO $ race ( pause (8 * rtt) ) $ atomically do
void $ peekTQueue chuQ
flushTQueue chuQ
STM.flushTQueue chuQ
catched <- waity <&> either id id
@ -337,6 +292,7 @@ downloadFromWithPeer peer thisBkSize h = do
trace $ "PROCESS BLOCK" <+> pretty coo <+> pretty h
lift $ expire @e key
void $ liftIO $ putBlock sto block
deleteBlockFromQ h
onBlockDownloaded brains peer h
void $ processBlock h
else do
@ -362,6 +318,7 @@ downloadFromWithPeer peer thisBkSize h = do
trace $ "downloadFromWithPeer EXIT" <+> pretty coo
instance HasPeerLocator e m => HasPeerLocator e (BlockDownloadM e m) where
getPeerLocator = lift getPeerLocator
@ -426,6 +383,45 @@ updatePeerInfo onError _ pinfo = do
trimDown n s | IntSet.size s >= n = IntSet.deleteMax s
| otherwise = s
data ByFirst a b = ByFirst a b
instance Eq a => Eq (ByFirst a b) where
(==) (ByFirst a _) (ByFirst b _) = a == b
instance Hashable a => Hashable (ByFirst a b) where
hashWithSalt s (ByFirst a _) = hashWithSalt s a
data DTask =
DTask
{ _dtaskBlock :: Hash HbSync
, _dtaskBlockSize :: Integer
}
data DState e =
DState
{ _dPeerInbox :: TVar (HashMap (Peer e) (TBQueue DTask, [Async ()]))
}
data PState =
PIdle
| PWork DTask
| PCheckPeer
newDState :: forall e m . (MonadUnliftIO m, MyPeer e) => m (DState e)
newDState = DState @e <$> newTVarIO mempty
downloadOnBlockSize :: (MonadIO m, IsPeerAddr e m)
=> DownloadEnv e
-> (Peer e, Hash HbSync, Maybe Integer)
-> m ()
downloadOnBlockSize denv (p,h,size) = do
maybe1 size none $ \s -> do
debug $ "GOT BLOCK SIZE" <+> pretty h
onBlockSize (_downloadBrains denv) p h s
atomically $ writeTVar (_blockInDirty denv) True
blockDownloadLoop :: forall e m . ( m ~ PeerM e IO
, MonadIO m
, Request e (BlockInfo e) m
@ -455,158 +451,288 @@ blockDownloadLoop :: forall e m . ( m ~ PeerM e IO
=> DownloadEnv e -> m ()
blockDownloadLoop env0 = do
-- [dmz@minipig:~/w/hbs2]$ hbs2 cat 8is4yaZLi4sK3mPSS7Z9yrJK8dRXQyrcD54qe1GWi8qe | wc -c
-- 1278173938
-- MiB (RX Bytes/second)
-- 90.25 .....|.............||.....
-- 75.21 .....||||||..||||.|||.....
-- 60.17 ....||||||||||||||||||....
-- 45.13 ....||||||||||||||||||....
-- 30.08 ....|||||||||||||||||||...
-- 15.04 ::::|||||||||||||||||||:::
-- 1 15 20 25 30 35
-- MiB (RX Bytes/second)
-- 74.60 ......|||||..|||||||.|.|...
-- 62.17 ......||||||||||||||||||...
-- 49.74 ......||||||||||||||||||...
-- 37.30 ......|||||||||||||||||||..
-- 24.87 ......|||||||||||||||||||..
-- 12.43 :::::|||||||||||||||||||||:
-- 1 10 15 20 25 30
-- FIXME: asap-fix-async-spawning
e <- ask
let blks = mempty
pl <- getPeerLocator @e
sto <- getStorage
pause @'Seconds 3.81
let withAllStuff = withPeerM e . withDownload env0
-- FIXME: exception-handling
void $ liftIO $ async $ withPeerM e do
downloadMonLoop (view downloadMon env0)
flip runContT pure do
void $ liftIO $ async $ forever $ withPeerM e do
pause @'Seconds 30
-- FIXME: exception-handling
void $ ContT $ withAsync $ withPeerM e do
downloadMonLoop (view downloadMon env0)
void $ ContT $ withAsync $ forever $ withPeerM e do
pause @'Seconds 30
pee <- knownPeers @e pl
npi <- newPeerInfo
for_ pee $ \p -> do
pinfo <- fetch True npi (PeerInfoKey p) id
liftIO $ atomically $ writeTVar (view peerBurstMax pinfo) Nothing
void $ ContT $ withAsync $ forever $ withPeerM e do
pause @'Seconds 1.5
pee <- knownPeers @e pl
npi <- newPeerInfo
for_ pee $ \p -> do
pinfo <- fetch True npi (PeerInfoKey p) id
updatePeerInfo False p pinfo
void $ ContT $ withAsync $ withAllStuff do
brains <- asks (view downloadBrains)
q <- asks (view blockInQ)
let refs = liftIO $ readTVarIO q <&> HashMap.keys <&> fmap (,2)
polling (Polling 5 2.5) refs $ \h -> do
here <- hasBlock sto h <&> isJust
if here then do
deleteBlockFromQ h
else do
po <- shouldPostponeBlock @e brains h
when po do
postponeBlock h
void $ ContT $ withAsync $ forever $ withAllStuff do
printDownloadStats
-- inQ <- asks (view blockInQ)
-- brains <- asks (view downloadBrains)
-- void $ ContT $ withAsync (withPeerM e (preRequestSizes brains rcache inQ))
state <- liftIO $ newDState @e
cores <- liftIO getNumCapabilities
-- FIXME: limit-cores-number
trace $ "!@!! CORES !!!!!" <+> pretty cores
let inboxCap = 200
sizeRq <- newTBQueueIO (10 * inboxCap)
void $ ContT $ withAsync $ withAllStuff $ forever do
req <- atomically (readTBQueue sizeRq)
withPeerM e $ broadCastMessage @e req
void $ ContT $ withAsync $ withAllStuff $ forever do
q <- asks (view blockInQ)
dirty <- asks (view blockInDirty)
brains <- asks (view downloadBrains)
now <- liftIO getTimeCoarse
blocks <- readTVarIO q <&> HashMap.toList
>>= liftIO . shuffleM
for_ blocks $ \(block, status) -> void $ runMaybeT do
sst <- readTVarIO (_bsState status)
case sst of
BlkNew -> do
trace $ "GOT NEW BLOCK" <+> pretty block
atomically $ do
full <- isFullTBQueue sizeRq
unless full do
writeTVar (_bsState status) (BlkSizeAsked now)
writeTBQueue sizeRq (GetBlockSize @e block)
BlkSizeAsked t0 -> do
trace $ "BLOCK WAIT SIZE" <+> pretty block
ss <- readTVarIO (_dPeerInbox state)
candidates' <- for (HashMap.toList ss) $ \(peer, inbox) -> do
pinfo <- withPeerM e $ find (PeerInfoKey peer) id
rtt <- runMaybeT (toMPlus pinfo >>= medianPeerRTT >>= toMPlus)
<&> fmap (logBase 10 . realToFrac)
bs <- blockSize brains peer block
maybe1 bs (pure Nothing) $ \size -> do
should <- shouldDownloadBlock @e brains peer block
if not should
then pure Nothing
else do
pure (Just (peer, size, inbox))
candidate <- liftIO $ shuffleM (catMaybes candidates') <&> headMay
-- candidate <- pure (catMaybes candidates') <&> headMay
forM_ candidate $ \(_, size, inbox) -> do
-- поток-читатель исчез, по таймауту, скорее всего. ДИХСН.
-- может, в лог написать.
void $ liftIO $ try @_ @SomeException $ atomically do
full <- isFullTBQueue (fst inbox)
unless full do
writeTVar ( _bsState status) (BlkDownloadStarted now)
writeTBQueue (fst inbox) (DTask block size)
when (isNothing candidate && expired defBlockInfoTimeout (now - t0) ) do
-- на самом деле можно считать, и отправлять блоки в отстой
atomically $ writeTVar (_bsState status) BlkNew
BlkDownloadStarted t0 | expired (600 :: Timeout 'Seconds) (now - t0) -> do
here <- liftIO $ hasBlock sto block <&> isJust
if here then do
lift $ deleteBlockFromQ block
else do
trace $ "BLOCK DOWNLOAD FAIL" <+> pretty block
atomically $ writeTVar (_bsState status) BlkNew
_ -> none
-- FIXME: normal-waiting-for-what?
-- тут надо как-то моднее ждать
void $ race (pause @'Seconds 1) $ atomically do
readTVar dirty >>= STM.check
writeTVar dirty False
pee <- knownPeers @e pl
npi <- newPeerInfo
for_ pee $ \p -> do
pinfo <- fetch True npi (PeerInfoKey p) id
liftIO $ atomically $ writeTVar (view peerBurstMax pinfo) Nothing
lift $ withAllStuff do
brains <- asks (view downloadBrains)
dirty <- asks (view blockInDirty)
let refs = withPeerM e (getKnownPeers @e <&> fmap (,60))
polling (Polling 5 60) refs $ \peer -> do
debug $ "SOME FUCKING PEER:" <+> pretty peer
-- ШАГ 1. Поллим пиров, создаём новых, если для них нет зареганой очереди
here <- readTVarIO (_dPeerInbox state) <&> HashMap.member peer
-- ШАГ 2. Создаём тред + инбокс если нету
unless here do
q <- newTBQueueIO inboxCap
ass <- replicateM cores $ async $ flip runContT pure do
pinfo <- withPeerM e $ fetch True npi (PeerInfoKey peer) id
let downFail = view peerDownloadFail pinfo
let downBlk = view peerDownloadedBlk pinfo
void $ ContT $ bracket none $ const $ do
atomically do
m <- readTVar (_dPeerInbox state)
let v = HashMap.lookup peer m
forM_ v (STM.flushTBQueue . fst)
writeTVar (_dPeerInbox state) (HashMap.delete peer m)
-- pause @'Seconds 1
flip fix PIdle $ \next -> \case
PIdle -> do
what <- liftIO do
r <- race (pause @'Seconds 60)
(try @_ @SomeException (atomically $ readTBQueue q))
case r of
Left _ -> pure (Left True)
Right (Left{}) -> pure (Left False)
Right (Right x) -> pure (Right x)
case what of
Left True -> next PCheckPeer
Left False -> pure ()
Right todo -> do
next (PWork todo)
PCheckPeer -> do
debug $ "PEER CHECK" <+> pretty peer
auth <- withPeerM e (find (KnownPeerKey peer) id <&> isJust)
when auth do
next PIdle
debug "PEER FINISHING"
PWork (DTask{..}) -> do
debug $ "PEER IS WORKING" <+> pretty peer <+> pretty _dtaskBlock
let (p,h) = (peer, _dtaskBlock)
onBlockDownloadAttempt brains peer h
-- FIXME: ASAP-hardcode
r <- liftIO $ race ( pause ( 10 :: Timeout 'Seconds) )
$ withPeerM e
$ withDownload env0
$ downloadFromWithPeer peer _dtaskBlockSize _dtaskBlock
withPeerM e $ withDownload env0 do
case r of
Left{} -> do
-- liftIO $ atomically $ modifyTVar downFail succ
failedDownload p h
atomically $ modifyTVar downFail succ
debug $ "DOWNLOAD FAILED!" <+> pretty p <+> pretty h
-- addDownload Nothing h
Right{} -> do
deleteBlockFromQ h
liftIO $ atomically do
writeTVar downFail 0
modifyTVar downBlk succ
debug $ "DOWNLOAD SUCCEED" <+> pretty p <+> pretty h
next PIdle
void $ liftIO $ async $ forever $ withPeerM e do
pause @'Seconds 1.5
pee <- knownPeers @e pl
npi <- newPeerInfo
for_ pee $ \p -> do
pinfo <- fetch True npi (PeerInfoKey p) id
updatePeerInfo False p pinfo
atomically $ modifyTVar (_dPeerInbox state) (HashMap.insert peer (q, ass))
void $ liftIO $ async $ forever $ withAllStuff do
pause @'Seconds 5 -- FIXME: put to defaults
-- we need to show download stats
where
printDownloadStats = do
pause @'Seconds 5 -- FIXME: put to defaults
-- we need to show download stats
wipNum <- asks (view blockInQ) >>= liftIO . readTVarIO <&> HashMap.size
po <- postponedNum
q <- asks (view blockInQ)
notice $ "maintain blocks wip" <+> pretty wipNum
<+> "postponed"
<+> pretty po
busyPeers <- liftIO $ newTVarIO (mempty :: HashSet (Peer e))
released <- liftIO newTQueueIO
npi <- newPeerInfo
liftIO $ withAllStuff do
brains <- asks (view downloadBrains)
fix \next -> do
wipNum <- asks (view blockInQ) >>= liftIO . readTVarIO <&> HashMap.size
when (wipNum == 0) do
pause @'Seconds 1
next
allPips <- lift $ getKnownPeers @e
onKnownPeers brains allPips
pips <- flip filterM allPips $
\p -> liftIO do
busy <- readTVarIO busyPeers <&> HashSet.member p
pure $ not busy
when (List.null pips) do
void $ liftIO $ race (pause @'Seconds 5) $ do
trace "ALL PEERS BUSY"
void $ liftIO $ atomically $ do
p <- readTQueue released
ps <- flushTQueue released
for_ (p:ps) $ \x -> do
modifyTVar busyPeers (HashSet.delete x)
next
for_ pips $ \p -> do
h0 <- getBlockForDownload p
-- trace $ "getBlockForDownload" <+> pretty p <+> pretty h0
-- FIXME: busyloop-when-no-block-for-peer
maybe1 h0 (pure ()) $ \h -> do
liftIO $ atomically $ do
modifyTVar busyPeers (HashSet.insert p)
void $ liftIO $ async $ withAllStuff do
-- trace $ "start downloading shit" <+> pretty p <+> pretty h
lift $ onBlockDownloadAttempt brains p h
pinfo <- lift $ fetch True npi (PeerInfoKey p) id
size' <- blockSize brains p h
esize <- case size' of
Nothing -> do
doBlockSizeRequest p h
Just s -> pure (Right (Just s))
case esize of
Left{} -> pure ()
Right Nothing -> do
let downMiss = view peerDownloadMiss pinfo
liftIO $ atomically $ modifyTVar downMiss succ
Right (Just size) -> do
-- trace $ "BLOCK SIZE" <+> pretty p <+> pretty h <+> pretty size
let downFail = view peerDownloadFail pinfo
let downBlk = view peerDownloadedBlk pinfo
r <- liftIO $ race ( pause defBlockWaitMax )
$ withAllStuff
$ downloadFromWithPeer p size h
liftIO $ atomically $ writeTQueue released p
case r of
Left{} -> do
liftIO $ atomically $ modifyTVar downFail succ
failedDownload p h
Right{} -> do
onBlockDownloaded brains p h
liftIO $ withAllStuff $ processBlock h
liftIO $ atomically do
writeTVar downFail 0
modifyTVar downBlk succ
-- trace $ "exit download thread" <+> pretty p <+> pretty h
liftIO $ atomically $ writeTQueue released p
next
withDownload env0 do
mapM_ processBlock blks
proposed <- asks (view blockProposed)
void $ liftIO $ async $ forever do
pause @'Seconds 20
-- debug "block download loop. does not do anything"
liftIO $ Cache.purgeExpired proposed
wipNum <- liftIO (readTVarIO q) <&> HashMap.size
po <- postponedNum
notice $ "maintain blocks wip" <+> pretty wipNum
<+> "postponed"
<+> pretty po
postponedLoop :: forall e m . ( MyPeer e
, Sessions e (KnownPeer e) m
@ -676,7 +802,7 @@ doBlockSizeRequest peer h = do
liftIO $ race ( pause defBlockInfoTimeout )
( atomically $ do
s <- readTQueue q
void $ flushTQueue q
void $ STM.flushTQueue q
pure s
)

52
hbs2-peer/app/Brains.hs
View File

@ -23,6 +23,7 @@ import HBS2.System.Logger.Simple
import PeerConfig
import Control.Concurrent.STM
import Control.Applicative
import Control.Exception
import Control.Monad
import Control.Monad.Reader
@ -77,6 +78,8 @@ data BasicBrains e =
, _brainsDb :: Connection
, _brainsPipeline :: TQueue (IO ())
, _brainsCommit :: TQueue CommitCmd
, _brainsDelDownload :: TQueue (Hash HbSync)
, _brainsSizeCache :: Cache (Peer e, Hash HbSync) Integer
}
makeLenses 'BasicBrains
@ -132,12 +135,8 @@ instance ( Hashable (Peer e)
commitNow br True
onBlockSize b p h size = do
liftIO $ Cache.insert (_brainsSizeCache b) (p,h) size
updateOP b $ insertSize b p h size
commitNow b True
-- FIXME: wait-till-really-commited
-- sz <- liftIO $ selectBlockSize b p h
-- trace $ "BRAINS: onBlockSize" <+> pretty p <+> pretty h <+> pretty sz
pure ()
onBlockDownloadAttempt b peer h = do
-- trace $ "BRAINS: onBlockDownloadAttempt" <+> pretty peer <+> pretty h
@ -151,9 +150,11 @@ instance ( Hashable (Peer e)
onBlockDownloaded b p h = do
-- trace $ "BRAINS: onBlockDownloaded" <+> pretty p <+> pretty h
cleanupPostponed b h
-- cleanupPostponed b h
updateOP b do
insertPeer b h p
atomically $ writeTQueue (_brainsDelDownload b) h
-- deleteDownload b (HashRef h)
onBlockPostponed b h = do
-- trace $ "BRAINS: onBlockPostponed" <+> pretty h
@ -202,7 +203,9 @@ instance ( Hashable (Peer e)
pure $ mapMaybe fromStringMay r
blockSize b p h = do
liftIO $ selectBlockSize b p h
let cs = view brainsSizeCache b
found <- liftIO $ Cache.lookup cs (p,h)
maybe (liftIO $ selectBlockSize b p h) (pure . Just) found
isReflogProcessed b h = do
liftIO $ selectReflogProcessed b h
@ -570,7 +573,7 @@ SAVEPOINT zzz1;
DELETE FROM ancestors WHERE strftime('%s','now') - strftime('%s', ts) > 600;
DELETE FROM seenby WHERE strftime('%s','now') - strftime('%s', ts) > 600;
DELETE FROM blocksize WHERE strftime('%s','now') - strftime('%s', ts) > 300;
DELETE FROM blocksize WHERE strftime('%s','now') - strftime('%s', ts) > 1200;
DELETE FROM statedb.pexinfo where seen < datetime('now', '-7 days');
DELETE FROM seen where ts < datetime('now');
@ -851,6 +854,8 @@ newBasicBrains cfg = liftIO do
<*> pure conn
<*> newTQueueIO
<*> newTQueueIO
<*> newTQueueIO
<*> Cache.newCache (Just (toTimeSpec (1200:: Timeout 'Seconds)))
runBasicBrains :: forall e m . ( e ~ L4Proto
, MonadUnliftIO m
@ -865,12 +870,13 @@ runBasicBrains cfg brains = do
let pip = view brainsPipeline brains
let expire = view brainsExpire brains
let sizes = view brainsSizeCache brains
let commit = view brainsCommit brains
-- FIXME: async-error-handling
void $ liftIO $ async $ forever do
ewaiters <- race (pause @'Seconds 5) $ do
ewaiters <- race (pause @'Seconds 10) $ do
atomically $ do
c <- readTQueue commit
cs <- flushTQueue commit
@ -884,9 +890,15 @@ runBasicBrains cfg brains = do
transactional brains (sequence_ (w:ws))
sequence_ waiters
void $ liftIO $ async $ forever do
pause @'Seconds 60
updateOP brains (cleanupHashes brains)
void $ liftIO $ async do
del <- liftIO $ atomically $ flushTQueue (_brainsDelDownload brains)
forever do
pause @'Seconds 60
updateOP brains (cleanupHashes brains)
for_ del $ \d -> do
delDownload @e brains (HashRef d)
trace "runBasicBrains init"
@ -897,7 +909,7 @@ runBasicBrains cfg brains = do
] )
void $ async $ do
-- pause @'Seconds 5
pause @'Seconds 10
forM_ polls $ \(t,mi,x) -> do
trace $ "BRAINS: poll" <+> pretty t <+> pretty (AsBase58 x) <+> pretty mi
updateOP brains $ do
@ -907,14 +919,24 @@ runBasicBrains cfg brains = do
values (?,?,?)
on conflict do update set interval = excluded.interval
|] (show $ pretty (AsBase58 x), show $ pretty t, mi)
commitNow brains True
-- commitNow brains True
void $ forever do
pause @'Seconds 15
pause @'Seconds 20
ee <- liftIO $ Cache.toList expire
let eee = [ h | (h,_,Just{}) <- ee ]
forM_ eee $ \h -> do
cleanupPostponed brains h
liftIO $ Cache.purgeExpired expire
liftIO $ Cache.purgeExpired sizes
del <- liftIO $ atomically $ flushTQueue (_brainsDelDownload brains)
for_ del $ \d -> do
delDownload @e brains (HashRef d)

4
hbs2-peer/app/DownloadMon.hs
View File

@ -28,9 +28,9 @@ downloadMonLoop env = do
debug "I'm a download monitor"
-- FIXME: timeout-hardcodes
let refs = readTVarIO (view downloads env) <&> HashMap.keys <&> fmap (,2)
let refs = readTVarIO (view downloads env) <&> HashMap.keys <&> fmap (,10)
polling (Polling 2.5 1) refs $ \ref -> do
polling (Polling 2.5 2) refs $ \ref -> do
debug $ "DownloadMon. check" <+> pretty ref
done <- checkDownloaded ref
when done do

2
hbs2-peer/app/PeerInfo.hs
View File

@ -60,7 +60,7 @@ medianPeerRTT pinfo = do
pure $ median rttBuffer
rttBufferCapacity :: Int
rttBufferCapacity = 10
rttBufferCapacity = 1024
-- | New values are added to the head of the list, old values are discarded when the list is full.
insertRTT :: MonadIO m => Integer -> TVar [Integer] -> m ()

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

@ -646,7 +646,7 @@ runPeer opts = Exception.handle (\e -> myException e
let tcpProbeWait = runReader (cfgValue @PeerTcpProbeWaitKey) syn
& fromInteger @(Timeout 'Seconds) . fromMaybe 300
let downloadThreadNum = runReader (cfgValue @PeerDownloadThreadKey) syn & fromMaybe 2
-- let downloadThreadNum = runReader (cfgValue @PeerDownloadThreadKey) syn & fromMaybe 1
let useSocks5 = runReader (cfgValue @PeerTcpSOCKS5) syn
@ -1025,8 +1025,7 @@ runPeer opts = Exception.handle (\e -> myException e
peerThread "pexLoop" (pexLoop @e brains tcp)
replicateM_ downloadThreadNum do
peerThread "blockDownloadLoop" (blockDownloadLoop denv)
peerThread "blockDownloadLoop" (blockDownloadLoop denv)
peerThread "blockDownloadQ" (downloadQueue conf (SomeBrains brains) denv)
@ -1042,7 +1041,7 @@ runPeer opts = Exception.handle (\e -> myException e
peerThread "all protos" do
runProto @e
[ makeResponse (blockSizeProto blk dontHandle onNoBlock)
[ makeResponse (blockSizeProto blk (downloadOnBlockSize denv) onNoBlock)
, makeResponse (blockChunksProto adapter)
, makeResponse blockAnnounceProto
, makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter penv)

53
hbs2-peer/app/PeerTypes.hs
View File

@ -15,7 +15,6 @@ import HBS2.Clock
import HBS2.Data.Types.SignedBox
import HBS2.Data.Types.Peer
import HBS2.Data.Types.Refs
import HBS2.Data.Detect
import HBS2.Defaults
import HBS2.Events
import HBS2.Hash
@ -38,8 +37,6 @@ import Brains
import PeerConfig
import Prelude hiding (log)
import Data.Foldable (for_)
import Control.Concurrent.Async
import Control.Monad.Reader
import Control.Monad.Writer qualified as W
import Data.ByteString.Lazy (ByteString)
@ -56,15 +53,12 @@ import Data.IntMap (IntMap)
import Data.IntSet (IntSet)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as TE
import Data.Heap qualified as Heap
import Data.Heap (Entry(..))
import Data.Time.Clock
import Data.Word
import Data.List qualified as List
import Data.Set qualified as Set
import Data.Set (Set)
import UnliftIO.STM
import UnliftIO
import Streaming.Prelude qualified as S
@ -163,6 +157,7 @@ instance Expires (EventKey e (DownloadReq e)) where
type DownloadFromPeerStuff e m = ( MyPeer e
, MonadIO m
, MonadUnliftIO m
, ForSignedBox e
, Request e (BlockInfo e) m
, Request e (BlockChunks e) m
@ -215,12 +210,16 @@ newtype instance SessionKey e (BlockChunks e) =
deriving newtype instance Hashable (SessionKey L4Proto (BlockChunks L4Proto))
deriving stock instance Eq (SessionKey L4Proto (BlockChunks L4Proto))
data BlkS =
BlkNew
| BlkSizeAsked TimeSpec
| BlkDownloadStarted TimeSpec
data BlockState =
BlockState
{ _bsStart :: TimeSpec
, _bsReqSizeTimes :: TVar Int
, _bsLastSeen :: TVar TimeSpec
, _bsHasSize :: TVar Bool
{ _bsStart :: TimeSpec
, _bsWip :: Maybe TimeSpec
, _bsState :: TVar BlkS
}
makeLenses 'BlockState
@ -246,8 +245,11 @@ downloadMonAdd env h whenDone = do
data DownloadEnv e =
DownloadEnv
{ _blockInQ :: TVar (HashMap (Hash HbSync) ())
, _blockPostponed :: TVar (HashMap (Hash HbSync) () )
{ _blockInQ :: TVar (HashMap (Hash HbSync) BlockState)
, _blockInDirty :: TVar Bool
-- FIXME: trim!!
, _blockSizeCache :: TVar (HashMap (Hash HbSync) (HashMap (Peer e) Integer))
, _blockPostponed :: TVar (HashMap (Hash HbSync) () )
, _blockPostponedTo :: Cache (Hash HbSync) ()
, _blockDelayTo :: TQueue (Hash HbSync)
, _blockProposed :: Cache (Hash HbSync, Peer e) ()
@ -261,6 +263,8 @@ makeLenses 'DownloadEnv
newDownloadEnv :: (MonadIO m, MyPeer e, HasBrains e brains) => brains -> m (DownloadEnv e)
newDownloadEnv brains = liftIO do
DownloadEnv <$> newTVarIO mempty
<*> newTVarIO False
<*> newTVarIO mempty
<*> newTVarIO mempty
<*> Cache.newCache (Just defBlockBanTime)
<*> newTQueueIO
@ -274,6 +278,7 @@ newtype BlockDownloadM e m a =
, Applicative
, Monad
, MonadIO
, MonadUnliftIO
, MonadReader (DownloadEnv e)
, MonadTrans
)
@ -308,14 +313,22 @@ addDownload :: forall e m . ( DownloadConstr e m
addDownload mbh h = do
tinq <- asks (view blockInQ)
dirty <- asks (view blockInDirty)
brains <- asks (view downloadBrains)
here <- isBlockHereCached h
if here then do
removeFromWip h
else do
newBlock <- BlockState
<$> liftIO getTimeCoarse
<*> pure Nothing
<*> liftIO (newTVarIO BlkNew)
claimBlockCameFrom @e brains mbh h
liftIO $ atomically $ modifyTVar tinq $ HashMap.insert h ()
liftIO $ atomically $ do
modifyTVar tinq $ HashMap.insert h newBlock
writeTVar dirty True
postponedNum :: forall e m . (MyPeer e, MonadIO m) => BlockDownloadM e m Int
postponedNum = do
@ -333,6 +346,16 @@ delayLittleBit h = do
q <- asks (view blockDelayTo)
liftIO $ atomically $ writeTQueue q h
deleteBlockFromQ :: MonadIO m => Hash HbSync -> BlockDownloadM e m ()
deleteBlockFromQ h = do
inq <- asks (view blockInQ)
po <- asks (view blockPostponed)
ca <- asks (view blockSizeCache)
liftIO $ atomically $ modifyTVar' inq (HashMap.delete h)
liftIO $ atomically $ modifyTVar' po (HashMap.delete h)
liftIO $ atomically $ modifyTVar' po (HashMap.delete h)
liftIO $ atomically $ modifyTVar' ca (HashMap.delete h)
postponeBlock :: forall e m . (MyPeer e, MonadIO m) => Hash HbSync -> BlockDownloadM e m ()
postponeBlock h = do
@ -484,7 +507,7 @@ checkDownloaded :: forall m . (MonadIO m, HasStorage m) => HashRef -> m Bool
checkDownloaded hr = do
sto <- getStorage
missed <- findMissedBlocks sto hr
missed <- S.head_ $ findMissedBlocks2 sto hr
pure $ null missed

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

@ -10,7 +10,7 @@ license-file: LICENSE
-- copyright:
category: Network
build-type: Simple
extra-doc-files: CHANGELOG.md
-- extra-doc-files: CHANGELOG.md
-- extra-source-files:
common warnings
@ -57,6 +57,7 @@ common common-deps
, time
, timeit
, transformers
, typed-process
, uniplate
, unordered-containers
, vector
@ -89,7 +90,7 @@ common shared-properties
-- -fno-warn-unused-binds
-threaded
-rtsopts
"-with-rtsopts=-N4 -A64m -AL256m -I0 -T"
"-with-rtsopts=-N -A64m -AL256m -I0 -T"
default-language: Haskell2010
@ -148,6 +149,7 @@ library
HBS2.Peer.RPC.Client.StorageClient
HBS2.Peer.RPC.Internal.Storage
HBS2.Peer.RPC.Internal.Types
HBS2.Peer.CLI.Detect
other-modules:

0
hbs2-share/src/HBS2/Peer/CLI/Detect.hs → hbs2-peer/lib/HBS2/Peer/CLI/Detect.hs
View File

2
hbs2-qblf/hbs2-qblf.cabal
View File

@ -10,7 +10,7 @@ maintainer: dzuikov@gmail.com
-- copyright:
category: Network
build-type: Simple
extra-doc-files: CHANGELOG.md
-- extra-doc-files: CHANGELOG.md
-- extra-source-files:
common shared-properties

3
hbs2-share/hbs2-share.cabal
View File

@ -10,7 +10,7 @@ maintainer: dzuikov@gmail.com
-- copyright:
category: System
build-type: Simple
extra-doc-files: CHANGELOG.md
-- extra-doc-files: CHANGELOG.md
-- extra-source-files:
common shared-properties
@ -96,7 +96,6 @@ library
HBS2.Share.MetaData
other-modules:
HBS2.Peer.CLI.Detect
-- other-modules:
-- other-extensions:

2
hbs2-storage-simple/hbs2-storage-simple.cabal
View File

@ -10,7 +10,7 @@ license-file: LICENSE
-- copyright:
category: Database
build-type: Simple
extra-doc-files: CHANGELOG.md
-- extra-doc-files: CHANGELOG.md
-- extra-source-files:
common shared-properties

6
hbs2-tests/hbs2-tests.cabal
View File

@ -10,7 +10,7 @@ license-file: LICENSE
-- copyright:
category: Network
build-type: Simple
extra-doc-files: CHANGELOG.md
-- extra-doc-files: CHANGELOG.md
-- extra-source-files:
common warnings
@ -945,6 +945,7 @@ executable test-playground
, unliftio
, unordered-containers
, resourcet
, text-icu >= 0.8.0.3
executable test-repo-export
@ -981,11 +982,12 @@ executable test-repo-export
, temporary
, unliftio
, unordered-containers
, bloomfilter >=2.0.1.2
, timeit
, memory
, deepseq
, xxhash-ffi
, optparse-generic
, interpolatedstring-perl6

235
hbs2-tests/repo-export/RepoExportMain.hs
View File

@ -29,34 +29,14 @@ import Data.ByteString.Lazy (ByteString)
import Codec.Serialise
import Data.Maybe
import Data.HashSet qualified as HS
import Data.Vector qualified as V
import Data.Vector ((!))
import Data.HashSet (HashSet)
import Data.HashSet qualified as HashSet
import Data.ByteArray.Hash (SipHash(..), SipKey(..))
import Data.ByteArray.Hash qualified as BA
import Text.InterpolatedString.Perl6 (qc)
import System.TimeIt
-- import Data.BloomFilter.Easy qualified as B
import Data.BloomFilter qualified as B
import Data.BloomFilter.Easy qualified as B
import Data.BloomFilter.Hash qualified as B
import Control.Concurrent.STM (flushTQueue)
import Control.DeepSeq (deepseq)
import Data.Bits
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.Word
import Data.Bits
import Data.Vector.Mutable qualified as V
import Data.IntMap qualified as IntMap
import Data.IntMap (IntMap)
import Data.Hashable
import Data.Digest.XXHash.FFI
import Streaming.Prelude qualified as S
-- import Control.Concurrent.BloomFilter qualified as U
import Options.Generic
data RPCEndpoints =
RPCEndpoints
@ -102,130 +82,113 @@ runWithRPC action = do
void $ waitAnyCatchCancel [messaging, c1]
data CLI = CLI { nThreads :: Maybe Int }
deriving (Generic)
instance ParseRecord CLI
doAlter :: (Bits a1, Integral a2, Num a1) => a2 -> Maybe a1 -> Maybe a1
doAlter j = \case
Nothing -> Just (setBit 0 (fromIntegral j))
Just x -> Just (setBit x (fromIntegral j))
{-# INLINE doAlter #-}
main :: IO ()
main = do
ls <- LBS8.readFile "input.txt" <&> LBS8.lines
bs <- gitRunCommand [qc|git cat-file --batch-check='%(objectname)' --batch-all-object --unordered --buffer|]
>>= orThrowUser "oopsie"
let ls = LBS8.lines bs -- & HashSet.fromList
print $ length ls
z <- newIORef 0
let (sz, hn) = B.suggestSizing 5000000 0.01
let bloom = B.fromList (\s -> [ xxh32 (LBS.toStrict s) x | x <- [1 .. fromIntegral hn] ]) sz ls
-- let bloom = B.fromList (\s -> [ xxh32 (LBS.toStrict s) x | x <- [1 .. fromIntegral 2] ]) sz ls
-- let bloom = B.fromList (\s -> [ fromIntegral (hashWithSalt x ls) | x <- [1 .. hn] ]) sz ls
print $ B.length bloom
-- v <- V.new @_ @Word8 (sz `div` 8)
-- thm <- newIORef (HashMap.empty @Word64 @Word64)
-- thi <- newIORef (IntMap.empty @Word64)
-- tvm <- newTVarIO (HashMap.empty @Word64 @Word64)
-- tq <- newTQueueIO
-- haha <- for ls $ \s -> do
-- let hashes = [ xxh32 s x `mod` fromIntegral sz | x <- [1 .. 7] ]
-- vals <- for hashes $ \h -> do
-- let (w,b) = h `divMod` 64
-- pure (w, setBit 0 (fromIntegral b) :: Word64)
-- pure $ HashMap.fromListWith (.|.) vals
-- let result = HashMap.unions haha
-- print $ length result
-- for_ hashes $ \i -> do
-- let (w,b) = i `divMod` 64
-- pure
-- pure ()
-- atomically $ mapM_ (writeTQueue tq) hashes
-- print "FUCK!"
-- pure ()
-- modifyIORef thm (HashMap.alter (doAlter j) (fromIntegral i))
-- w <- readIORef z
-- print w
-- let bloom = B.easyList 0.01 ls
-- print $ B.length bloom
--dir <- findGitDir "." >>= orThrowUser "not a git dir"
--flip runContT pure do
-- o <- gitListAllObjects
-- ep <- ContT runWithRPC
-- let sto = StorageClient (rpcStorage ep)
-- cat <- startGitCatFile
-- -- h <- gitGetHash "HEAD" >>= orThrowUser "wtf1"
-- -- rvl <- gitRevList Nothing h
-- --
-- items <- for o $ \(a,GitHash b) -> do
-- pure b
-- liftIO $ print $ "bloom params" <+> pretty (B.suggestSizing (length items) 0.01)
-- timeItNamed (show $ "build bloom filter" <+> pretty (length items)) do
-- let bloom = B.easyList 0.01 items
-- liftIO $ print $ "bloom filter size" <+> pretty (B.length bloom) <> line
-- <> "data size" <+> pretty (LBS.length (serialise items))
-- timeItNamed "calc siphashes" do
-- let w = 67108864
-- tvm <- newTVarIO (HashMap.empty @Word64 @Bool)
-- -- q <- newTQueueIO
-- for_ items $ \it -> do
-- for_ (B.cheapHashes 7 it) $ \hx -> do
-- let k = fromIntegral (hx `mod` w)
-- atomically $ modifyTVar tvm (HashMap.insert k True)
main1 :: IO ()
main1 = do
dir <- findGitDir "." >>= orThrowUser "not a git dir"
-- wtf <- liftIO $ readTVarIO tvm
-- liftIO $ print $ length wtf
let hrs = [ "A9Y5k28STYMg2XGUA5xwpAU3CcQg3Fh5j56E4v1QYV7A"
, "BZuMNqPy1vpxev4H5yKJ4TjTHrZ5HAqPzxDM1ZN74XY2"
, "Bs2jEFJTSQnY7z5nActjBBanCEWSYnbzUzC41xhhHwtX"
, "2rZxtNqi8haDEhQkVd2v1ddSfDub9bMH4BB9tgwqvxCF"
, "Fe1cLjj9BPqHcLowTNwZvHkwT7tAL7dywBocdN3VYeMn"
] :: [HashRef]
-- liftIO $ print $ LBS.length $ serialise bloom
let pt = toPTree (MaxSize 256) (MaxNum 256) hrs
root <- makeMerkle 0 pt $ \(hx,_,bss) -> do
liftIO $ print $ "block:" <+> pretty hx
print $ pretty root
error "stop"
(CLI mn) <- getRecord "export git repo"
let n = fromMaybe 1 mn
flip runContT pure do
o <- gitListAllObjects
ep <- ContT runWithRPC
let sto = StorageClient (rpcStorage ep)
ou <- newTQueueIO
qqs <- V.fromList <$> replicateM n newTQueueIO
w <- liftIO $ async do
for_ (zip [0..] o) $ \(i,x) -> do
let j = i `mod` V.length qqs
atomically $ writeTQueue (qqs ! j) (Just x)
for_ qqs $ \q -> do
atomically $ writeTQueue q Nothing
ws <- liftIO $ for (V.toList qqs) $ \q -> async do
cat <- startGitCatFile
fix \next -> do
e <- atomically $ readTQueue q
case e of
Nothing -> pure ()
Just (_,h) -> do
void $ runMaybeT do
GitObject t lbs <- toMPlus =<< gitReadFromCatFileBatch cat h
atomically $ writeTQueue ou (t, h, LBS.length lbs)
next
wou <- liftIO $ async do
fix \next -> do
r <- atomically $ readTQueue ou
print $ pretty r
next
mapM_ wait (w:ws)
cancel wou
-- for_ [q1, q2] -> do
-- cat2 <- startGitCatFile
-- h <- gitGetHash "HEAD" >>= orThrowUser "wtf1"
-- rvl <- gitRevList Nothing h
-- liftIO do
-- allShit' <- for o $ \r@(o,h) -> runMaybeT do
-- GitObject t lbs <- toMPlus =<< gitReadFromCatFileBatch cat h
-- liftIO $ print $ pretty (t, h)
-- ght <- writeAsMerkle sto lbs
-- for_ o $ \r@(o,h) -> runMaybeT do
-- pure ()
-- GitObject t lbs <- toMPlus =<< gitReadFromCatFileBatch cat h
-- liftIO $ print $ pretty (t, h, LBS.length lbs)
-- ght <- writeAsMerkle sto lbs
-- tt <- getBlock sto ght
-- >>= toMPlus
-- >>= orThrowUser "FUCK" . (deserialiseOrFail @(MTree [HashRef]))
-- tt <- getBlock sto ght
-- >>= toMPlus
-- >>= orThrowUser "FUCK" . (deserialiseOrFail @(MTree [HashRef]))
-- let txt = fromString (show $ pretty t)
-- let ann = MTreeAnn (ShortMetadata txt) NullEncryption tt
-- putBlock sto (serialise ann) >>= toMPlus
-- let txt = fromString (show $ pretty t)
-- let ann = MTreeAnn (ShortMetadata txt) NullEncryption tt
-- putBlock sto (serialise ann) >>= toMPlus
-- let pt = HS.fromList (HashRef <$> catMaybes allShit')
-- & HS.toList
-- & toPTree (MaxSize 256) (MaxNum 256)
-- let pt = HS.fromList (HashRef <$> catMaybes allShit')
-- & HS.toList
-- & toPTree (MaxSize 256) (MaxNum 256)
-- ht <- makeMerkle 0 pt $ \(_,_,bss) -> do
-- void $ putBlock sto bss
-- ht <- makeMerkle 0 pt $ \(_,_,bss) -> do
-- void $ putBlock sto bss
-- print $ pretty (HashRef ht)
-- print $ pretty (HashRef ht)

2
hbs2/hbs2.cabal
View File

@ -10,7 +10,7 @@ license-file: LICENSE
-- copyright:
category: Network
build-type: Simple
extra-doc-files: CHANGELOG.md
-- extra-doc-files: CHANGELOG.md
-- extra-source-files:

220
nix/peer/flake.lock
View File

@ -1,16 +1,38 @@
{
"nodes": {
"db-pipe": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils",
"nixpkgs": [
"hbs2",
"nixpkgs"
]
},
"locked": {
"lastModified": 1700834043,
"narHash": "sha256-VDExjkJ2maIP+Baw5V3fhmRtJ4nHpQV/Fxg1H8g69ME=",
"ref": "refs/heads/master",
"rev": "6050d7949f390c4717293d1d410123439e0fda67",
"revCount": 6,
"type": "git",
"url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
},
"original": {
"type": "git",
"url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
}
},
"extra-container": {
"inputs": {
"flake-utils": "flake-utils",
"nixpkgs": "nixpkgs"
},
"locked": {
"lastModified": 1678566036,
"narHash": "sha256-dq+gCYplCTkbHOH1ERCzuTnwY/RvwMyw/kijPy7C3vE=",
"lastModified": 1699821751,
"narHash": "sha256-UlId5jvJFmkVcKpn0oZ2VTvWAc/mZy6butRZGk73xXM=",
"owner": "erikarvstedt",
"repo": "extra-container",
"rev": "a4fe3227bf63bf8479938e1457ebe1c04fe51ef5",
"rev": "842912907bf189ef17a80ca09ba37b6bdfc76c49",
"type": "github"
},
"original": {
@ -21,7 +43,7 @@
},
"fixme": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils",
"haskell-flake-utils": "haskell-flake-utils_2",
"nixpkgs": [
"hbs2",
"nixpkgs"
@ -29,26 +51,29 @@
"suckless-conf": "suckless-conf"
},
"locked": {
"lastModified": 1679822846,
"narHash": "sha256-bXGorR8cLCVm3Cu7EcTUGNtaxPwqZH8zLrch7r/ST5c=",
"owner": "voidlizard",
"repo": "fixme",
"rev": "ff3faeeee860b2ed2edf6e69cec26e9b49b167a3",
"type": "github"
"lastModified": 1697356303,
"narHash": "sha256-hJbJZtx7gdcXaKL8n5J8b/eVyoYe9VxM+037ZK7q8Gw=",
"ref": "refs/heads/master",
"rev": "e9b1dcfd78dc766a2255a8125c14b24f0d728c0e",
"revCount": 139,
"type": "git",
"url": "https://git.hbs2.net/Fujv1Uy4W5d9Z7REEArMxbXSJ8nLLn4dYuvaAs8b86hr"
},
"original": {
"owner": "voidlizard",
"repo": "fixme",
"type": "github"
"type": "git",
"url": "https://git.hbs2.net/Fujv1Uy4W5d9Z7REEArMxbXSJ8nLLn4dYuvaAs8b86hr"
}
},
"flake-utils": {
"inputs": {
"systems": "systems"
},
"locked": {
"lastModified": 1667395993,
"narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=",
"lastModified": 1685518550,
"narHash": "sha256-o2d0KcvaXzTrPRIo0kOLV0/QXHhDQ5DTi+OxcjO8xqY=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f",
"rev": "a1720a10a6cfe8234c0e93907ffe81be440f4cef",
"type": "github"
},
"original": {
@ -132,16 +157,31 @@
"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"
}
},
"haskell-flake-utils": {
"inputs": {
"flake-utils": "flake-utils_2"
},
"locked": {
"lastModified": 1672412555,
"narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
"lastModified": 1698938553,
"narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=",
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
"rev": "19b273b5dc401a0a565e7f75cf50a593871b80c9",
"type": "github"
},
"original": {
@ -182,7 +222,6 @@
},
"original": {
"owner": "ivanovs-4",
"ref": "master",
"repo": "haskell-flake-utils",
"type": "github"
}
@ -192,17 +231,17 @@
"flake-utils": "flake-utils_5"
},
"locked": {
"lastModified": 1672412555,
"narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
"lastModified": 1698938553,
"narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=",
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
"rev": "19b273b5dc401a0a565e7f75cf50a593871b80c9",
"type": "github"
},
"original": {
"owner": "ivanovs-4",
"ref": "master",
"repo": "haskell-flake-utils",
"rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
"type": "github"
}
},
@ -218,6 +257,25 @@
"rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
"type": "github"
},
"original": {
"owner": "ivanovs-4",
"repo": "haskell-flake-utils",
"rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
"type": "github"
}
},
"haskell-flake-utils_6": {
"inputs": {
"flake-utils": "flake-utils_7"
},
"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",
@ -226,8 +284,9 @@
},
"hbs2": {
"inputs": {
"db-pipe": "db-pipe",
"fixme": "fixme",
"haskell-flake-utils": "haskell-flake-utils_3",
"haskell-flake-utils": "haskell-flake-utils_4",
"hspup": "hspup",
"nixpkgs": [
"nixpkgs"
@ -236,33 +295,31 @@
"suckless-conf": "suckless-conf_2"
},
"locked": {
"lastModified": 1681115037,
"narHash": "sha256-CovUWmx6Pup3p/6zhIBAltJiUlh2ukFAI1P4U/vnXNw=",
"owner": "voidlizard",
"repo": "hbs2",
"rev": "21fb2d844076f8b380847854ebbd75cac57e3424",
"type": "github"
"lastModified": 1707584207,
"narHash": "sha256-y4JimRbs6Edfhh1UnJLdX1jrnfcTFmAU+h89ir23gno=",
"rev": "039d2bfefcd11f67ed957a71d650e877f8500611",
"revCount": 1062,
"type": "git",
"url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
},
"original": {
"owner": "voidlizard",
"ref": "injecting-tcp",
"repo": "hbs2",
"type": "github"
"rev": "039d2bfefcd11f67ed957a71d650e877f8500611",
"type": "git",
"url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
}
},
"home-manager": {
"inputs": {
"nixpkgs": [
"nixpkgs"
],
"utils": "utils"
]
},
"locked": {
"lastModified": 1679394816,
"narHash": "sha256-1V1esJt2YAxsKmRuGuB62RF5vhDAVFDvJXVNhtEO22A=",
"lastModified": 1707467182,
"narHash": "sha256-/Bw/xgCXfj4nXDd8Xq+r1kaorfsYkkomMf5w5MpsDyA=",
"owner": "nix-community",
"repo": "home-manager",
"rev": "e386ec640e16dc91120977285cb8c72c77078164",
"rev": "5b9156fa9a8b8beba917b8f9adbfd27bf63e16af",
"type": "github"
},
"original": {
@ -273,7 +330,7 @@
},
"hspup": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils_4",
"haskell-flake-utils": "haskell-flake-utils_5",
"nixpkgs": [
"hbs2",
"nixpkgs"
@ -295,42 +352,27 @@
},
"nixpkgs": {
"locked": {
"lastModified": 1669833724,
"narHash": "sha256-/HEZNyGbnQecrgJnfE8d0WC5c1xuPSD2LUpB6YXlg4c=",
"lastModified": 1685566663,
"narHash": "sha256-btHN1czJ6rzteeCuE/PNrdssqYD2nIA4w48miQAFloM=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "4d2b37a84fad1091b9de401eb450aae66f1a741e",
"rev": "4ecab3273592f27479a583fb6d975d4aba3486fe",
"type": "github"
},
"original": {
"owner": "NixOS",
"ref": "22.11",
"ref": "23.05",
"repo": "nixpkgs",
"type": "github"
}
},
"nixpkgs_2": {
"locked": {
"lastModified": 1675758091,
"narHash": "sha256-7gFSQbSVAFUHtGCNHPF7mPc5CcqDk9M2+inlVPZSneg=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "747927516efcb5e31ba03b7ff32f61f6d47e7d87",
"type": "github"
},
"original": {
"owner": "NixOS",
"repo": "nixpkgs",
"type": "github"
}
},
"nixpkgs_3": {
"locked": {
"lastModified": 1679319606,
"narHash": "sha256-wyEMIZB6BnsmJWInEgDZu66hXVMGJEZFl5uDsn27f9M=",
"lastModified": 1707451808,
"narHash": "sha256-UwDBUNHNRsYKFJzyTMVMTF5qS4xeJlWoeyJf+6vvamU=",
"owner": "nixos",
"repo": "nixpkgs",
"rev": "8bc6945b1224a1cfa679d6801580b1054dba1a5c",
"rev": "442d407992384ed9c0e6d352de75b69079904e4e",
"type": "github"
},
"original": {
@ -345,7 +387,7 @@
"extra-container": "extra-container",
"hbs2": "hbs2",
"home-manager": "home-manager",
"nixpkgs": "nixpkgs_3"
"nixpkgs": "nixpkgs_2"
}
},
"saltine": {
@ -367,15 +409,19 @@
},
"suckless-conf": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils_2",
"nixpkgs": "nixpkgs_2"
"haskell-flake-utils": "haskell-flake-utils_3",
"nixpkgs": [
"hbs2",
"fixme",
"nixpkgs"
]
},
"locked": {
"lastModified": 1679815688,
"narHash": "sha256-xLvIoeG5krM0CXfWRcwSgHGP7W8i8dsoKP5hUb182hE=",
"lastModified": 1697354514,
"narHash": "sha256-5doedGj2QU4vPuw1VZor1GGEJTxu0zFeO/PsybFIcn8=",
"owner": "voidlizard",
"repo": "suckless-conf",
"rev": "04c432681d3627f180a402674523736f409f964d",
"rev": "3f87278bc10ac4f14a6d9d2c75cbbed228509129",
"type": "github"
},
"original": {
@ -386,38 +432,38 @@
},
"suckless-conf_2": {
"inputs": {
"haskell-flake-utils": "haskell-flake-utils_5",
"haskell-flake-utils": "haskell-flake-utils_6",
"nixpkgs": [
"hbs2",
"nixpkgs"
]
},
"locked": {
"lastModified": 1679815688,
"narHash": "sha256-xLvIoeG5krM0CXfWRcwSgHGP7W8i8dsoKP5hUb182hE=",
"owner": "voidlizard",
"repo": "suckless-conf",
"rev": "04c432681d3627f180a402674523736f409f964d",
"type": "github"
"lastModified": 1704001322,
"narHash": "sha256-D7T/8wAg5J4KkRw0uB90w3+adY11aQaX7rjmQPXkkQc=",
"ref": "refs/heads/master",
"rev": "8cfc1272bb79ef6ad62ae6a625f21e239916d196",
"revCount": 28,
"type": "git",
"url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"
},
"original": {
"owner": "voidlizard",
"repo": "suckless-conf",
"type": "github"
"type": "git",
"url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"
}
},
"utils": {
"systems": {
"locked": {
"lastModified": 1676283394,
"narHash": "sha256-XX2f9c3iySLCw54rJ/CZs+ZK6IQy7GXNY4nSOyu2QG4=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "3db36a8b464d0c4532ba1c7dda728f4576d6d073",
"lastModified": 1681028828,
"narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
"owner": "nix-systems",
"repo": "default",
"rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"owner": "nix-systems",
"repo": "default",
"type": "github"
}
}

65
nix/peer/flake.nix
View File

@ -1,11 +1,12 @@
# See how this flake is used in ./usage.sh
# on host: sudo sysctl -w net.ipv4.ip_forward=1
{
description = "hbs2-container";
inputs = {
extra-container.url = "github:erikarvstedt/extra-container";
nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
hbs2.url = "github:voidlizard/hbs2/injecting-tcp";
hbs2.url = "git+http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP?rev=039d2bfefcd11f67ed957a71d650e877f8500611";
hbs2.inputs.nixpkgs.follows = "nixpkgs";
home-manager.url = "github:nix-community/home-manager";
@ -27,28 +28,68 @@
# If unset, the nixpkgs input of extra-container flake is used
nixpkgs = inputs.nixpkgs;
# home-manager.homeConfigurations = {
# # FIXME replace with your username@hostname
# "root@minipig" = home-manager.lib.homeManagerConfiguration {
# pkgs = nixpkgs.legacyPackages.x86_64-linux; # Home-manager requires 'pkgs' instance
# extraSpecialArgs = { inherit inputs; }; # Pass flake inputs to our config
# # > Our main home-manager configuration file <
# modules = [ ./home/home.nix ];
# };
# };
# Set this to disable `nix run` support
# addRunner = false;
config = {
containers.hbs2-test = {
extra.addressPrefix = "10.250.0";
extra = {
addressPrefix = "10.250.0";
exposeLocalhost = true;
firewallAllowHost = true;
enableWAN = true;
};
config = { pkgs, ... }: {
imports = [
home-manager.nixosModules.home-manager
{
home-manager.useGlobalPkgs = true;
home-manager.useUserPackages = true;
home-manager.users.hbs2 = {
# import ./config/home.nix;
home.stateVersion = "23.05";
xdg.configFile = {
".hbs2-peer/config".text = ''
;; hbs2-peer config file
listen "0.0.0.0:7351"
listen-tcp "0.0.0.0:10351"
known-peer "10.250.0.1:7354"
; edit path to a keyring file
; key "./key"
key "./default.key"
'';
};
};
home-manager.extraSpecialArgs = {
# inherit inputs;
};
}
];
# settings.trusted-users = [ "root" "hbs2" ];
nix = {
package = pkgs.nixFlakes;
extraOptions = ''
experimental-features = nix-command flakes
'';
#settings.trusted-users = [ "root" "dmz" ];
};
users.users.hbs2 = {
isNormalUser = true;
home = "/home/hbs2";
packages = with pkgs; [];
};
systemd.services.hello = {
@ -99,10 +140,8 @@ http-port 5001
key "./key"
storage "/root/.local/share/hbs2"
accept-block-announce *
download-log "/tmp/download-log"
bootstrap-dns "bootstrap.hbs2.net"
known-peer "10.250.0.1:7354"
known-peer "10.250.0.1:7351"
; poll reflog 1 "2YNGdnDBnciF1Kgmx1EZTjKUp1h5pvYAjrHoApbArpeX"