diff --git a/Makefile b/Makefile index b923cd36..8f0a2388 100644 --- a/Makefile +++ b/Makefile @@ -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 + diff --git a/docs/devlog.md b/docs/devlog.md index 5a684112..ee663673 100644 --- a/docs/devlog.md +++ b/docs/devlog.md @@ -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 стилей. diff --git a/examples/raft-algo/raft-algo.cabal b/examples/raft-algo/raft-algo.cabal index 6413302e..5e3bf677 100644 --- a/examples/raft-algo/raft-algo.cabal +++ b/examples/raft-algo/raft-algo.cabal @@ -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 diff --git a/examples/refchan-qblf/refchan-qblf.cabal b/examples/refchan-qblf/refchan-qblf.cabal index bfe83452..b64e6573 100644 --- a/examples/refchan-qblf/refchan-qblf.cabal +++ b/examples/refchan-qblf/refchan-qblf.cabal @@ -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 diff --git a/flake.lock b/flake.lock index 48a3106b..b3c9df26 100644 --- a/flake.lock +++ b/flake.lock @@ -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": { diff --git a/flake.nix b/flake.nix index 387b57ce..cf45a0e2 100644 --- a/flake.nix +++ b/flake.nix @@ -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 ''; }; diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 35e12416..be11de5a 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -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 diff --git a/hbs2-core/lib/HBS2/Clock.hs b/hbs2-core/lib/HBS2/Clock.hs index 9ab209d9..93d83a90 100644 --- a/hbs2-core/lib/HBS2/Clock.hs +++ b/hbs2-core/lib/HBS2/Clock.hs @@ -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 diff --git a/hbs2-core/lib/HBS2/Defaults.hs b/hbs2-core/lib/HBS2/Defaults.hs index 933fd114..2d31a5d8 100644 --- a/hbs2-core/lib/HBS2/Defaults.hs +++ b/hbs2-core/lib/HBS2/Defaults.hs @@ -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! diff --git a/hbs2-core/lib/HBS2/Misc/PrettyStuff.hs b/hbs2-core/lib/HBS2/Misc/PrettyStuff.hs new file mode 100644 index 00000000..bf5d7eff --- /dev/null +++ b/hbs2-core/lib/HBS2/Misc/PrettyStuff.hs @@ -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 + + + diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Encrypted/ByPass.hs b/hbs2-core/lib/HBS2/Net/Messaging/Encrypted/ByPass.hs index 03a9da84..db80f3d9 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/Encrypted/ByPass.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/Encrypted/ByPass.hs @@ -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)) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Notify.hs b/hbs2-core/lib/HBS2/Net/Proto/Notify.hs index a4a90004..2821c01e 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Notify.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Notify.hs @@ -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 diff --git a/hbs2-core/lib/HBS2/Prelude.hs b/hbs2-core/lib/HBS2/Prelude.hs index a30eee1e..6e2ef3c7 100644 --- a/hbs2-core/lib/HBS2/Prelude.hs +++ b/hbs2-core/lib/HBS2/Prelude.hs @@ -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 diff --git a/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs b/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs index 168d2f6b..5a9899f1 100644 --- a/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs +++ b/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs @@ -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 diff --git a/hbs2-core/lib/HBS2/System/Dir.hs b/hbs2-core/lib/HBS2/System/Dir.hs new file mode 100644 index 00000000..093f4642 --- /dev/null +++ b/hbs2-core/lib/HBS2/System/Dir.hs @@ -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 + diff --git a/hbs2-core/lib/HBS2/System/Logger/Simple/ANSI.hs b/hbs2-core/lib/HBS2/System/Logger/Simple/ANSI.hs index 4aa42bed..ae23fa2b 100644 --- a/hbs2-core/lib/HBS2/System/Logger/Simple/ANSI.hs +++ b/hbs2-core/lib/HBS2/System/Logger/Simple/ANSI.hs @@ -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 \ No newline at end of file + toLogStr = toLogStr . renderStrict . layoutPretty defaultLayoutOptions diff --git a/hbs2-keyman/hbs2-keyman.cabal b/hbs2-keyman/hbs2-keyman.cabal index 3bcd3618..817571af 100644 --- a/hbs2-keyman/hbs2-keyman.cabal +++ b/hbs2-keyman/hbs2-keyman.cabal @@ -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 diff --git a/hbs2-peer/app/BlockDownload.hs b/hbs2-peer/app/BlockDownload.hs index 974036e1..8fe90f5d 100644 --- a/hbs2-peer/app/BlockDownload.hs +++ b/hbs2-peer/app/BlockDownload.hs @@ -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 ) diff --git a/hbs2-peer/app/Brains.hs b/hbs2-peer/app/Brains.hs index 98da6611..908fc528 100644 --- a/hbs2-peer/app/Brains.hs +++ b/hbs2-peer/app/Brains.hs @@ -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) + + + + diff --git a/hbs2-peer/app/DownloadMon.hs b/hbs2-peer/app/DownloadMon.hs index 5288958b..a4e28065 100644 --- a/hbs2-peer/app/DownloadMon.hs +++ b/hbs2-peer/app/DownloadMon.hs @@ -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 diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index 9e2c7e4a..b6fcbe39 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/hbs2-peer/app/PeerInfo.hs @@ -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 () diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index b668c216..76f266af 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -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) diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index f87c4491..ad3a1d28 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/hbs2-peer/app/PeerTypes.hs @@ -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 diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 58fa9d31..ee446081 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -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: diff --git a/hbs2-share/src/HBS2/Peer/CLI/Detect.hs b/hbs2-peer/lib/HBS2/Peer/CLI/Detect.hs similarity index 100% rename from hbs2-share/src/HBS2/Peer/CLI/Detect.hs rename to hbs2-peer/lib/HBS2/Peer/CLI/Detect.hs diff --git a/hbs2-qblf/hbs2-qblf.cabal b/hbs2-qblf/hbs2-qblf.cabal index 70b179ac..5b04bb5e 100644 --- a/hbs2-qblf/hbs2-qblf.cabal +++ b/hbs2-qblf/hbs2-qblf.cabal @@ -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 diff --git a/hbs2-share/hbs2-share.cabal b/hbs2-share/hbs2-share.cabal index 46e70bbe..cc105825 100644 --- a/hbs2-share/hbs2-share.cabal +++ b/hbs2-share/hbs2-share.cabal @@ -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: diff --git a/hbs2-storage-simple/hbs2-storage-simple.cabal b/hbs2-storage-simple/hbs2-storage-simple.cabal index c331fb2b..027dfb4f 100644 --- a/hbs2-storage-simple/hbs2-storage-simple.cabal +++ b/hbs2-storage-simple/hbs2-storage-simple.cabal @@ -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 diff --git a/hbs2-tests/hbs2-tests.cabal b/hbs2-tests/hbs2-tests.cabal index ba9793ba..784edb2d 100644 --- a/hbs2-tests/hbs2-tests.cabal +++ b/hbs2-tests/hbs2-tests.cabal @@ -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 diff --git a/hbs2-tests/repo-export/RepoExportMain.hs b/hbs2-tests/repo-export/RepoExportMain.hs index ced13b51..cc9a2e1e 100644 --- a/hbs2-tests/repo-export/RepoExportMain.hs +++ b/hbs2-tests/repo-export/RepoExportMain.hs @@ -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) diff --git a/hbs2/hbs2.cabal b/hbs2/hbs2.cabal index 6d2ef0e5..eb427680 100644 --- a/hbs2/hbs2.cabal +++ b/hbs2/hbs2.cabal @@ -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: diff --git a/nix/peer/flake.lock b/nix/peer/flake.lock index 714dc8cc..ed7f90d2 100644 --- a/nix/peer/flake.lock +++ b/nix/peer/flake.lock @@ -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" } } diff --git a/nix/peer/flake.nix b/nix/peer/flake.nix index b529c2ee..6c22664e 100644 --- a/nix/peer/flake.nix +++ b/nix/peer/flake.nix @@ -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"