diff --git a/Makefile b/Makefile index 8f0a2388..c95bc8fc 100644 --- a/Makefile +++ b/Makefile @@ -12,6 +12,7 @@ BINS := \ hbs2-peer \ hbs2-reposync \ hbs2-keyman \ + hbs2-git-reposync \ git-remote-hbs2 \ git-hbs2 \ diff --git a/code-of-conduct b/code-of-conduct index 8c8b754c..e4e72110 100644 --- a/code-of-conduct +++ b/code-of-conduct @@ -2,21 +2,3 @@ NOTE: do-it-right RU: Нормально делай, нормально будет EN: Do it right and it'll be alright -NOTE: do-dont-complain - RU: Запрещено ныть и жаловаться Что-то не нравится --- предложи, как - сделать лучше. Не знаешь, как лучше --- инициируй обсуждение. Будь - конструктивен. - - EN: No whining or complaining allowed. If something bothers you --- - suggest how to make it better. Don't know how to improve it --- - initiate a discussion. Be constructive. - -NOTE: others-might-be-smart-as-well - - RU: Если что-то сделано каким-то образом --- скорее всего, - для этого были причины. Выясни эти причины сначала. - См. так же пункт see:do-dont-complain - - EN: If something is done in a certain way, there are likely reasons for - it. Find out those reasons first. See also point see:do-dont-complain. - diff --git a/docs/devlog.md b/docs/devlog.md index ee663673..3ef56170 100644 --- a/docs/devlog.md +++ b/docs/devlog.md @@ -1,3 +1,7 @@ +## 2024-02-24 + +wtf? + ## 2024-02-06 Новый формат репозиториев и реворк hbs2-git, статус - wip. diff --git a/examples/refchan-qblf/app/RefChanQBLFMain.hs b/examples/refchan-qblf/app/RefChanQBLFMain.hs index ac6277da..eea5a666 100644 --- a/examples/refchan-qblf/app/RefChanQBLFMain.hs +++ b/examples/refchan-qblf/app/RefChanQBLFMain.hs @@ -13,8 +13,8 @@ import HBS2.OrDie import HBS2.Data.Types.Refs import HBS2.Net.Proto.Types import HBS2.Actors.Peer -import HBS2.Net.Proto.RefChan -import HBS2.Net.Proto.AnyRef +import HBS2.Peer.Proto.RefChan +import HBS2.Peer.Proto.AnyRef import HBS2.Data.Types.SignedBox import HBS2.Net.Messaging.Unix import HBS2.Data.Bundle diff --git a/examples/refchan-qblf/lib/Demo/QBLF/Transactions.hs b/examples/refchan-qblf/lib/Demo/QBLF/Transactions.hs index fd634bd2..59f184af 100644 --- a/examples/refchan-qblf/lib/Demo/QBLF/Transactions.hs +++ b/examples/refchan-qblf/lib/Demo/QBLF/Transactions.hs @@ -4,14 +4,11 @@ module Demo.QBLF.Transactions where import HBS2.Prelude.Plated import HBS2.Hash import HBS2.Base58 -import HBS2.Net.Proto.Types -import HBS2.Actors.Peer.Types -import HBS2.Net.Proto.RefChan +import HBS2.Peer.Proto import HBS2.Data.Types.Refs (HashRef(..)) import HBS2.Data.Types.SignedBox import HBS2.Net.Auth.Credentials import HBS2.Net.Messaging.Unix (UNIX) -import HBS2.Net.Proto.Definition() import Data.Hashable(Hashable(..)) import Codec.Serialise diff --git a/examples/refchan-qblf/refchan-qblf.cabal b/examples/refchan-qblf/refchan-qblf.cabal index b64e6573..127cf7a4 100644 --- a/examples/refchan-qblf/refchan-qblf.cabal +++ b/examples/refchan-qblf/refchan-qblf.cabal @@ -18,7 +18,7 @@ common warnings common common-deps build-depends: - base, hbs2-core, hbs2-storage-simple, hbs2-qblf + base, hbs2-core, hbs2-peer, hbs2-storage-simple, hbs2-qblf , aeson , async , bytestring diff --git a/flake.lock b/flake.lock index b3c9df26..45da053e 100644 --- a/flake.lock +++ b/flake.lock @@ -8,11 +8,11 @@ ] }, "locked": { - "lastModified": 1700834043, - "narHash": "sha256-VDExjkJ2maIP+Baw5V3fhmRtJ4nHpQV/Fxg1H8g69ME=", + "lastModified": 1708680396, + "narHash": "sha256-ZPwDreNdnyCS/hNdaE0OqVhytm+SzZGRfGRTRvBuSzE=", "ref": "refs/heads/master", - "rev": "6050d7949f390c4717293d1d410123439e0fda67", - "revCount": 6, + "rev": "221fde04a00a9c38d2f6c0d05b1e1c3457d5a827", + "revCount": 7, "type": "git", "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft" }, diff --git a/flake.nix b/flake.nix index cf45a0e2..2d7278e4 100644 --- a/flake.nix +++ b/flake.nix @@ -33,6 +33,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs: "hbs2-core" "hbs2-storage-simple" "hbs2-git" + "hbs2-git-reposync" "hbs2-qblf" "hbs2-keyman" "hbs2-share" @@ -58,6 +59,8 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs: "hbs2-peer" = "./hbs2-peer"; "hbs2-keyman" = "./hbs2-keyman"; "hbs2-share" = "./hbs2-share"; + "hbs2-git" = "./hbs2-git"; + "hbs2-git-reposync" = "./hbs2-git-reposync"; }; hpPreOverrides = {pkgs, ...}: final: prev: with pkgs; { @@ -100,6 +103,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs: text-icu pkgs.icu72 pkgs.openssl + weeder ]) ++ [ pkgs.pkg-config @@ -110,7 +114,6 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs: shellHook = '' 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 be11de5a..706e35c6 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -83,7 +83,6 @@ library , HBS2.Data.KeyRing , HBS2.Data.Detect , HBS2.Data.Types - , HBS2.Data.Types.Crypto , HBS2.Data.Types.Peer , HBS2.Data.Types.Refs , HBS2.Data.Types.SignedBox @@ -95,6 +94,7 @@ library , HBS2.Polling , HBS2.Hash , HBS2.Merkle + , HBS2.Net.Auth.Schema , HBS2.Net.Auth.GroupKeyAsymm , HBS2.Net.Auth.GroupKeySymm , HBS2.Net.Auth.Credentials @@ -111,27 +111,9 @@ library , HBS2.Net.PeerLocator , HBS2.Net.PeerLocator.Static , HBS2.Net.Proto - , HBS2.Net.Proto.BlockAnnounce - , HBS2.Net.Proto.BlockChunks - , HBS2.Net.Proto.BlockInfo - , HBS2.Net.Proto.Definition - , HBS2.Net.Proto.Dialog + , HBS2.Net.Proto.Sessions , HBS2.Net.Proto.Service , HBS2.Net.Proto.Notify - , HBS2.Net.Proto.EncryptionHandshake - , HBS2.Net.Proto.Event.PeerExpired - , HBS2.Net.Proto.Peer - , HBS2.Net.Proto.PeerAnnounce - , HBS2.Net.Proto.PeerExchange - , HBS2.Net.Proto.PeerMeta - , HBS2.Net.Proto.Sessions - , HBS2.Net.Proto.RefLog - , HBS2.Net.Proto.RefChan - , HBS2.Net.Proto.RefChan.Types - , HBS2.Net.Proto.RefChan.RefChanHead - , HBS2.Net.Proto.RefChan.RefChanNotify - , HBS2.Net.Proto.RefChan.RefChanUpdate - , HBS2.Net.Proto.AnyRef , HBS2.Net.Proto.Types , HBS2.OrDie , HBS2.Prelude @@ -236,6 +218,7 @@ test-suite test , HasProtocol , DialogSpec , TestScheduled + , TestDerivedKey -- other-extensions: diff --git a/hbs2-core/lib/HBS2/Actors/Peer/Types.hs b/hbs2-core/lib/HBS2/Actors/Peer/Types.hs index 6a0aac5e..c68ab28a 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer/Types.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer/Types.hs @@ -8,9 +8,9 @@ import HBS2.Net.Messaging import HBS2.Hash import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe import Data.ByteString.Lazy (ByteString) - +import Control.Monad +import Codec.Serialise class HasProtocol e p => HasTimeLimits e p m where tryLockForPeriod :: Peer e -> p -> m Bool @@ -48,3 +48,5 @@ type PeerMessaging e = ( Messaging (Fabriq e) e (AnyMessage (Encoded e) e) , Hashable (Encoded e) ) + + diff --git a/hbs2-core/lib/HBS2/Data/Types/Crypto.hs b/hbs2-core/lib/HBS2/Data/Types/Crypto.hs deleted file mode 100644 index f14e406a..00000000 --- a/hbs2-core/lib/HBS2/Data/Types/Crypto.hs +++ /dev/null @@ -1,29 +0,0 @@ -module HBS2.Data.Types.Crypto where - -import Codec.Serialise -import Crypto.Saltine.Core.Box qualified as Encrypt -import Crypto.Saltine.Core.Sign qualified as Sign - -import HBS2.Net.Auth.Credentials -import HBS2.Net.Proto.Types -import HBS2.Prelude - --- type SignPubKey = () --- type EncryptPubKey = () - -type instance PubKey 'Sign HBS2Basic = Sign.PublicKey -type instance PrivKey 'Sign HBS2Basic = Sign.SecretKey -type instance PubKey 'Encrypt HBS2Basic = Encrypt.PublicKey -type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey - -instance Serialise Sign.PublicKey -instance Serialise Encrypt.PublicKey -instance Serialise Sign.SecretKey -instance Serialise Encrypt.SecretKey - -instance Serialise Sign.Signature - -instance Signatures HBS2Basic where - type Signature HBS2Basic = Sign.Signature - makeSign = Sign.signDetached - verifySign = Sign.signVerifyDetached diff --git a/hbs2-core/lib/HBS2/Data/Types/Peer.hs b/hbs2-core/lib/HBS2/Data/Types/Peer.hs index 0c250a00..ebd28b62 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Peer.hs +++ b/hbs2-core/lib/HBS2/Data/Types/Peer.hs @@ -7,7 +7,6 @@ import Data.Hashable import Lens.Micro.Platform import HBS2.Prelude -import HBS2.Data.Types.Crypto import HBS2.Net.Auth.Credentials import HBS2.Net.Proto.Types diff --git a/hbs2-core/lib/HBS2/Defaults.hs b/hbs2-core/lib/HBS2/Defaults.hs index 2d31a5d8..99906951 100644 --- a/hbs2-core/lib/HBS2/Defaults.hs +++ b/hbs2-core/lib/HBS2/Defaults.hs @@ -16,11 +16,11 @@ defBurstMax :: Integral a => a defBurstMax = 128 defBurst :: Integral a => a -defBurst = defBurstMax `div` 2 +defBurst = defBurstMax `div` 8 -- defChunkSize :: Integer defChunkSize :: Integral a => a -defChunkSize = 1420 +defChunkSize = 1400 -- defChunkSize = 480 defBlockSize :: Integer @@ -70,7 +70,7 @@ defBlockWipTimeout :: TimeSpec defBlockWipTimeout = defCookieTimeout defBlockInfoTimeout :: Timeout 'Seconds -defBlockInfoTimeout = 2 +defBlockInfoTimeout = 5 defBlockInfoTimeoutSpec :: TimeSpec defBlockInfoTimeoutSpec = toTimeSpec defBlockInfoTimeout diff --git a/hbs2-core/lib/HBS2/Misc/PrettyStuff.hs b/hbs2-core/lib/HBS2/Misc/PrettyStuff.hs index bf5d7eff..45c6a5da 100644 --- a/hbs2-core/lib/HBS2/Misc/PrettyStuff.hs +++ b/hbs2-core/lib/HBS2/Misc/PrettyStuff.hs @@ -19,6 +19,9 @@ red = annotate (color Red) blue :: Doc AnsiStyle -> Doc AnsiStyle blue = annotate (color Blue) +ul :: Doc AnsiStyle -> Doc AnsiStyle +ul = annotate underlined + section :: Doc ann section = line <> line diff --git a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs index f45f6653..2c9a5615 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs @@ -6,11 +6,14 @@ {-# Language PatternSynonyms #-} module HBS2.Net.Auth.Credentials ( module HBS2.Net.Auth.Credentials + , module HBS2.Net.Auth.Schema ) where import HBS2.Prelude.Plated import HBS2.Net.Proto.Types +import HBS2.Net.Auth.Schema import HBS2.Base58 +import HBS2.Hash import Codec.Serialise import Crypto.Saltine.Core.Sign (Keypair(..)) @@ -26,7 +29,24 @@ import Data.List qualified as List import Lens.Micro.Platform import Data.Kind +type instance PubKey 'Sign HBS2Basic = Sign.PublicKey +type instance PrivKey 'Sign HBS2Basic = Sign.SecretKey +type instance PubKey 'Encrypt HBS2Basic = Encrypt.PublicKey +type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey +instance Signatures HBS2Basic where + type Signature HBS2Basic = Sign.Signature + makeSign = Sign.signDetached + verifySign = Sign.signVerifyDetached + +type instance KeyActionOf Sign.PublicKey = 'Sign +type instance KeyActionOf Encrypt.PublicKey = 'Encrypt + +instance Serialise Sign.Signature +instance Serialise Sign.PublicKey +instance Serialise Sign.SecretKey +instance Serialise Encrypt.PublicKey +instance Serialise Encrypt.SecretKey type family EncryptPubKey e :: Type @@ -213,3 +233,19 @@ instance IsEncoding (PubKey 'Encrypt e) => Pretty (KeyringEntry e) where pretty ke = fill 10 "pub-key:" <+> pretty (AsBase58 (Crypto.encode (view krPk ke))) + +instance Asymm HBS2Basic where + type AsymmKeypair HBS2Basic = Encrypt.Keypair + type AsymmPrivKey HBS2Basic = Encrypt.SecretKey + type AsymmPubKey HBS2Basic = Encrypt.PublicKey + type CommonSecret HBS2Basic = Encrypt.CombinedKey + asymmNewKeypair = liftIO Encrypt.newKeypair + privKeyFromKeypair = Encrypt.secretKey + pubKeyFromKeypair = Encrypt.publicKey + genCommonSecret = Encrypt.beforeNM + +instance Hashed HbSync Sign.PublicKey where + hashObject pk = hashObject (Crypto.encode pk) + + + diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs index 95c5dc84..5c41f460 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs @@ -7,9 +7,7 @@ module HBS2.Net.Auth.GroupKeyAsymm where import HBS2.Base58 import HBS2.Data.Types import HBS2.Data.Types.EncryptedBox -import HBS2.Merkle import HBS2.Net.Auth.Credentials -import HBS2.Net.Proto.Definition import HBS2.Net.Proto.Types import HBS2.Prelude.Plated diff --git a/hbs2-core/lib/HBS2/Net/Auth/Schema.hs b/hbs2-core/lib/HBS2/Net/Auth/Schema.hs new file mode 100644 index 00000000..3f578356 --- /dev/null +++ b/hbs2-core/lib/HBS2/Net/Auth/Schema.hs @@ -0,0 +1,53 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} +module HBS2.Net.Auth.Schema where + +import HBS2.Prelude +import HBS2.OrDie +import HBS2.Net.Proto.Types +import HBS2.Hash +import HBS2.Net.Messaging.Unix + +import Data.Word +import Crypto.Error +import Crypto.PubKey.Ed25519 qualified as Ed +import Crypto.KDF.HKDF qualified as HKDF +import Crypto.Saltine.Class qualified as Saltine +import Crypto.Saltine.Class (IsEncoding(..)) +import Codec.Serialise +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString (ByteString) +import Data.ByteArray ( convert) + +data HBS2Basic + +type instance Encryption L4Proto = HBS2Basic + +type instance Encryption UNIX = HBS2Basic + + +type ForDerivedKey s = (IsEncoding (PrivKey 'Sign s), IsEncoding (PubKey 'Sign s)) + +instance (MonadIO m, ForDerivedKey s, s ~ HBS2Basic) => HasDerivedKey s 'Sign Word64 m where + derivedKey nonce sk = do + + sk0 <- liftIO $ throwCryptoErrorIO (Ed.secretKey k0) + let pk0 = Ed.toPublic sk0 + + let bs0 = convert sk0 :: ByteString + let bs1 = convert pk0 :: ByteString + + sk1 <- Saltine.decode (bs0 <> bs1) + & orThrow CryptoError_SecretKeySizeInvalid + + pk1 <- Saltine.decode bs1 + & orThrow CryptoError_PublicKeySizeInvalid + + pure (pk1, sk1) + + where + ikm = Saltine.encode sk + salt = LBS.toStrict (serialise nonce) + prk = HKDF.extract @(HashType HbSync) salt ikm + k0 = HKDF.expand @_ @_ @ByteString prk salt Ed.secretKeySize + diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Encrypted/ByPass.hs b/hbs2-core/lib/HBS2/Net/Messaging/Encrypted/ByPass.hs index db80f3d9..866d3332 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/Encrypted/ByPass.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/Encrypted/ByPass.hs @@ -16,7 +16,6 @@ import HBS2.Hash import HBS2.Clock hiding (sec) import HBS2.Net.Messaging import HBS2.Data.Types.SignedBox -import HBS2.Net.Proto.Definition() import HBS2.Net.Auth.Credentials() import HBS2.Net.Messaging.Encrypted.RandomPrefix diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs deleted file mode 100644 index 78155603..00000000 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# Language TemplateHaskell #-} -{-# Language UndecidableInstances #-} - -module HBS2.Net.Proto.EncryptionHandshake where - -import HBS2.Actors.Peer -import HBS2.Clock -import HBS2.Data.Types -import HBS2.Net.Auth.Credentials -import HBS2.Net.Proto -import HBS2.Net.Proto.Peer -import HBS2.Net.Proto.Sessions -import HBS2.Prelude.Plated -import HBS2.System.Logger.Simple - -import Crypto.Saltine.Core.Box qualified as Encrypt -import Data.ByteString qualified as BS -import Data.Hashable hiding (Hashed) -import Data.String.Conversions (cs) -import Lens.Micro.Platform - -instance - ( Show (PubKey 'Encrypt (Encryption e)) - , Show (PubKey 'Sign (Encryption e)) - , Show (Nonce ()) - ) - => Pretty (PeerData e) where - pretty = viaShow - -data EncryptionHandshake e = - BeginEncryptionExchange (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) - | AckEncryptionExchange (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) - | ResetEncryptionKeys - deriving stock (Generic) - -sendResetEncryptionKeys :: forall e s m . - ( MonadIO m - , Request e (EncryptionHandshake e) m - , e ~ L4Proto - , s ~ Encryption e - ) - => Peer e - -> m () - -sendResetEncryptionKeys peer = do - request peer (ResetEncryptionKeys @e) - -sendBeginEncryptionExchange :: forall e s m . - ( MonadIO m - , Request e (EncryptionHandshake e) m - , Sessions e (EncryptionHandshake e) m - -- , HasCredentials s m - , Asymm s - , Signatures s - , Serialise (PubKey 'Encrypt s) - , Pretty (Peer e) - , HasProtocol e (EncryptionHandshake e) - , e ~ L4Proto - , s ~ Encryption e - ) - => PeerCredentials s - -> PubKey 'Encrypt (Encryption e) - -> Peer e - -> m () - -sendBeginEncryptionExchange creds ourpubkey peer = do - let sign = makeSign @s (view peerSignSk creds) ((cs . serialise) ourpubkey) - request peer (BeginEncryptionExchange @e sign ourpubkey) - -data EncryptionHandshakeAdapter e m s = EncryptionHandshakeAdapter - { encHandshake_considerPeerAsymmKey :: Peer e -> Maybe Encrypt.PublicKey -> m () - - , encAsymmetricKeyPair :: AsymmKeypair (Encryption e) - - , encGetEncryptionKey :: EncryptionKeyIDKey e -> m (Maybe (CommonSecret (Encryption e))) - } - - -encryptionHandshakeProto :: forall e s m proto . - ( MonadIO m - , Response e (EncryptionHandshake e) m - , Request e (EncryptionHandshake e) m - , Sessions e (KnownPeer e) m - , HasCredentials s m - , Asymm s - , Signatures s - , Sessions e (EncryptionHandshake e) m - , Serialise (PubKey 'Encrypt (Encryption e)) - , s ~ Encryption e - , e ~ L4Proto - , PubKey 'Encrypt s ~ Encrypt.PublicKey - , Show (PubKey 'Sign s) - , Show (Nonce ()) - , proto ~ EncryptionHandshake e - ) - => EncryptionHandshakeAdapter e m s - -> EncryptionHandshake e - -> m () - -encryptionHandshakeProto EncryptionHandshakeAdapter{..} = \case - - ResetEncryptionKeys -> do - peer <- thatPeer @proto - mpeerData <- find (KnownPeerKey peer) id - -- TODO: check theirsign - trace $ "ENCRYPTION EHSP ResetEncryptionKeys from" <+> viaShow (peer, mpeerData) - - -- сначала удалим у себя его прошлый ключ - encHandshake_considerPeerAsymmKey peer Nothing - - creds <- getCredentials @s - ourpubkey <- pure $ pubKeyFromKeypair @s $ encAsymmetricKeyPair - sendBeginEncryptionExchange @e creds ourpubkey peer - - BeginEncryptionExchange theirsign theirpubkey -> do - peer <- thatPeer @proto - mpeerData <- find (KnownPeerKey peer) id - -- TODO: check theirsign - - trace $ "ENCRYPTION EHSP BeginEncryptionExchange from" <+> viaShow (peer, mpeerData) - - -- взять свои ключи - creds <- getCredentials @s - - ourpubkey <- pure $ pubKeyFromKeypair @s $ encAsymmetricKeyPair - - -- подписать нонс - let sign = makeSign @s (view peerSignSk creds) ((cs . serialise) ourpubkey) - - -- сначала удалим у себя его прошлый ключ - encHandshake_considerPeerAsymmKey peer Nothing - - -- отправить обратно свой публичный ключ - -- отправится пока ещё в плоском виде - response (AckEncryptionExchange @e sign ourpubkey) - - -- Только после этого прописываем его ключ у себя - encHandshake_considerPeerAsymmKey peer (Just theirpubkey) - - AckEncryptionExchange theirsign theirpubkey -> do - peer <- thatPeer @proto - mpeerData <- find (KnownPeerKey peer) id - -- TODO: check theirsign - - trace $ "ENCRYPTION EHSP AckEncryptionExchange from" <+> viaShow (peer, mpeerData) - - -- Он уже прописал у себя наш публичный ключ и готов общаться шифрованными сообщениями - -- Прописываем его ключ у себя - encHandshake_considerPeerAsymmKey peer (Just theirpubkey) - - where - proto = Proxy @(EncryptionHandshake e) - ------ - -data PeerAsymmInfo e = PeerAsymmInfo - -data instance EventKey e (PeerAsymmInfo e) = PeerAsymmInfoKey - deriving stock (Generic) - -deriving stock instance (Eq (Peer e)) => Eq (EventKey e (PeerAsymmInfo e)) -instance (Hashable (Peer e)) => Hashable (EventKey e (PeerAsymmInfo e)) - -data instance Event e (PeerAsymmInfo e) = - PeerAsymmPubKey (Peer e) (AsymmPubKey (Encryption e)) - deriving stock (Typeable) - -instance Expires (EventKey e (PeerAsymmInfo e)) where - expiresIn _ = Nothing - -instance - ( Serialise (PubKey 'Sign (Encryption e)) - , Serialise (PubKey 'Encrypt (Encryption e)) - , Serialise (Signature (Encryption e)) - ) - => Serialise (EncryptionHandshake e) - -deriving instance - ( Show (PubKey 'Encrypt (Encryption e)) - , Show (Signature (Encryption e)) - ) - => Show (EncryptionHandshake e) - -type instance SessionData e (EncryptionHandshake e) = () - -newtype instance SessionKey e (EncryptionHandshake e) = - KnownPeerAsymmInfoKey (Peer e) - deriving stock (Generic, Typeable) - -deriving instance Eq (Peer e) => Eq (SessionKey e (EncryptionHandshake e)) -instance Hashable (Peer e) => Hashable (SessionKey e (EncryptionHandshake e)) - -data instance EventKey e (EncryptionHandshake e) = - AnyKnownPeerEncryptionHandshakeEventKey - deriving stock (Typeable, Eq,Generic) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs b/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs deleted file mode 100644 index 347e9877..00000000 --- a/hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs +++ /dev/null @@ -1,35 +0,0 @@ -module HBS2.Net.Proto.Event.PeerExpired where - -import HBS2.Clock -import HBS2.Data.Types.Peer -import HBS2.Events -import HBS2.Net.Proto -import HBS2.Net.Proto.Peer -import HBS2.Prelude.Plated - -data PeerExpires = PeerExpires - -data instance EventKey e PeerExpires = - PeerExpiredEventKey - deriving stock (Typeable, Eq, Generic) - -data instance Event e PeerExpires = - PeerExpiredEvent (Peer e) -- (Maybe (PeerData e)) - deriving stock (Typeable) - -instance EventType (Event e PeerExpires) where - isPersistent = True - -instance Expires (EventKey e PeerExpires) where - expiresIn _ = Nothing - -instance Hashable (EventKey e PeerExpires) - ---instance ( Serialise (PubKey 'Sign (Encryption e)) --- , Serialise (PubKey 'Encrypt (Encryption e)) --- , Serialise (Signature (Encryption e)) --- , Serialise PeerNonce --- ) - --- => Serialise PeerExpires - diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs b/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs deleted file mode 100644 index 92938a94..00000000 --- a/hbs2-core/lib/HBS2/Net/Proto/RefChan.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# Language UndecidableInstances #-} -{-# Language AllowAmbiguousTypes #-} -module HBS2.Net.Proto.RefChan - ( module HBS2.Net.Proto.RefChan.Types - , module HBS2.Net.Proto.RefChan.RefChanHead - , module HBS2.Net.Proto.RefChan.RefChanUpdate - , module HBS2.Net.Proto.RefChan.RefChanNotify - ) where - -import HBS2.Net.Proto.RefChan.Types -import HBS2.Net.Proto.RefChan.RefChanHead -import HBS2.Net.Proto.RefChan.RefChanUpdate -import HBS2.Net.Proto.RefChan.RefChanNotify - diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs index 0a449c7e..15d70133 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Types.hs @@ -24,7 +24,7 @@ import System.Random qualified as Random import Codec.Serialise import Data.Maybe import Control.Monad.Trans.Maybe -import Data.ByteString (ByteString) +import Data.ByteString.Lazy (ByteString) -- e -> Transport (like, UDP or TChan) -- p -> L4 Protocol (like Ping/Pong) @@ -46,6 +46,10 @@ type family KeyActionOf k :: CryptoAction data family GroupKey (scheme :: GroupKeyScheme) s +-- NOTE: throws-error +class MonadIO m => HasDerivedKey s (a :: CryptoAction) nonce m where + derivedKey :: nonce -> PrivKey a s -> m (PubKey a s, PrivKey a s) + -- TODO: move-to-an-appropriate-place newtype AsGroupKeyFile a = AsGroupKeyFile a @@ -54,7 +58,6 @@ data family ToEncrypt (scheme :: GroupKeyScheme) s a -- = ToEncrypt a data family ToDecrypt (scheme :: GroupKeyScheme) s a -- FIXME: move-to-a-crypto-definition-modules -data HBS2Basic data L4Proto = UDP | TCP deriving stock (Eq,Ord,Generic) @@ -230,3 +233,7 @@ instance FromStringMaybe (PeerAddr L4Proto) where instance Serialise L4Proto instance Serialise (PeerAddr L4Proto) + +deserialiseCustom :: (Serialise a, MonadPlus m) => ByteString -> m a +deserialiseCustom = either (const mzero) pure . deserialiseOrFail + diff --git a/hbs2-core/lib/HBS2/OrDie.hs b/hbs2-core/lib/HBS2/OrDie.hs index 38b595ec..183c0c28 100644 --- a/hbs2-core/lib/HBS2/OrDie.hs +++ b/hbs2-core/lib/HBS2/OrDie.hs @@ -54,6 +54,19 @@ instance OrThrow (Either b a) where Left{} -> throwIO e Right x -> pure x +class OrThrowError a where + type family OrThrowErrorResult a :: Type + orThrowError :: forall e m . (MonadError e m ) => e -> a -> m (OrThrowErrorResult a) + +{- HLINT ignore "Eta reduce" -} +instance OrThrowError (Maybe a) where + type instance (OrThrowErrorResult (Maybe a)) = a + orThrowError e a = maybe (throwError e) pure a + +instance OrThrowError (Either b a) where + type instance (OrThrowErrorResult (Either b a)) = a + orThrowError e a = either (const $ throwError e) pure a + orThrowUser :: (OrThrow a1, MonadIO m) => Doc ann -> a1 diff --git a/hbs2-core/lib/HBS2/Prelude.hs b/hbs2-core/lib/HBS2/Prelude.hs index 6d98e329..cff9d7c8 100644 --- a/hbs2-core/lib/HBS2/Prelude.hs +++ b/hbs2-core/lib/HBS2/Prelude.hs @@ -3,7 +3,9 @@ module HBS2.Prelude ( module Data.String , module Safe , module X - , MonadIO(..) + , module Numeric.Natural + , module HBS2.Clock + , MonadIO(..), MonadPlus(..) , void, guard, when, unless , maybe1 , eitherToMaybe @@ -23,15 +25,14 @@ module HBS2.Prelude , HasErrorStatus(..), ErrorStatus(..), SomeError(..), WithSomeError(..), mayE, someE ) where +import HBS2.Clock + import Data.Typeable as X import GHC.Generics as X (Generic) import Data.ByteString (ByteString) import Data.String (IsString(..)) import Safe -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad (guard,when,unless,MonadPlus(..)) -import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe @@ -46,12 +47,10 @@ import Data.Hashable import Prettyprinter import Data.Word import GHC.Generics -import Data.Time.Clock (NominalDiffTime(..)) -import Codec.Serialise import Control.Monad.Except +import Numeric.Natural import UnliftIO -import Control.Monad.IO.Unlift none :: forall m . Monad m => m () none = pure () @@ -62,9 +61,6 @@ maybe1 mb n j = maybe n j mb eitherToMaybe :: Either a b -> Maybe b eitherToMaybe = either (const Nothing) Just --- deriving instance Generic NominalDiffTime --- instance Serialise NominalDiffTime - newtype AsFileName a = AsFileName a instance Pretty a => Pretty (AsFileName a) where diff --git a/hbs2-core/lib/HBS2/Storage/Operations/Class.hs b/hbs2-core/lib/HBS2/Storage/Operations/Class.hs index a42554a0..2ae0a6e6 100644 --- a/hbs2-core/lib/HBS2/Storage/Operations/Class.hs +++ b/hbs2-core/lib/HBS2/Storage/Operations/Class.hs @@ -5,18 +5,21 @@ import HBS2.Prelude.Plated import HBS2.Hash import HBS2.Storage +import Control.Exception import Data.Kind data OperationError = StorageError | CryptoError + | DecryptError | DecryptionError | MissedBlockError | UnsupportedFormat + | IncompleteData | GroupKeyNotFound Int deriving (Generic,Show,Data,Typeable) --- instance Exception OperationError +instance Exception OperationError class (MonadIO m, Storage storage hash (ToBlockW s) m) => MerkleWriter s hash storage m where type family ToBlockW s :: Type diff --git a/hbs2-core/test/Main.hs b/hbs2-core/test/Main.hs index 24365844..372a83e1 100644 --- a/hbs2-core/test/Main.hs +++ b/hbs2-core/test/Main.hs @@ -5,6 +5,7 @@ import TestActors import DialogSpec import TestFileLogger import TestScheduled +import TestDerivedKey import Test.Tasty import Test.Tasty.HUnit @@ -18,6 +19,7 @@ main = , testCase "testActorsBasic" testActorsBasic , testCase "testFileLogger" testFileLogger , testCase "testScheduledActions" testScheduled + , testCase "testDerivedKeys1" testDerivedKeys1 -- FIXME does-not-finish -- , testDialog diff --git a/hbs2-core/test/TestDerivedKey.hs b/hbs2-core/test/TestDerivedKey.hs new file mode 100644 index 00000000..0360b014 --- /dev/null +++ b/hbs2-core/test/TestDerivedKey.hs @@ -0,0 +1,35 @@ +module TestDerivedKey where + +import HBS2.Prelude +import HBS2.OrDie +import HBS2.Net.Proto.Types +import HBS2.Net.Auth.Schema +import HBS2.Net.Auth.Credentials +import HBS2.Data.Types.SignedBox + +import Test.Tasty.HUnit + +import Lens.Micro.Platform +import Data.Word + +testDerivedKeys1 :: IO () +testDerivedKeys1 = do + + cred <- newCredentials @HBS2Basic + + let _ = view peerSignPk cred + let sk = view peerSignSk cred + + let nonce = 0x123456780928934 :: Word64 + (pk1,sk1) <- derivedKey @HBS2Basic @'Sign nonce sk + + let box = makeSignedBox @L4Proto pk1 sk1 (42 :: Word32) + + (pk, n) <- pure (unboxSignedBox0 box) + `orDie` "can not unbox" + + assertEqual "signed-box-unpacked" n 42 + + print $ "ZBS!" <+> pretty n + + pure () diff --git a/hbs2-git-reposync/LICENSE b/hbs2-git-reposync/LICENSE new file mode 100644 index 00000000..3086ee5d --- /dev/null +++ b/hbs2-git-reposync/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Dmitry Zuikov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Dmitry Zuikov nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/hbs2-git/reposync/ReposyncMain.hs b/hbs2-git-reposync/ReposyncMain.hs similarity index 79% rename from hbs2-git/reposync/ReposyncMain.hs rename to hbs2-git-reposync/ReposyncMain.hs index 2f9ebc9a..d2fce704 100644 --- a/hbs2-git/reposync/ReposyncMain.hs +++ b/hbs2-git-reposync/ReposyncMain.hs @@ -2,40 +2,33 @@ module Main where import HBS2.Prelude.Plated +import HBS2.Net.Auth.Credentials import HBS2.OrDie -import HBS2.Base58 +import HBS2.Data.Types.Refs import HBS2.Actors.Peer -import HBS2.Actors.Peer.Types import HBS2.Net.Proto.Notify -import HBS2.Data.Types.Refs (HashRef(..)) -import HBS2.Net.Proto.Types -import HBS2.Net.Proto.RefLog +import HBS2.Peer.Proto import HBS2.Peer.RPC.Client.Unix hiding (Cookie) import HBS2.Peer.RPC.API.RefLog import HBS2.Peer.Notify -import HBS2.Clock --- import HBS2Git.PrettyStuff import HBS2.System.Logger.Simple hiding (info) -import HBS2.System.Logger.Simple qualified as Log import Data.Config.Suckless -import Data.Config.Suckless.Syntax -import Data.Config.Suckless.KeyValue - +import Data.Char qualified as Char import Control.Monad.Catch (MonadThrow(..)) import Control.Monad.Except (runExceptT,throwError) import Control.Monad.Cont import Control.Monad.Reader +import Data.ByteString.Builder hiding (writeFile) +import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy.Char8 qualified as LBS import Data.Either import Data.List qualified as List import Data.Maybe import Data.Text qualified as Text import Lens.Micro.Platform -import Network.Wai (Middleware, pathInfo, rawPathInfo, lazyRequestBody) -import Network.Wai.Middleware.Static (staticPolicy, addBase) import Network.Wai.Middleware.RequestLogger (logStdoutDev) import Options.Applicative import qualified Data.Text.Encoding as TE @@ -47,10 +40,14 @@ import Control.Concurrent.STM (flushTQueue) import UnliftIO import Web.Scotty hiding (header,next) --- import Control.Monad +import Network.HTTP.Types +import Network.Wai + import System.Exit qualified as Exit import System.IO.Unsafe (unsafePerformIO) +import Streaming.Prelude qualified as S + -- TODO: support-encrypted-repoes die :: (MonadIO m, Show msg) => msg -> m a @@ -117,7 +114,7 @@ newtype ReposyncM m a = myName :: FilePath -myName = "hbs2-reposync" +myName = "hbs2-git-reposync" reposyncDefaultDir :: FilePath reposyncDefaultDir = unsafePerformIO do @@ -133,6 +130,7 @@ newState :: MonadUnliftIO m newState so refLog sink = ReposyncState so refLog sink reposyncDefaultDir 4017 <$> newTVarIO mempty +{- HLINT ignore "Functor law" -} withConfig :: forall a m . (MonadUnliftIO m) => Maybe FilePath -> ReposyncM m a -> ReposyncM m () withConfig cfg m = do @@ -188,7 +186,64 @@ withConfig cfg m = do pure $ RepoEntry (root path) repo keys mt --- WTF1? + +data S = S0 (Builder, LBS.ByteString) + | S1 (LBS.ByteString, Builder, LBS.ByteString) + | S2 LBS.ByteString + +data R = Hdr Header + | HdrS (Maybe Status) + | Content LBS.ByteString + deriving (Data,Generic) + +parseResp :: MonadIO m => LBS.ByteString -> m (Maybe Status, [(HeaderName, BS8.ByteString)], LBS.ByteString) +parseResp lbs = do + + let yieldHeader (h, v) = do + if fmap Char.toLower (LBS.unpack h) == "status" then do + case LBS.words v of + (code : rest) -> do + let cnum = readMay @Int (LBS.unpack code) + st <- forM cnum $ \n -> pure $ mkStatus n (LBS.toStrict (LBS.unwords rest)) + S.yield $ HdrS st + + _ -> S.yield (HdrS Nothing) + else do + S.yield $ Hdr (fromString $ LBS.unpack h, LBS.toStrict v) + + chunks <- S.toList_ do + void $ flip fix (S0 (mempty,lbs)) $ \next -> \case + S0 (h,s) -> case LBS.uncons s of + Nothing -> pure () + + Just (':', rest) -> next (S1 (toLazyByteString h, mempty, LBS.dropWhile (`elem` "\t ") rest)) + Just (c, rest) -> next (S0 (h <> char8 c, rest)) + + S1 (h, v, s) -> case LBS.uncons s of + Nothing -> do + yieldHeader (h,toLazyByteString v) + pure () + + Just ('\r',rest) -> do + yieldHeader (h,toLazyByteString v) + next (S2 rest) + + Just (c,rest) -> next (S1 (h, v <> char8 c, rest)) + + S2 rest -> do + let (fin, content) = LBS.splitAt 3 rest + if fin == "\n\r\n" then do + S.yield (Content content) + else do + next (S0 (mempty, LBS.drop 1 rest)) + + + let hdr = [ s | Hdr s <- chunks ] + let st = headDef Nothing [ s | HdrS s <- chunks ] + let content = mconcat [ s | Content s <- chunks ] + + pure (st, hdr, content) + runSync :: (MonadUnliftIO m, MonadThrow m) => ReposyncM m () runSync = do es <- asks (view reposyncEntries) >>= readTVarIO @@ -197,14 +252,31 @@ runSync = do refLogRPC <- asks (view rpcRefLog) sink <- asks (view rpcNotifySink) - root <- asks (view reposyncBaseDir) - port <- asks (view reposyncPort) <&> fromIntegral + port <- asks (fromIntegral . view reposyncPort) http <- async $ liftIO $ scotty port $ do - middleware $ staticPolicy (addBase root) + -- middleware $ staticPolicy (addBase root) + middleware $ (\a req r2 -> do + + let env = [ ("REQUEST_METHOD", BS8.unpack $ requestMethod req), + ("PATH_INFO", BS8.unpack $ rawPathInfo req), + ("QUERY_STRING", BS8.unpack $ rawQueryString req), + ("CONTENT_TYPE", maybe "" BS8.unpack $ lookup "Content-Type" $ requestHeaders req), + ("CONTENT_LENGTH", maybe "" BS8.unpack $ lookup "Content-Length" $ requestHeaders req), + ("GIT_PROJECT_ROOT", "/home/dmz/.local/share/hbs2-reposync/repo"), + ("GIT_HTTP_EXPORT_ALL", "") + ] + + let p = shell "/usr/bin/env git-http-backend" & setEnv env & setStderr closed + (code, out) <- readProcessStdout p + + (s, h, body) <- parseResp out + + let st = fromMaybe status200 s + + r2 $ responseLBS st h body + ) middleware logStdoutDev - get "/" $ do - text "This is hbs2-reposync" r <- forM es $ \entry -> async $ void $ flip runContT pure do let ref = repoRef entry diff --git a/hbs2-git/reposync/examples/config b/hbs2-git-reposync/examples/config similarity index 100% rename from hbs2-git/reposync/examples/config rename to hbs2-git-reposync/examples/config diff --git a/hbs2-git-reposync/hbs2-git-reposync.cabal b/hbs2-git-reposync/hbs2-git-reposync.cabal new file mode 100644 index 00000000..a647119b --- /dev/null +++ b/hbs2-git-reposync/hbs2-git-reposync.cabal @@ -0,0 +1,135 @@ +cabal-version: 3.0 +name: hbs2-git-reposync +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD-3-Clause +license-file: LICENSE +author: Dmitry Zuikov +maintainer: dzuikov@gmail.com +-- copyright: +category: Development +build-type: Simple +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common shared-properties + ghc-options: + -Wall + -Wno-type-defaults + -fprint-potential-instances + -- -fno-warn-unused-matches + -- -fno-warn-unused-do-bind + -- -Werror=missing-methods + -- -Werror=incomplete-patterns + -- -fno-warn-unused-binds + + + default-language: Haskell2010 + + default-extensions: + ApplicativeDo + , BangPatterns + , BlockArguments + , ConstraintKinds + , DataKinds + , DeriveDataTypeable + , DeriveGeneric + , DerivingStrategies + , DerivingVia + , ExtendedDefaultRules + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , ImportQualifiedPost + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , QuasiQuotes + , RecordWildCards + , ScopedTypeVariables + , StandaloneDeriving + , TupleSections + , TypeApplications + , TypeOperators + , TypeFamilies + , TemplateHaskell + + + build-depends: hbs2-core, hbs2-peer + , attoparsec + , aeson + , async + , base16-bytestring + , bytestring + , cache + , containers + , streaming + , streaming-bytestring + , streaming-commons + , streaming-utils + , cryptonite + , directory + , exceptions + , filelock + , filepath + , filepattern + , generic-lens + , hashable + , http-conduit + , interpolatedstring-perl6 + , memory + , microlens-platform + , mtl + , prettyprinter + , prettyprinter-ansi-terminal + , random + , resourcet + , safe + , saltine + , serialise + , split + , sqlite-simple + , stm + , suckless-conf + , temporary + , text + , time + , timeit + , transformers + , typed-process + , uniplate + , unliftio + , unliftio-core + , unordered-containers + , wai-app-file-cgi + , wai-extra + +executable hbs2-git-reposync + import: shared-properties + main-is: ReposyncMain.hs + + ghc-options: + -threaded + -rtsopts + "-with-rtsopts=-N4 -A64m -AL256m -I0" + + other-modules: + + -- other-extensions: + build-depends: + base, hbs2-core, hbs2-peer + , optparse-applicative + , unliftio + , terminal-progress-bar + , http-types + , scotty + , wai + , wai-middleware-static + , wai-extra + + hs-source-dirs: . + default-language: Haskell2010 + + diff --git a/hbs2-git/git-hbs2/GitRemoteTypes.hs b/hbs2-git/git-hbs2/GitRemoteTypes.hs index a6fa6143..b33b70ef 100644 --- a/hbs2-git/git-hbs2/GitRemoteTypes.hs +++ b/hbs2-git/git-hbs2/GitRemoteTypes.hs @@ -6,7 +6,6 @@ import HBS2.Prelude import HBS2.OrDie import HBS2.Net.Proto import HBS2.Net.Auth.Credentials -import HBS2.Net.Proto.Definition() import HBS2.Peer.RPC.Client.StorageClient import HBS2Git.Types diff --git a/hbs2-git/git-hbs2/Main.hs b/hbs2-git/git-hbs2/Main.hs index 2f6e580c..f5b1fc42 100644 --- a/hbs2-git/git-hbs2/Main.hs +++ b/hbs2-git/git-hbs2/Main.hs @@ -7,7 +7,6 @@ import HBS2Git.App import HBS2Git.Export import HBS2Git.Tools import HBS2Git.KeysCommand -import HBS2.Net.Proto.Definition() import HBS2.Version import RunShow diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index a9b23490..9ef97a3d 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -58,6 +58,7 @@ common shared-properties build-depends: hbs2-core, hbs2-peer + , attoparsec , aeson , async , base16-bytestring @@ -102,12 +103,15 @@ common shared-properties , unliftio , unliftio-core , unordered-containers + , wai-app-file-cgi + , wai-extra library import: shared-properties exposed-modules: HBS2.Git.Types + HBS2Git.Prelude HBS2Git.Alerts HBS2Git.Annotations HBS2Git.App @@ -191,31 +195,4 @@ executable git-remote-hbs2 default-language: Haskell2010 -executable hbs2-reposync - import: shared-properties - main-is: ReposyncMain.hs - - ghc-options: - -threaded - -rtsopts - "-with-rtsopts=-N4 -A64m -AL256m -I0" - - other-modules: - - -- other-extensions: - build-depends: - base, hbs2-git, hbs2-core, hbs2-peer - , optparse-applicative - , unliftio - , terminal-progress-bar - , http-types - , scotty - , wai - , wai-middleware-static - , wai-extra - - hs-source-dirs: reposync - default-language: Haskell2010 - - diff --git a/hbs2-git/lib/HBS2Git/Annotations.hs b/hbs2-git/lib/HBS2Git/Annotations.hs index 1de591aa..ab87cf14 100644 --- a/hbs2-git/lib/HBS2Git/Annotations.hs +++ b/hbs2-git/lib/HBS2Git/Annotations.hs @@ -1,12 +1,8 @@ module HBS2Git.Annotations where -import HBS2.Prelude.Plated -import HBS2.Data.Types.Refs - +import HBS2Git.Prelude import HBS2Git.Encryption -import Codec.Serialise - data Annotation = GK1 HashRef (GroupKey 'Symm HBS2Basic) deriving (Generic) diff --git a/hbs2-git/lib/HBS2Git/App.hs b/hbs2-git/lib/HBS2Git/App.hs index 41373e4e..d9009f89 100644 --- a/hbs2-git/lib/HBS2Git/App.hs +++ b/hbs2-git/lib/HBS2Git/App.hs @@ -10,7 +10,6 @@ module HBS2Git.App where import HBS2.Prelude.Plated -import HBS2.Actors.Peer.Types import HBS2.Data.Types.Refs import HBS2.Base58 import HBS2.OrDie @@ -22,10 +21,9 @@ import HBS2.Net.Auth.GroupKeySymm qualified as Symm import HBS2.System.Logger.Simple import HBS2.Merkle import HBS2.Git.Types -import HBS2.Net.Proto.Definition() import HBS2.Peer.RPC.Client.StorageClient import HBS2.Net.Auth.Credentials hiding (getCredentials) -import HBS2.Net.Proto.RefLog +import HBS2.Peer.Proto import HBS2.Defaults (defBlockSize) import HBS2.Peer.RPC.Client.Unix diff --git a/hbs2-git/lib/HBS2Git/Encryption.hs b/hbs2-git/lib/HBS2Git/Encryption.hs index 224fbf06..a4ef507d 100644 --- a/hbs2-git/lib/HBS2Git/Encryption.hs +++ b/hbs2-git/lib/HBS2Git/Encryption.hs @@ -4,12 +4,11 @@ module HBS2Git.Encryption , module HBS2.Net.Auth.GroupKeySymm ) where -import HBS2.Prelude.Plated +import HBS2Git.Prelude -import HBS2.Base58 +import HBS2.Net.Auth.Credentials import HBS2.Net.Proto.Types hiding (Cookie) import HBS2.Net.Auth.GroupKeySymm hiding (Cookie) -import HBS2.Net.Proto.Definition() import HBS2Git.Encryption.KeyInfo @@ -17,7 +16,6 @@ import HBS2Git.Encryption.KeyInfo import Data.Config.Suckless.Syntax import Data.Config.Suckless.KeyValue -import Data.Function import Data.HashSet qualified as HashSet import Data.Maybe import Data.Text qualified as Text diff --git a/hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs b/hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs index dc241f90..abbf8112 100644 --- a/hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs +++ b/hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs @@ -1,11 +1,11 @@ +{-# Language UndecidableInstances #-} module HBS2Git.Encryption.KeyInfo where import HBS2.Prelude.Plated import HBS2.Hash +import HBS2.Net.Auth.Credentials import HBS2.Net.Proto.Types hiding (Cookie) --- import HBS2.Net.Auth.GroupKeySymm hiding (Cookie) -import HBS2.Net.Proto.Definition() import Data.Config.Suckless.Syntax import Data.Config.Suckless.KeyValue @@ -27,13 +27,14 @@ data KeyInfo = } deriving (Eq,Ord,Show,Generic) -instance Serialise KeyInfo +type ForKeys s = (Serialise (PubKey 'Sign s), Serialise (PubKey 'Encrypt s)) -instance Hashed HbSync KeyInfo where +instance ForKeys HBS2Basic => Serialise KeyInfo + +instance ForKeys HBS2Basic => Hashed HbSync KeyInfo where hashObject ki = hashObject (serialise ki) - keyInfoFrom :: POSIXTime -> Syntax C -> Maybe KeyInfo keyInfoFrom t (ListVal (SymbolVal "encrypted" : (LitStrVal r) : args)) = KeyInfo <$> nonce diff --git a/hbs2-git/lib/HBS2Git/Export.hs b/hbs2-git/lib/HBS2Git/Export.hs index 58ee240f..3e402c90 100644 --- a/hbs2-git/lib/HBS2Git/Export.hs +++ b/hbs2-git/lib/HBS2Git/Export.hs @@ -13,9 +13,8 @@ import HBS2.Prelude.Plated import HBS2.Data.Types.Refs import HBS2.OrDie import HBS2.System.Logger.Simple -import HBS2.Net.Proto.Definition() import HBS2.Base58 -import HBS2.Net.Proto.RefLog +import HBS2.Peer.Proto import HBS2.Git.Local import HBS2.Git.Local.CLI @@ -32,7 +31,6 @@ import Control.Monad.Catch import Control.Monad.Reader import Control.Concurrent.STM import Data.ByteString.Lazy.Char8 qualified as LBS -import Data.Foldable (for_) import Data.HashMap.Strict qualified as HashMap import Data.HashSet qualified as HashSet import Data.HashSet (HashSet) diff --git a/hbs2-git/lib/HBS2Git/Import.hs b/hbs2-git/lib/HBS2Git/Import.hs index 5623c0f9..1be13ab1 100644 --- a/hbs2-git/lib/HBS2Git/Import.hs +++ b/hbs2-git/lib/HBS2Git/Import.hs @@ -12,7 +12,7 @@ import HBS2.Storage.Operations.Class import HBS2.Storage.Operations.Missed import HBS2.Storage.Operations.ByteString(TreeKey(..)) import HBS2.Net.Auth.GroupKeySymm -import HBS2.Net.Proto.RefLog +import HBS2.Peer.Proto import Text.InterpolatedString.Perl6 (qc) import HBS2.Data.Detect hiding (Blob) diff --git a/hbs2-git/lib/HBS2Git/KeysCommand.hs b/hbs2-git/lib/HBS2Git/KeysCommand.hs index 546bec12..6bb21088 100644 --- a/hbs2-git/lib/HBS2Git/KeysCommand.hs +++ b/hbs2-git/lib/HBS2Git/KeysCommand.hs @@ -4,17 +4,16 @@ module HBS2Git.KeysCommand , CryptoAction(..) ) where -import HBS2.Prelude.Plated -import HBS2.Base58 + +import HBS2Git.Prelude +import HBS2Git.App +import HBS2Git.Encryption + import HBS2.OrDie import HBS2.Net.Proto.Types -import HBS2Git.App -import HBS2Git.Encryption import HBS2.System.Logger.Simple - -import Data.Function import Data.Time.Clock.POSIX import Data.Maybe diff --git a/hbs2-git/lib/HBS2Git/KeysMetaData.hs b/hbs2-git/lib/HBS2Git/KeysMetaData.hs index 41a40c79..eb6c60a2 100644 --- a/hbs2-git/lib/HBS2Git/KeysMetaData.hs +++ b/hbs2-git/lib/HBS2Git/KeysMetaData.hs @@ -1,19 +1,7 @@ module HBS2Git.KeysMetaData where -import HBS2.Prelude.Plated -import HBS2.Hash -import HBS2.Base58 -import HBS2.Data.Detect -import HBS2.Data.Types.Refs -import HBS2.Merkle -import HBS2.Net.Auth.GroupKeySymm -import HBS2.Net.Proto.RefLog -import HBS2.OrDie -import HBS2.Storage -import HBS2.Storage.Operations.ByteString -import HBS2.System.Logger.Simple -import HBS2.Net.Proto.Definition() +import HBS2Git.Prelude import HBS2Git.Types import HBS2Git.Alerts import HBS2Git.Annotations @@ -22,7 +10,15 @@ import HBS2Git.State import HBS2Git.PrettyStuff import HBS2Git.Config -import Codec.Serialise + +import HBS2.Data.Detect +import HBS2.Merkle +import HBS2.Peer.Proto +import HBS2.OrDie +import HBS2.Storage +import HBS2.Storage.Operations.ByteString +import HBS2.System.Logger.Simple + import Control.Monad import Control.Monad.Catch (MonadMask) import Control.Monad.Except (runExceptT) @@ -33,7 +29,6 @@ import Data.Either import Data.HashMap.Strict qualified as HashMap import Data.HashSet qualified as HashSet import Data.List qualified as List -import Data.Function (on) import Data.Maybe import Lens.Micro.Platform import Streaming.Prelude qualified as S diff --git a/hbs2-git/lib/HBS2Git/Prelude.hs b/hbs2-git/lib/HBS2Git/Prelude.hs new file mode 100644 index 00000000..1c421ba5 --- /dev/null +++ b/hbs2-git/lib/HBS2Git/Prelude.hs @@ -0,0 +1,15 @@ +module HBS2Git.Prelude + ( module HBS2.Prelude.Plated + , module HBS2.Base58 + , module HBS2.Data.Types.Refs + , module Credentials + , module Codec.Serialise + ) where + +import HBS2.Prelude.Plated +import HBS2.Base58 +import HBS2.Data.Types.Refs +import HBS2.Net.Auth.Credentials as Credentials + +import Codec.Serialise + diff --git a/hbs2-git/lib/HBS2Git/State.hs b/hbs2-git/lib/HBS2Git/State.hs index 68b524e2..0ef1b55d 100644 --- a/hbs2-git/lib/HBS2Git/State.hs +++ b/hbs2-git/lib/HBS2Git/State.hs @@ -2,19 +2,17 @@ {-# Language UndecidableInstances #-} module HBS2Git.State where -import HBS2.Prelude -import HBS2.Base58 -import HBS2.Net.Auth.GroupKeySymm hiding (Cookie) - +import HBS2Git.Prelude hiding (getCredentials) import HBS2Git.Types -import HBS2.Data.Types.Refs +import HBS2Git.Config (cookieFile) +import HBS2Git.Encryption import HBS2.Git.Types + +import HBS2.Data.Types.Refs import HBS2.Hash import HBS2.System.Logger.Simple -import HBS2Git.Config (cookieFile) -import HBS2Git.Encryption import Control.Monad.Trans.Resource import Data.Functor diff --git a/hbs2-git/lib/HBS2Git/Types.hs b/hbs2-git/lib/HBS2Git/Types.hs index 4e155f65..b3f55d97 100644 --- a/hbs2-git/lib/HBS2Git/Types.hs +++ b/hbs2-git/lib/HBS2Git/Types.hs @@ -14,12 +14,11 @@ module HBS2Git.Types import HBS2.Prelude.Plated import HBS2.Hash -import HBS2.Clock import HBS2.Git.Types import HBS2.Storage import HBS2.Peer.RPC.Client.Unix hiding (Cookie) -import HBS2.Net.Proto.RefLog (RefLogKey(..)) import HBS2.Net.Auth.Credentials +import HBS2.Peer.Proto hiding (Cookie) import HBS2.Peer.RPC.API.Peer import HBS2.Peer.RPC.API.RefLog diff --git a/hbs2-keyman/app/Main.hs b/hbs2-keyman/app/Main.hs index 5f8c2646..bff2be16 100644 --- a/hbs2-keyman/app/Main.hs +++ b/hbs2-keyman/app/Main.hs @@ -1,25 +1,26 @@ module Main where -import HBS2.Prelude -import HBS2.Net.Auth.Credentials - +import HBS2.KeyMan.Prelude import HBS2.KeyMan.App.Types import HBS2.KeyMan.Config import HBS2.KeyMan.State + +import HBS2.Net.Auth.Credentials + import HBS2.Data.KeyRing qualified as KeyRing +import HBS2.System.Dir import HBS2.System.Logger.Simple import Data.Config.Suckless.KeyValue - import Options.Applicative qualified as O +import Data.Text qualified as Text import Options.Applicative hiding (info) import Data.Set qualified as Set import Data.ByteString qualified as BS import Control.Monad.Trans.Maybe import Control.Monad.Reader -import UnliftIO data GlobalOptions = GlobalOptions @@ -32,21 +33,38 @@ type Command m = m () globalOptions :: Parser GlobalOptions globalOptions = pure GlobalOptions -type AppPerks m = (MonadIO m, MonadReader AppEnv m, HasConf m) +type AppPerks m = (MonadIO m, MonadUnliftIO m, MonadReader AppEnv m, HasConf m, SerialisedCredentials HBS2Basic) -- Парсер для команд commands :: (AppPerks m) => Parser (Command m) commands = hsubparser - ( command "update" (O.info (updateKeys <**> helper) (progDesc "update keys" )) - <> command "list" (O.info (listKeysCmd <**> helper) (progDesc "list keys" )) + ( command "update" (O.info (updateKeys <**> helper) (progDesc "update keys" )) + <> command "list" (O.info (listKeysCmd <**> helper) (progDesc "list keys" )) + <> command "set-weight" (O.info (setWeightCmd <**> helper) (progDesc "set weight for a key")) + <> command "add-mask" (O.info (addPath <**> helper) (progDesc "add path/mask to search keys, ex. '/home/user/keys/*.key'")) + <> command "config" (O.info (showConfig <**> helper) (progDesc "show hbs2-keyman config")) ) opts :: (AppPerks m) => ParserInfo (GlobalOptions, Command m) opts = O.info (liftA2 (,) globalOptions commands <**> helper) ( fullDesc - -- <> progDesc "An application with global options and subcommands" <> header "hbs2-keyman" ) + +showConfig :: (AppPerks m) => Parser (Command m) +showConfig = do + pure do + readConfig >>= liftIO . print . vcat . fmap pretty + +addPath :: (AppPerks m) => Parser (Command m) +addPath = do + masks <- many $ strArgument (metavar "KEYFILE-MASK") + pure do + cfg <- getConfigPath <&> takeDirectory + mkdir cfg + for_ masks $ \m -> do + liftIO $ appendFile (cfg "config") (show $ "key-files" <+> dquotes (pretty m) <> line) + listKeysCmd :: (AppPerks m) => Parser (Command m) listKeysCmd = pure do kw <- withState listKeys @@ -54,11 +72,25 @@ listKeysCmd = pure do updateKeys :: (AppPerks m) => Parser (Command m) updateKeys = do + prune <- flag False True ( long "prune" <> short 'p' <> help "prune keys for missed files") pure do + masks <- cfgValue @KeyFilesOpt @(Set String) <&> Set.toList files <- KeyRing.findFilesBy masks + when prune do + -- here <- doesPathExist fn + -- + keys <- withState listKeys + for_ keys $ \k -> void $ runMaybeT do + fn <- keyFile k & toMPlus <&> Text.unpack + here <- doesPathExist fn + unless here do + info $ "prune" <+> pretty fn + lift $ withState $ deleteKey (keyId k) + for_ files $ \fn -> runMaybeT do + bs <- liftIO $ BS.readFile fn krf <- parseCredentials @HBS2Basic (AsCredFile bs) & toMPlus @@ -66,17 +98,25 @@ updateKeys = do let skp = view peerSignPk krf withState do - info $ pretty (AsBase58 skp) <+> pretty "sign" <+> pretty fn + -- info $ pretty (AsBase58 skp) <+> pretty "sign" <+> pretty fn updateKeyFile (SomePubKey @'Sign skp) fn updateKeyType (SomePubKey @'Sign skp) for_ (view peerKeyring krf) $ \(KeyringEntry pk _ _) -> do - info $ pretty (AsBase58 pk) <+> pretty "encrypt" <+> pretty fn + -- info $ pretty (AsBase58 pk) <+> pretty "encrypt" <+> pretty fn updateKeyFile (SomePubKey @'Encrypt pk) fn updateKeyType (SomePubKey @'Encrypt pk) commitAll +setWeightCmd :: (AppPerks m) => Parser (Command m) +setWeightCmd = do + k <- argument str (metavar "KEY" <> help "Key identifier") + v <- argument auto (metavar "WEIGHT" <> help "Weight value") + pure do + withState $ updateKeyWeight k v + + main :: IO () main = do (_, action) <- execParser opts diff --git a/hbs2-keyman/hbs2-keyman.cabal b/hbs2-keyman/hbs2-keyman.cabal index 817571af..cf9061dc 100644 --- a/hbs2-keyman/hbs2-keyman.cabal +++ b/hbs2-keyman/hbs2-keyman.cabal @@ -47,6 +47,7 @@ common common-deps , tasty , tasty-hunit , temporary + , text , timeit , transformers , uniplate @@ -95,9 +96,9 @@ library exposed-modules: HBS2.KeyMan.App.Types + HBS2.KeyMan.Prelude HBS2.KeyMan.Config HBS2.KeyMan.State - HBS2.KeyMan.Keys HBS2.KeyMan.Keys.Direct -- other-modules: diff --git a/hbs2-keyman/src/HBS2/KeyMan/App/Types.hs b/hbs2-keyman/src/HBS2/KeyMan/App/Types.hs index bcd189de..7605dad6 100644 --- a/hbs2-keyman/src/HBS2/KeyMan/App/Types.hs +++ b/hbs2-keyman/src/HBS2/KeyMan/App/Types.hs @@ -6,15 +6,17 @@ module HBS2.KeyMan.App.Types , module Prettyprinter ) where +import HBS2.KeyMan.Prelude +import HBS2.KeyMan.Config +import HBS2.KeyMan.State + import HBS2.Prelude import HBS2.Base58 -- FIXME: remove-this -import HBS2.Net.Proto.Definition () +import HBS2.Net.Auth.Credentials() import HBS2.Net.Proto.Types -import HBS2.KeyMan.Config -import HBS2.KeyMan.State import HBS2.System.Logger.Simple import Data.Config.Suckless diff --git a/hbs2-keyman/src/HBS2/KeyMan/Keys.hs b/hbs2-keyman/src/HBS2/KeyMan/Keys.hs deleted file mode 100644 index a96e8b67..00000000 --- a/hbs2-keyman/src/HBS2/KeyMan/Keys.hs +++ /dev/null @@ -1,4 +0,0 @@ -module HBS2.KeyMan.Keys where - - - diff --git a/hbs2-keyman/src/HBS2/KeyMan/Keys/Direct.hs b/hbs2-keyman/src/HBS2/KeyMan/Keys/Direct.hs index 4b679f49..e7ed852f 100644 --- a/hbs2-keyman/src/HBS2/KeyMan/Keys/Direct.hs +++ b/hbs2-keyman/src/HBS2/KeyMan/Keys/Direct.hs @@ -1,21 +1,26 @@ module HBS2.KeyMan.Keys.Direct where +import HBS2.KeyMan.App.Types +import HBS2.KeyMan.Prelude +import HBS2.KeyMan.State +import HBS2.KeyMan.Config + import HBS2.Prelude.Plated import HBS2.Net.Auth.Credentials import HBS2.Net.Proto.Types -import HBS2.KeyMan.App.Types -import HBS2.KeyMan.State + +import HBS2.System.Dir import Control.Monad.Cont -import Control.Monad.Reader -import Control.Monad.Except import UnliftIO import DBPipe.SQLite import Text.InterpolatedString.Perl6 (qc) import Data.Maybe import Control.Monad.Trans.Maybe +import Data.List qualified as List import Data.ByteString qualified as BS +import Data.Ord data KeyManClientError = KeyManClientSomeError @@ -29,16 +34,24 @@ newtype KeyManClient m a = KeyManClient { fromKeyManClient :: DBPipeM m a } runKeymanClient :: MonadUnliftIO m => KeyManClient m a -> m a runKeymanClient action = do + dbPath <- getStatePath env <- liftIO newAppEnv let db = appDb env flip runContT pure $ do void $ ContT $ bracket (async (runPipe db)) cancel + + here <- doesPathExist dbPath + + unless here do + withDB db $ populateState + lift $ withDB db (fromKeyManClient action) loadCredentials :: forall a m . ( MonadIO m , SomePubKeyPerks a + , SerialisedCredentials HBS2Basic ) => a -> KeyManClient m (Maybe (PeerCredentials HBS2Basic)) @@ -58,6 +71,7 @@ loadCredentials k = KeyManClient do loadKeyRingEntry :: forall m . ( MonadIO m + , SerialisedCredentials HBS2Basic ) => PubKey 'Encrypt HBS2Basic -> KeyManClient m (Maybe (KeyringEntry HBS2Basic)) @@ -71,3 +85,21 @@ loadKeyRingEntry pk = KeyManClient do , p == pk ] +loadKeyRingEntries :: forall m . + ( MonadIO m + , SerialisedCredentials HBS2Basic + ) + => [PubKey 'Encrypt HBS2Basic] + -> KeyManClient m [(Word, KeyringEntry HBS2Basic)] +loadKeyRingEntries pks = KeyManClient do + r <- for pks $ \pk -> runMaybeT do + fn <- lift (selectKeyFile pk) >>= toMPlus + w <- lift (selectKeyWeight pk) + bs <- liftIO (try @_ @IOException $ BS.readFile fn) >>= toMPlus + creds <- toMPlus $ parseCredentials (AsCredFile bs) + toMPlus $ headMay [ (w,e) + | e@(KeyringEntry p _ _) <- view peerKeyring creds + , p == pk + ] + pure $ catMaybes r & List.sortOn (Down . fst) + diff --git a/hbs2-keyman/src/HBS2/KeyMan/Prelude.hs b/hbs2-keyman/src/HBS2/KeyMan/Prelude.hs new file mode 100644 index 00000000..0b6fefeb --- /dev/null +++ b/hbs2-keyman/src/HBS2/KeyMan/Prelude.hs @@ -0,0 +1,8 @@ +module HBS2.KeyMan.Prelude + ( module HBS2.Prelude.Plated + ) where + + +import HBS2.Prelude.Plated + + diff --git a/hbs2-keyman/src/HBS2/KeyMan/State.hs b/hbs2-keyman/src/HBS2/KeyMan/State.hs index 3074f89a..3a44323b 100644 --- a/hbs2-keyman/src/HBS2/KeyMan/State.hs +++ b/hbs2-keyman/src/HBS2/KeyMan/State.hs @@ -23,6 +23,8 @@ import Control.Monad.Trans.Maybe import Text.InterpolatedString.Perl6 (qc) import Data.Maybe +import UnliftIO + -- newtype ToDB a = ToDB a class SomePubKeyType a where somePubKeyType :: a -> String @@ -74,11 +76,20 @@ populateState = do ) |] + ddl [qc| + create table if not exists keyweight + ( key text not null + , weight int not null + , primary key (key) + ) + |] + commitAll instance ToField (SomePubKey a) where toField (SomePubKey s) = toField $ show $ pretty (AsBase58 s) + updateKeyFile :: forall a m . (SomePubKeyType (SomePubKey a), MonadIO m) => SomePubKey a -> FilePath @@ -133,28 +144,63 @@ selectKeyFile pk = do data KeyListView = KeyListView - { keyId :: Text - , keyType :: Text - , keyAlias :: Maybe Text - , keyFile :: Maybe Text + { keyId :: Text + , keyType :: Text + , keyWeight :: Maybe Word + , keyAlias :: Maybe Text + , keyFile :: Maybe Text } deriving stock (Show,Generic) instance FromRow KeyListView instance Pretty KeyListView where - pretty KeyListView{..} = fill (-32) (pretty keyId) + pretty KeyListView{..} = fill 44 (pretty keyId) + <+> fill 5 (pretty keyWeight) <+> fill 10 (pretty keyType) <+> pretty keyFile -listKeys :: MonadIO m - => DBPipeM m [KeyListView] +listKeys :: MonadIO m => DBPipeM m [KeyListView] listKeys = select_ [qc| - select t.key, t.type, a.alias, f.file - from keytype t left join keyalias a on a.key = t.key - left join keyfile f on f.key = t.key + select t.key, t.type, w.weight, a.alias, f.file + from keytype t + left join keyalias a on a.key = t.key + left join keyfile f on f.key = t.key + left join keyweight w on w.key = t.key + order by w.weight ASC, f.file ASC |] +deleteKey :: (MonadUnliftIO m, ToField a) => a -> DBPipeM m () +deleteKey keyId = transactional do + insert [qc|delete from keyfile where key = ?|] (Only keyId) + insert [qc|delete from keytype where key = ?|] (Only keyId) + insert [qc|delete from keyalias where key = ?|] (Only keyId) + insert [qc|delete from keyweight where key = ?|] (Only keyId) + commitAll + + + +updateKeyWeight :: (MonadIO m, ToField a) => a -> Int -> DBPipeM m () +updateKeyWeight key weight = do + insert [qc| + insert into keyweight (key, weight) + values (?, ?) + on conflict (key) do update set weight = excluded.weight + |] (key, weight) + pure () + +selectKeyWeight :: (MonadIO m, SomePubKeyPerks a) + => a + -> DBPipeM m Word + +selectKeyWeight key = do + select [qc| + select coalesce(weight,0) as weight + from keyweight + where key = ? + limit 1 + |] (Only (SomePubKey key)) <&> maybe 0 fromOnly . listToMaybe + diff --git a/hbs2-peer/app/BlockDownload.hs b/hbs2-peer/app/BlockDownload.hs index cc0d6da2..5c413fd7 100644 --- a/hbs2-peer/app/BlockDownload.hs +++ b/hbs2-peer/app/BlockDownload.hs @@ -2,8 +2,10 @@ {-# Language UndecidableInstances #-} module BlockDownload where +import HBS2.Peer.Prelude +import HBS2.Base58 import HBS2.Actors.Peer -import HBS2.Clock +import HBS2.Data.Types.Peer import HBS2.Data.Detect import HBS2.Data.Types.Refs import HBS2.Data.Bundle @@ -13,12 +15,7 @@ import HBS2.Events import HBS2.Hash import HBS2.Merkle import HBS2.Net.PeerLocator -import HBS2.Net.Proto -import HBS2.Net.Proto.Definition -import HBS2.Net.Proto.Peer -import HBS2.Net.Proto.RefLog -import HBS2.Net.Proto.Sessions -import HBS2.Prelude.Plated +import HBS2.Peer.Proto import HBS2.Storage import HBS2.Storage.Operations.Missed import HBS2.Misc.PrettyStuff @@ -35,18 +32,711 @@ import Control.Monad.Trans.Maybe import Data.Cache qualified as Cache import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap -import Data.IntMap qualified as IntMap +import Data.HashMap.Strict qualified as HM +import Data.HashSet (HashSet) +import Data.HashSet qualified as HS +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap import Data.IntSet qualified as IntSet import Data.Maybe +import Data.Either +import Data.ByteString.Lazy (ByteString) +import Data.List qualified as L import Lens.Micro.Platform import Codec.Serialise import Data.Hashable import System.Random.Shuffle (shuffleM) import Control.Concurrent (getNumCapabilities) +import Streaming.Prelude qualified as S +import System.Random import UnliftIO +trimFactor :: Double +trimFactor = 100 + + +-- NOTE: if peer does not have a block, it may +-- cause to an unpleasant timeouts +-- So make sure that this peer really answered to +-- GetBlockSize request + + +downloadFromWithPeer :: forall e m . ( DownloadFromPeerStuff e m + , e ~ L4Proto + , HasPeerLocator e (BlockDownloadM e m) ) + => Peer e + -> Integer + -> Hash HbSync + -> BlockDownloadM e m (Maybe ByteString) +downloadFromWithPeer peer thisBkSize h = do + + brains <- asks (view downloadBrains) + + npi <- newPeerInfo + pinfo <- lift $ fetch True npi (PeerInfoKey peer) id + + sto <- lift getStorage + + let chunkSize = case view sockType peer of + UDP -> defChunkSize + TCP -> defChunkSize + + coo <- genCookie (peer,h) + let key = DownloadSessionKey (peer, coo) + let chusz = fromIntegral chunkSize -- defChunkSize + dnwld <- newBlockDownload h + let chuQ = view sBlockChunks dnwld + let new = set sBlockChunkSize chusz + . set sBlockSize (fromIntegral thisBkSize) + $ dnwld + + trace $ "downloadFromWithPeer STARTED" <+> pretty coo + + lift $ update @e new key id + + let burstSizeT = view peerBurst pinfo + + burstSize <- liftIO $ readTVarIO burstSizeT + + let offsets = calcChunks thisBkSize (fromIntegral chusz) :: [(Offset, Size)] + + let chunkNums = [ 0 .. pred (length offsets) ] + + let bursts = calcBursts burstSize chunkNums + + -- let burstTime = min defChunkWaitMax $ realToFrac w :: Timeout 'Seconds + -- trace $ "BURST TIME" <+> pretty burstTime + + let r = view sBlockChunks2 new + rq <- liftIO newTQueueIO + + for_ bursts $ liftIO . atomically . writeTQueue rq + + rtt <- medianPeerRTT pinfo <&> fmap ( (/1e9) . realToFrac ) + <&> fromMaybe 0.1 + + r <- fix \next -> do + burst <- liftIO $ atomically $ tryReadTQueue rq + + case burst of + + Just (i,chunksN) -> do + let req = BlockGetChunks h chusz (fromIntegral i) (fromIntegral chunksN) + + void $ liftIO $ atomically $ STM.flushTQueue chuQ + + lift $ request peer (BlockChunks @e coo req) + + let waity = do + fix \zzz -> do + + wt <- race ( pause @'Seconds 1 ) (atomically $ peekTQueue chuQ >> STM.flushTQueue chuQ) + + case wt of + Left{} -> pure False + Right{} -> do + + d <- atomically do + m <- readTVar r + hc <- forM [i .. i + chunksN-1 ] $ \j -> do + pure (IntMap.member j m) + + pure ( and hc ) + + if d then pure True else zzz + + catched <- race (pause @'Seconds 3 >> pure False) waity <&> either id id + + void $ liftIO $ atomically $ STM.flushTQueue chuQ + + if catched then do + liftIO $ atomically do + modifyTVar (view peerDownloaded pinfo) (+chunksN) + writeTVar (view peerPingFailed pinfo) 0 + + else do + + liftIO $ atomically $ modifyTVar (view peerErrors pinfo) succ + updatePeerInfo True peer pinfo + + newBurst <- liftIO $ readTVarIO burstSizeT + -- let newBurst = max defBurst $ floor (realToFrac newBurst' * 0.5 ) + + liftIO $ atomically $ modifyTVar (view peerDownloaded pinfo) (+chunksN) + + let chuchu = calcBursts newBurst [ i + n | n <- [0 .. chunksN] ] + + liftIO $ atomically $ modifyTVar (view peerErrors pinfo) succ + + trace $ "new burst: " <+> pretty newBurst + trace1 $ red $ "missed chunks for request" <+> pretty (peer,i,chunksN) + + for_ chuchu $ liftIO . atomically . writeTQueue rq + + next + + Nothing -> do + + sz <- liftIO $ readTVarIO r <&> IntMap.size + + if sz >= length offsets then do + pieces <- liftIO $ readTVarIO r <&> IntMap.elems + let block = mconcat pieces + let h1 = hashObject @HbSync block + + if h1 == h then do + trace $ "PROCESS BLOCK" <+> pretty coo <+> pretty h + -- onBlockDownloaded brains peer h + pure (Just block) + else do + debug $ red "HASH NOT MATCH / PEER MAYBE JERK" + pure Nothing + + else do + debug $ red $ "RETRY BLOCK DOWNLOADING / ASK FOR MISSED CHUNKS" + got <- liftIO $ readTVarIO r <&> IntMap.keysSet + let need = IntSet.fromList (fmap fromIntegral chunkNums) + + let missed = IntSet.toList $ need `IntSet.difference` got + + -- normally this should not happen + -- however, let's try do download the tails + -- by one chunk a time + for_ missed $ \n -> do + debug $ "MISSED CHUNK" <+> pretty coo <+> pretty n + liftIO $ atomically $ writeTQueue rq (n,1) + + next + + lift $ expire @e key + debug $ yellow $ "downloadFromWithPeer EXIT" <+> pretty coo + pure r + + +instance HasPeerLocator e m => HasPeerLocator e (BlockDownloadM e m) where + getPeerLocator = lift getPeerLocator + + +-- NOTE: updatePeerInfo is CC +-- updatePeerInfo is actuall doing CC (congestion control) + +updatePeerInfo :: forall e m . (e ~ L4Proto, MonadIO m) => Bool -> Peer e -> PeerInfo e -> m () + +updatePeerInfo _ p pinfo | view sockType p == TCP = do + liftIO $ atomically $ writeTVar (view peerBurst pinfo) 256 + +updatePeerInfo onError _ pinfo = do + + t1 <- liftIO getTimeCoarse + + void $ liftIO $ atomically $ do + + bu <- readTVar (view peerBurst pinfo) + buMax <- readTVar (view peerBurstMax pinfo) + buSet <- readTVar (view peerBurstSet pinfo) + errs <- readTVar (view peerErrors pinfo) + errsLast <- readTVar (view peerErrorsLast pinfo) + t0 <- readTVar (view peerLastWatched pinfo) + down <- readTVar (view peerDownloaded pinfo) + downLast <- readTVar (view peerDownloadedLast pinfo) + -- downFail <- readTVar (view peerDownloadFail pinfo) + -- downBlk <- readTVar (view peerDownloadedBlk pinfo) + + let dE = realToFrac $ max 0 (errs - errsLast) + let dT = realToFrac (max 1 (toNanoSecs t1 - toNanoSecs t0)) / 1e9 + + let eps = floor (dE / dT) + + let win = min 10 $ 4 * (defBurstMax - defBurst) + + when (down - downLast > 0 || onError) do + + (bu1, bus) <- if eps == 0 && not onError then do + let bmm = fromMaybe defBurstMax buMax + let buN = min bmm (ceiling (realToFrac bu * 1.10)) + pure (buN, trimUp win $ IntSet.insert buN buSet) + else do + let buM = headMay $ drop 1 $ IntSet.toDescList buSet + writeTVar (view peerBurstMax pinfo) buM + let buN = headDef defBurst $ drop 4 $ IntSet.toDescList buSet + pure (buN, trimDown win $ IntSet.insert buN buSet) + + + writeTVar (view peerErrorsLast pinfo) errs + writeTVar (view peerLastWatched pinfo) t1 + writeTVar (view peerErrorsPerSec pinfo) eps + writeTVar (view peerBurst pinfo) bu1 + writeTVar (view peerBurstSet pinfo) bus + writeTVar (view peerDownloadedLast pinfo) down + -- writeTVar (view peerUsefulness pinfo) usefulN + + where + trimUp n s | IntSet.size s >= n = IntSet.deleteMin s + | otherwise = s + + 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 + + +downloadOnBlockSize :: (MonadIO m, IsPeerAddr e m, MyPeer e) + => DownloadEnv e + -> (Peer e, Hash HbSync, Maybe Integer) + -> m () + +downloadOnBlockSize denv item@(p,h,size) = do + let f = if isJust size then green else red + debug $ f "GOT BLOCK SIZE" <+> pretty p <+> pretty h <+> pretty size + atomically $ writeTVar (_blockInDirty denv) True + atomically $ writeTQueue (_blockSizeRecvQ denv) item + +blockDownloadLoop :: forall e m . ( m ~ PeerM e IO + , MonadIO m + , Request e (BlockInfo e) m + , Request e (BlockAnnounce e) m + , HasProtocol e (BlockInfo e) + , HasProtocol e (BlockAnnounce e) + , HasProtocol e (BlockChunks e) + , EventListener e (BlockInfo e) m + , EventListener e (BlockChunks e) m + , EventListener e (BlockAnnounce e) m + , EventListener e (PeerHandshake e) m + , EventListener e (RefLogUpdateEv e) m + , EventListener e (RefLogRequestAnswer e) m + , EventEmitter e (BlockChunks e) m + , EventEmitter e (DownloadReq e) m + , Sessions e (BlockChunks e) m + , Sessions e (PeerInfo e) m + , Sessions e (KnownPeer e) m + , PeerSessionKey e (PeerInfo e) + , HasStorage m + , Pretty (Peer e) + , PeerMessaging e + , IsPeerAddr e m + , HasPeerLocator e m + , e ~ L4Proto + ) + => DownloadEnv e -> m () +blockDownloadLoop env0 = do + + let blkInfoLock = 5 :: Timeout 'Seconds + let blkWaitLock = 60 :: Timeout 'Seconds + let workloadFactor = 1.10 + + e <- ask + sto <- getStorage + + let downT = 8 + let sizeT = 1 + + inQ <- withDownload env0 $ asks (view blockInQ) + checkQ <- withDownload env0 $ asks (view blockCheckQ) + sizeQ <- newTQueueIO + fetchQ <- newTQueueIO + parseQ <- newTQueueIO + sizeRQ <- withDownload env0 $ asks (view blockSizeRecvQ) + + -- FIXME: cleanup-nonce + nonces <- newTVarIO (mempty :: HashMap (Peer e) PeerNonce) + + -- FIXME: cleanup-busy + busy <- newTVarIO (mempty :: HashMap PeerNonce Double) + + rates <- newTVarIO (mempty :: IntMap.IntMap [(Peer e,PeerNonce)]) + + fetchH <- newTVarIO (mempty :: HashSet (Hash HbSync)) + sizes <- newTVarIO (mempty :: HashMap (Peer e, Hash HbSync) (Maybe Integer, TimeSpec)) + sizeReq <- newTVarIO (mempty :: HashMap (Hash HbSync) TimeSpec) + + seen <- newTVarIO (mempty :: HashMap (Hash HbSync) Int) + + flip runContT pure do + void $ ContT $ withAsync updatePeers + + -- UPDATE-STATS-LOOP + void $ ContT $ withAsync $ updateRates e rates nonces + + replicateM_ downT $ ContT $ withAsync do + forever do + pause @'Seconds 120 + atomically do + q <- readTVar inQ + let isInQ x = HashMap.member x q + modifyTVar' fetchH (HS.filter isInQ) + modifyTVar' sizeReq (HM.filterWithKey (curry (isInQ . fst))) + modifyTVar' sizes (HM.filterWithKey (curry (isInQ . snd . fst))) + modifyTVar' seen (HM.filterWithKey (curry (isInQ . fst))) + + livePeers <- readTVar rates <&> mconcat . IntMap.elems + let liveNonce = HS.fromList (fmap snd livePeers) + let livePeer = HS.fromList (fmap fst livePeers) + + modifyTVar' busy (HM.filterWithKey (\x _ -> HS.member x liveNonce)) + modifyTVar' nonces (HM.filterWithKey (\x _ -> HS.member x livePeer)) + + replicateM_ downT $ ContT $ withAsync do + forever do + blk <- atomically $ readTQueue checkQ + here <- hasBlock sto blk <&> isJust + if not here then do + atomically $ writeTQueue sizeQ blk + else do + atomically $ writeTQueue parseQ blk + + void $ ContT $ withAsync do + forever do + blk <- atomically $ readTQueue parseQ + withDownload env0 do + + blks <- findMissedBlocks sto (HashRef blk) + + for_ blks $ \b -> do + addDownload (Just blk) (fromHashRef b) + + processBlock blk + deleteBlockFromQ blk + + replicateM_ 1 $ ContT $ withAsync do + forever do + + -- pause @'Seconds 0.25 + + items <- atomically do + peekTQueue sizeRQ >> STM.flushTQueue sizeRQ + + now <- getTimeCoarse + + todo <- atomically do + w <- for items $ \(p,h,s) -> do + modifyTVar sizes (HashMap.insert (p,h) (s, now)) + readTVar nonces <&> HashMap.lookup p >>= \case + Nothing -> pure () + Just nonce -> setBusySTM nonce busy (Just (setFactor 0 (0.01-))) + pure h + + for (L.nub w) pure + + for_ todo $ \b -> do + here <- hasBlock sto b <&> isJust + + already <- atomically do + readTVar fetchH <&> HS.member b + + when (not here && not already) do + atomically $ writeTQueue fetchQ b + + replicateM_ sizeT $ ContT $ withAsync do + + -- TODO: trim-sizeReq + let blocks = readTVarIO sizeReq <&> HashMap.keys <&> fmap (,2) + + polling (Polling 1 1) blocks $ \h -> do + pips <- readTVarIO nonces <&> HashMap.keys + s <- readTVarIO sizes <&> HashMap.toList + + for_ pips $ \p -> do + here <- lookupSizeIO sizes p h <&> isRight + + if here then do + atomically $ modifyTVar sizeReq (HashMap.delete h) + else + request p (GetBlockSize @e h) + + + replicateM_ sizeT $ ContT $ withAsync do + + forever do + + blk <- atomically do + readTVar rates <&> not . IntMap.null >>= STM.check + readTQueue sizeQ + + debug $ green "PEER SIZE THREAD" <+> pretty blk + + + r <- readTVarIO rates <&> IntMap.toDescList + <&> foldMap snd + + + answ <- for r $ \(p,nonce) -> do + lookupSizeIO sizes p blk >>= \case + -- уже спрашивали, отрицает + Left{} -> do + npi <- newPeerInfo + PeerInfo{..} <- fetch True npi (PeerInfoKey p) id + + atomically do + setBusySTM nonce busy (Just (setFactor 0 (+(-0.01)))) + modifyTVar _peerDownloadMiss succ + modifyTVar seen (HashMap.insertWith (+) blk 1) + modifyTVar sizeReq (HashMap.delete blk) + + debug $ red "NONE:" <+> pretty p <+> pretty blk + pure 0 + + -- уже спрашивали, ответил + Right (Just w) -> do + + atomically do + setBusySTM nonce busy (Just (setFactor 0 (+(-0.01)))) + modifyTVar sizeReq (HashMap.delete blk) + + debug $ red "SIZE:" <+> pretty p <+> pretty blk <+> pretty w + pure 1 + + -- не спрашивали еще + Right Nothing -> do + (doReq, f) <- atomically do + f <- lookupBusySTM nonce busy + if f > workloadFactor then + pure (False, f) + else do + setBusySTM nonce busy (Just (setFactor 0.01 (+0.01))) + pure (True, f) + + debug $ green "BUSY" <+> pretty p <+> pretty f + + when doReq do + debug $ red "SEND REQUEST FOR SIZE" <+> pretty p <+> pretty blk + async $ do + pause blkInfoLock + atomically (setBusySTM nonce busy (Just (setFactor 0 (+(-0.01))))) + + withPeerM e $ request p (GetBlockSize @e blk) + now <- getTimeCoarse + atomically $ modifyTVar sizeReq (HashMap.insert blk now) + + pure 0 + + if sum answ > 0 then do + atomically do + here <- readTVar fetchH <&> HS.member blk + readTVar seen <&> HM.delete blk + unless here $ + writeTQueue fetchQ blk + + else do + howMany <- readTVarIO seen <&> (fromMaybe 0 . HashMap.lookup blk) + pips <- readTVarIO nonces <&> HM.size + -- FIXME: hardcode + when (howMany < 10) do + atomically $ writeTQueue sizeQ blk + + void $ ContT $ withAsync do + -- FIXME: ban-time-hardcode + let loosers = readTVarIO seen <&> fmap (,120) . HashMap.keys + polling (Polling 1 10) loosers $ \it -> do + atomically $ writeTQueue checkQ it + atomically $ modifyTVar seen (HashMap.delete it) + + replicateM_ downT $ ContT $ withAsync do + + gen <- newStdGen + + forever do + + flip runContT pure $ callCC \exit -> do + + blk <- atomically $ readTQueue fetchQ + + atomically do + modifyTVar fetchH (HS.insert blk) + + here <- hasBlock sto blk <&> isJust + + when here $ exit () + + debug $ green "PEER DOWNLOAD THREAD" <+> pretty blk + + -- TODO: already-downloaded-possible + + let ws = round . (*trimFactor) <$> randomRs (0, 2.5) gen + + work <- lift $ race (pause @'Seconds 60) $ atomically do + r0 <- readTVar rates <&> IntMap.toList + bsy <- readTVar busy + + let bx nonce = + round $ trimFactor * (1.75 / (1.0 + fromMaybe 0 (HashMap.lookup nonce bsy))) + + let w = [ (-(v + w0 + bx nonce), p) + | (v, (w0, peers)) <- zip ws r0, p@(_,nonce) <- peers + ] & L.sortOn fst & fmap snd + + avail' <- for w $ \(peer,nonce) -> do + p <- readTVar busy <&> HashMap.lookup nonce + sz <- lookupSizeSTM sizes peer blk + if p < Just workloadFactor then + pure (Just (peer,nonce, sz)) + else + pure Nothing + + let avail = catMaybes avail' + + STM.check (not $ L.null avail) + + found <- for avail $ \(pip, nonce, msz) -> case msz of + Right (Just sz) -> do + pure $ Just (blk, pip, nonce, sz) + + _ -> pure Nothing + + case headMay (catMaybes found) of + Nothing -> do + writeTQueue checkQ blk + modifyTVar fetchH (HS.delete blk) + pure Nothing + + Just what@(_,_,nonce,_) -> do + setBusySTM nonce busy (Just (setFactor 1.0 (+1.0))) + pure $ Just what + + case work of + Right (Just (b,p,nonce,s)) -> do + debug $ green "WORKER CHOOSEN" <+> pretty p <+> pretty blk <+> pretty s + r <- lift $ race (pause @'Seconds 60) (withDownload env0 $ downloadFromWithPeer p s b) + + atomically do + setBusySTM nonce busy (Just (setFactor 0 (const 0))) + + npi <- newPeerInfo + PeerInfo{..} <- lift $ fetch True npi (PeerInfoKey p) id + + debug $ green "DOWNLOAD DONE!" <+> pretty p <+> pretty blk <+> pretty s <+> pretty (isRight r) + + atomically $ modifyTVar fetchH (HS.delete blk) + + case r of + Right (Just block) -> do + mh <- putBlock sto block + atomically do + modifyTVar _peerDownloaded succ + modifyTVar _peerDownloadedBlk succ + + case mh of + Nothing -> err $ red "storage write error!" + Just h-> do + atomically $ writeTQueue parseQ h + _ -> do + debug $ red "DOWNLOAD FAILED / TIMEOUT" + atomically do + modifyTVar _peerDownloadFail succ + modifyTVar _peerErrors succ + writeTQueue checkQ blk + + _ -> do + debug $ red "WAIT FOR PEERS TIMEOUT" <+> pretty blk + atomically $ writeTVar busy mempty + + forever do + withPeerM e $ withDownload env0 do + pause @'Seconds 5 + wip <- asks _blockInQ >>= readTVarIO <&> HashMap.size + notice $ yellow "wip" <+> pretty wip + + where + + setFactor d f = \case + Nothing -> Just d + Just v -> Just (g v) + where + g y = f y & max 0 + + setBusySTM nonce busy = \case + Nothing -> modifyTVar busy (HashMap.delete nonce) + Just fn -> modifyTVar busy (HashMap.alter fn nonce) + + lookupBusySTM nonce busy = + readTVar busy <&> fromMaybe 0 . HashMap.lookup nonce + + lookupSizeSTM sizes p h = do + readTVar sizes + <&> HashMap.lookup (p,h) + <&> \case + Nothing -> Right Nothing + Just (Just x,_) -> Right (Just x) + Just (Nothing,_) -> Left () + + lookupSizeIO sizes p h = do + atomically $ lookupSizeSTM sizes p h + + updateRates e rates nonces = withPeerM e do + + let wRtt = 5 + let wUdp = 1.75 + let wTcp = 1.0 + let wS = 1.5 + let eps = 1e-8 + + forever do + pause @'Seconds 20 + + new <- S.toList_ do + withPeerM e $ forKnownPeers @e $ \peer pd -> do + pinfo <- find (PeerInfoKey peer) id + maybe1 pinfo none $ \pip -> do + + let nonce = _peerOwnNonce pd + + atomically $ modifyTVar nonces (HashMap.insert peer nonce) + + sr <- readTVarIO (_peerDownloaded pip) + er <- readTVarIO (_peerDownloadFail pip) + + let s = (eps + realToFrac sr) / (eps + realToFrac (sr + er)) + +{- HLINT ignore "Functor law" -} + rtt <- medianPeerRTT pip + <&> fmap ( (/1e9) . realToFrac ) + <&> fromMaybe 1.0 + + let (udp,tcp) = case view sockType peer of + UDP -> (0, wUdp * 1.0) + TCP -> (wTcp * 1.0, 0) + + let r = udp + tcp + wS*s + lift $ S.yield (peer, nonce, (r, rtt)) + + let maxRtt = maximumDef 1.0 [ rtt | (_, _, (_, rtt)) <- new ] + + let mkRate s rtt = round $ trimFactor * (s + wRtt * (1 / (1 + rtt / maxRtt))) + + let newRates = [ (mkRate s rtt, [(p,nonce)] ) + | (p, nonce, (s, rtt)) <- new + ] + + + atomically do + writeTVar rates (IntMap.fromListWith (<>) newRates) + + debug $ green "PEER RATES" <+> line <> vcat (fmap fmt newRates) + + where + fmt (r,prs) = pretty r <+> hcat (fmap (pretty . view _1) prs) + + updatePeers = do + e <- ask + pl <- getPeerLocator @e + forever $ withPeerM e do + pause @'Seconds 3.0 + + pee <- knownPeers @e pl + npi <- newPeerInfo + + for_ pee $ \p -> do + pinfo <- fetch True npi (PeerInfoKey p) id + updatePeerInfo False p pinfo + + processBlock :: forall e m . ( MonadIO m , HasStorage m , MyPeer e @@ -70,7 +760,7 @@ processBlock h = do -- FIXME: если блок нашёлся, то удаляем его из wip - when (isJust bt) (removeFromWip h) + when (isJust bt) (deleteBlockFromQ h) let handleHrr (hrr :: Either (Hash HbSync) [HashRef]) = do case hrr of @@ -118,11 +808,11 @@ processBlock h = do CryptAccessKeyNaClAsymm h -> addDownload parent h EncryptGroupNaClSymm h _ -> addDownload parent h - debug $ "GOT WRAPPED MERKLE. requesting nodes/leaves" <+> pretty h + trace $ "GOT WRAPPED MERKLE. requesting nodes/leaves" <+> pretty h walkMerkleTree (_mtaTree ann) (liftIO . getBlock sto) handleHrr Just (Merkle{}) -> do - debug $ "GOT MERKLE. requesting nodes/leaves" <+> pretty h + trace $ "GOT MERKLE. requesting nodes/leaves" <+> pretty h walkMerkle h (liftIO . getBlock sto) handleHrr Just (Blob{}) -> do @@ -156,657 +846,6 @@ processBlock h = do where unboxBundleRef (BundleRefValue box) = unboxSignedBox0 box --- NOTE: if peer does not have a block, it may --- cause to an unpleasant timeouts --- So make sure that this peer really answered to --- GetBlockSize request - - -downloadFromWithPeer :: forall e m . ( DownloadFromPeerStuff e m - , e ~ L4Proto - , HasPeerLocator e (BlockDownloadM e m) ) - => Peer e - -> Integer - -> Hash HbSync - -> BlockDownloadM e m () -downloadFromWithPeer peer thisBkSize h = do - - brains <- asks (view downloadBrains) - - npi <- newPeerInfo - pinfo <- lift $ fetch True npi (PeerInfoKey peer) id - - sto <- lift getStorage - - let chunkSize = case view sockType peer of - UDP -> defChunkSize - TCP -> defChunkSize - - coo <- genCookie (peer,h) - let key = DownloadSessionKey (peer, coo) - let chusz = fromIntegral chunkSize -- defChunkSize - dnwld <- newBlockDownload h - let chuQ = view sBlockChunks dnwld - let new = set sBlockChunkSize chusz - . set sBlockSize (fromIntegral thisBkSize) - $ dnwld - - trace $ "downloadFromWithPeer STARTED" <+> pretty coo - - lift $ update @e new key id - - let burstSizeT = view peerBurst pinfo - - burstSize <- liftIO $ readTVarIO burstSizeT - - let offsets = calcChunks thisBkSize (fromIntegral chusz) :: [(Offset, Size)] - - let chunkNums = [ 0 .. pred (length offsets) ] - - let bursts = calcBursts burstSize chunkNums - - rtt <- medianPeerRTT pinfo <&> fmap ( (/1e9) . realToFrac ) - <&> fromMaybe defChunkWaitMax - - let w = 10 * rtt * realToFrac (length bursts) - - let burstTime = min defChunkWaitMax $ realToFrac w :: Timeout 'Seconds - - trace $ "BURST TIME" <+> pretty burstTime - - let r = view sBlockChunks2 new - rq <- liftIO newTQueueIO - - for_ bursts $ liftIO . atomically . writeTQueue rq - - fix \next -> do - burst <- liftIO $ atomically $ tryReadTQueue rq - - case burst of - - Just (i,chunksN) -> do - let req = BlockGetChunks h chusz (fromIntegral i) (fromIntegral chunksN) - - void $ liftIO $ atomically $ STM.flushTQueue chuQ - - lift $ request peer (BlockChunks @e coo req) - - let waity = liftIO $ race ( pause burstTime >> pure False ) do - fix \zzz -> do - hc <- atomically do - forM [i .. i + chunksN-1 ] $ \j -> do - m <- readTVar r - pure (j, IntMap.member j m) - - let here = all snd hc - if here then do - pure here - - else do - pause rtt - zzz - - void $ liftIO $ race ( pause (8 * rtt) ) $ atomically do - void $ peekTQueue chuQ - STM.flushTQueue chuQ - - catched <- waity <&> either id id - - if catched then do - liftIO $ atomically do - modifyTVar (view peerDownloaded pinfo) (+chunksN) - writeTVar (view peerPingFailed pinfo) 0 - - else do - - liftIO $ atomically $ modifyTVar (view peerErrors pinfo) succ - updatePeerInfo True peer pinfo - - newBurst <- liftIO $ readTVarIO burstSizeT - -- let newBurst = max defBurst $ floor (realToFrac newBurst' * 0.5 ) - - liftIO $ atomically $ modifyTVar (view peerDownloaded pinfo) (+chunksN) - - let chuchu = calcBursts newBurst [ i + n | n <- [0 .. chunksN] ] - - liftIO $ atomically $ modifyTVar (view peerErrors pinfo) succ - - trace $ "new burst: " <+> pretty newBurst - trace $ "missed chunks for request" <+> pretty (i,chunksN) - trace $ "burst time" <+> pretty burstTime - - for_ chuchu $ liftIO . atomically . writeTQueue rq - - next - - Nothing -> do - - sz <- liftIO $ readTVarIO r <&> IntMap.size - - if sz >= length offsets then do - pieces <- liftIO $ readTVarIO r <&> IntMap.elems - let block = mconcat pieces - let h1 = hashObject @HbSync block - - if h1 == h then 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 - trace "HASH NOT MATCH / PEER MAYBE JERK" - - else do - trace "RETRY BLOCK DOWNLOADING / ASK FOR MISSED CHUNKS" - got <- liftIO $ readTVarIO r <&> IntMap.keysSet - let need = IntSet.fromList (fmap fromIntegral chunkNums) - - let missed = IntSet.toList $ need `IntSet.difference` got - - -- normally this should not happen - -- however, let's try do download the tails - -- by one chunk a time - for_ missed $ \n -> do - trace $ "MISSED CHUNK" <+> pretty coo <+> pretty n - liftIO $ atomically $ writeTQueue rq (n,1) - - next - - lift $ expire @e key - trace $ "downloadFromWithPeer EXIT" <+> pretty coo - - - -instance HasPeerLocator e m => HasPeerLocator e (BlockDownloadM e m) where - getPeerLocator = lift getPeerLocator - - --- NOTE: updatePeerInfo is CC --- updatePeerInfo is actuall doing CC (congestion control) - -updatePeerInfo :: forall e m . (e ~ L4Proto, MonadIO m) => Bool -> Peer e -> PeerInfo e -> m () - -updatePeerInfo _ p pinfo | view sockType p == TCP = do - liftIO $ atomically $ writeTVar (view peerBurst pinfo) 256 - -updatePeerInfo onError _ pinfo = do - - t1 <- liftIO getTimeCoarse - - void $ liftIO $ atomically $ do - - bu <- readTVar (view peerBurst pinfo) - buMax <- readTVar (view peerBurstMax pinfo) - buSet <- readTVar (view peerBurstSet pinfo) - errs <- readTVar (view peerErrors pinfo) - errsLast <- readTVar (view peerErrorsLast pinfo) - t0 <- readTVar (view peerLastWatched pinfo) - down <- readTVar (view peerDownloaded pinfo) - downLast <- readTVar (view peerDownloadedLast pinfo) - -- downFail <- readTVar (view peerDownloadFail pinfo) - -- downBlk <- readTVar (view peerDownloadedBlk pinfo) - - let dE = realToFrac $ max 0 (errs - errsLast) - let dT = realToFrac (max 1 (toNanoSecs t1 - toNanoSecs t0)) / 1e9 - - let eps = floor (dE / dT) - - let win = min 10 $ 4 * (defBurstMax - defBurst) - - when (down - downLast > 0 || onError) do - - (bu1, bus) <- if eps == 0 && not onError then do - let bmm = fromMaybe defBurstMax buMax - let buN = min bmm (ceiling (realToFrac bu * 1.25)) - pure (buN, trimUp win $ IntSet.insert buN buSet) - else do - let buM = headMay $ drop 1 $ IntSet.toDescList buSet - writeTVar (view peerBurstMax pinfo) buM - let buN = headDef defBurst $ drop 2 $ IntSet.toDescList buSet - pure (buN, trimDown win $ IntSet.insert buN buSet) - - - writeTVar (view peerErrorsLast pinfo) errs - writeTVar (view peerLastWatched pinfo) t1 - writeTVar (view peerErrorsPerSec pinfo) eps - writeTVar (view peerBurst pinfo) bu1 - writeTVar (view peerBurstSet pinfo) bus - writeTVar (view peerDownloadedLast pinfo) down - -- writeTVar (view peerUsefulness pinfo) usefulN - - where - trimUp n s | IntSet.size s >= n = IntSet.deleteMin s - | otherwise = s - - 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 - , Request e (BlockAnnounce e) m - , HasProtocol e (BlockInfo e) - , HasProtocol e (BlockAnnounce e) - , HasProtocol e (BlockChunks e) - , EventListener e (BlockInfo e) m - , EventListener e (BlockChunks e) m - , EventListener e (BlockAnnounce e) m - , EventListener e (PeerHandshake e) m - , EventListener e (RefLogUpdateEv e) m - , EventListener e (RefLogRequestAnswer e) m - , EventEmitter e (BlockChunks e) m - , EventEmitter e (DownloadReq e) m - , Sessions e (BlockChunks e) m - , Sessions e (PeerInfo e) m - , Sessions e (KnownPeer e) m - , PeerSessionKey e (PeerInfo e) - , HasStorage m - , Pretty (Peer e) - , PeerMessaging e - , IsPeerAddr e m - , HasPeerLocator e m - , e ~ L4Proto - ) - => 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 - - pl <- getPeerLocator @e - - sto <- getStorage - - pause @'Seconds 3.81 - - let withAllStuff = withPeerM e . withDownload env0 - - flip runContT pure do - - -- 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 - - npi <- newPeerInfo - - 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 - - -- ШАГ 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 - trace $ "PEER CHECK" <+> pretty peer - auth <- withPeerM e (find (KnownPeerKey peer) id <&> isJust) - - when auth do - next PIdle - - debug $ yellow "PEER FINISHING" <+> pretty peer - - PWork (DTask{..}) -> do - trace $ "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 - trace $ "DOWNLOAD FAILED!" <+> pretty p <+> pretty h - -- addDownload Nothing h - - Right{} -> do - deleteBlockFromQ h - liftIO $ atomically do - writeTVar downFail 0 - modifyTVar downBlk succ - - trace $ "DOWNLOAD SUCCEED" <+> pretty p <+> pretty h - - next PIdle - - - atomically $ modifyTVar (_dPeerInbox state) (HashMap.insert peer (q, ass)) - - - where - printDownloadStats = do - pause @'Seconds 5 -- FIXME: put to defaults - -- we need to show download stats - - q <- asks (view blockInQ) - - 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 - , Request e (BlockInfo e) m - , EventListener e (BlockInfo e) m - , DownloadFromPeerStuff e m - , HasPeerLocator e m - , m ~ PeerM e IO - ) - => DownloadEnv e -> m () -postponedLoop env0 = do - e <- ask - - pause @'Seconds 2.57 - - flip runContT pure do - - void $ ContT $ withAsync $ liftIO $ withPeerM e $ withDownload env0 do - q <- asks (view blockDelayTo) - fix \next -> do - w <- liftIO $ atomically $ readTQueue q - pause defInterBlockDelay - addDownload mzero w - -- ws <- liftIO $ atomically $ flushTQueue q - -- for_ (w:ws) $ addDownload mzero - next - - void $ liftIO $ withPeerM e $ withDownload env0 do - forever do - pause @'Seconds 30 - trace "UNPOSTPONE LOOP" - po <- asks (view blockPostponedTo) >>= liftIO . Cache.toList - for_ po $ \(h, _, expired) -> do - when (isJust expired) do - unpostponeBlock h - -doBlockSizeRequest :: forall e m . ( MyPeer e - , Sessions e (KnownPeer e) m - , Request e (BlockInfo e) m - , EventListener e (BlockInfo e) m - , DownloadFromPeerStuff e m - , HasPeerLocator e m - , IsPeerAddr e m - , m ~ PeerM e IO - ) - => Peer e - -> Hash HbSync - -> BlockDownloadM e m (Either () (Maybe Integer)) - -doBlockSizeRequest peer h = do - - brains <- asks (view downloadBrains) - - q <- liftIO newTQueueIO - lift do - subscribe @e (BlockSizeEventKey h) $ \case - BlockSizeEvent (p1,_,s) -> do - when (p1 == peer) do - liftIO $ atomically $ writeTQueue q (Just s) - onBlockSize brains peer h s - - NoBlockEvent{} -> do - -- TODO: ban-block-for-some-seconds - liftIO $ atomically $ writeTQueue q Nothing - pure () - - request peer (GetBlockSize @e h) - - liftIO $ race ( pause defBlockInfoTimeout ) - ( atomically $ do - s <- readTQueue q - void $ STM.flushTQueue q - pure s - ) - -- NOTE: this is an adapter for a ResponseM monad -- because response is working in ResponseM monad (ha!) diff --git a/hbs2-peer/app/Bootstrap.hs b/hbs2-peer/app/Bootstrap.hs index 88d1b020..5122f115 100644 --- a/hbs2-peer/app/Bootstrap.hs +++ b/hbs2-peer/app/Bootstrap.hs @@ -5,7 +5,7 @@ module Bootstrap where import HBS2.Data.Types.Peer import HBS2.Prelude import HBS2.Net.Proto.Types -import HBS2.Net.Proto.Peer +import HBS2.Peer.Proto.Peer import HBS2.Clock import HBS2.Net.Proto.Sessions import HBS2.Peer.Brains diff --git a/hbs2-peer/app/Brains.hs b/hbs2-peer/app/Brains.hs index bc39df4e..d8f17202 100644 --- a/hbs2-peer/app/Brains.hs +++ b/hbs2-peer/app/Brains.hs @@ -10,7 +10,7 @@ module Brains import HBS2.Prelude.Plated import HBS2.Clock -import HBS2.Net.Proto.RefChan(ForRefChans) +import HBS2.Peer.Proto.RefChan(ForRefChans) import HBS2.Data.Types.Refs import HBS2.Net.Proto import HBS2.Hash @@ -19,6 +19,8 @@ import HBS2.Net.IP.Addr import HBS2.Peer.Brains +import HBS2.Misc.PrettyStuff + import PeerLogger import PeerConfig @@ -218,6 +220,9 @@ instance ( Hashable (Peer e) updateOP brains $ do let conn = view brainsDb brains liftIO $ execute conn sql (show $ pretty (AsBase58 r), s, i) + + commitNow brains True + where sql = [qc| insert into statedb.poll (ref,type,interval) @@ -559,6 +564,17 @@ SELECT s.peer liftIO $ query conn sql (Only (show $ pretty child) ) <&> fmap fromOnly +delAllDownloads :: BasicBrains e -> IO () +delAllDownloads brains = do + + let conn = view brainsDb brains + + let sql = [qc| +DELETE FROM statedb.download; + |] + + void $ try @SomeException $ liftIO $ execute_ conn sql + cleanupHashes :: BasicBrains e -> IO () @@ -857,6 +873,12 @@ newBasicBrains cfg = liftIO do <*> newTQueueIO <*> Cache.newCache (Just (toTimeSpec (1200:: Timeout 'Seconds))) + +data PeerDownloadsDelOnStart + +instance Monad m => HasCfgKey PeerDownloadsDelOnStart b m where + key = "downloads-del-on-start" + runBasicBrains :: forall e m . ( e ~ L4Proto , MonadUnliftIO m , ForRefChans e @@ -903,6 +925,14 @@ runBasicBrains cfg brains = do trace "runBasicBrains init" let (PeerConfig syn) = cfg + + let delDowns = runReader (cfgValue @PeerDownloadsDelOnStart) cfg :: FeatureSwitch + + when (delDowns == FeatureOn ) do + debug $ yellow "CLEAN ALL DOWNLOADS" + updateOP brains (delAllDownloads brains) + commitNow brains True + let polls = catMaybes ( [ (tp,n,) <$> fromStringMay @(PubKey 'Sign (Encryption e)) (Text.unpack ref) | ListVal (Key "poll" [SymbolVal tp, LitIntVal n, LitStrVal ref]) <- syn diff --git a/hbs2-peer/app/ByPassWorker.hs b/hbs2-peer/app/ByPassWorker.hs index 2fcff1b1..fb0c4b56 100644 --- a/hbs2-peer/app/ByPassWorker.hs +++ b/hbs2-peer/app/ByPassWorker.hs @@ -5,8 +5,8 @@ import HBS2.Clock import HBS2.Actors.Peer import HBS2.Net.Messaging.Encrypted.ByPass -import HBS2.Net.Proto.Peer -import HBS2.Net.Proto.PeerExchange +import HBS2.Peer.Proto.Peer +import HBS2.Peer.Proto.PeerExchange import HBS2.Net.Proto.Sessions import HBS2.Net.Proto.Types diff --git a/hbs2-peer/app/CLI/RefChan.hs b/hbs2-peer/app/CLI/RefChan.hs index 9015c564..0dea5f5f 100644 --- a/hbs2-peer/app/CLI/RefChan.hs +++ b/hbs2-peer/app/CLI/RefChan.hs @@ -3,21 +3,17 @@ module CLI.RefChan where import HBS2.Prelude.Plated import HBS2.Hash -import HBS2.Clock import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Credentials.Sigil -import HBS2.Net.Proto.Definition() -import HBS2.Net.Proto.RefChan +import HBS2.Peer.Proto.RefChan import HBS2.Net.Proto.Types import HBS2.Data.Types.Refs -import HBS2.Merkle import HBS2.Actors.Peer.Types import HBS2.Data.Types.SignedBox import HBS2.Net.Proto.Service import HBS2.Data.Detect import HBS2.Storage import HBS2.Storage.Operations.ByteString -import HBS2.Data.Types.Refs import HBS2.Net.Messaging.Unix import HBS2.Net.Auth.GroupKeySymm @@ -44,13 +40,9 @@ import Data.Maybe import Lens.Micro.Platform import Options.Applicative import System.Exit -import Data.Time.Clock (getCurrentTime) -import Data.Time.Clock.POSIX (getPOSIXTime) import Control.Monad.Except (runExceptT) -import Data.Word import Codec.Serialise import UnliftIO -import Streaming.Prelude qualified as S pRefChan :: Parser (IO ()) diff --git a/hbs2-peer/app/CheckBlockAnnounce.hs b/hbs2-peer/app/CheckBlockAnnounce.hs index f864bcb5..ffcde038 100644 --- a/hbs2-peer/app/CheckBlockAnnounce.hs +++ b/hbs2-peer/app/CheckBlockAnnounce.hs @@ -6,7 +6,7 @@ import HBS2.Actors.Peer import HBS2.Base58 import HBS2.Data.Types.Peer import HBS2.Hash -import HBS2.Net.Proto.Peer +import HBS2.Peer.Proto.Peer import HBS2.Net.Proto.Sessions import HBS2.Net.Proto.Types @@ -110,5 +110,6 @@ checkBlockAnnounce conf denv nonce pa h = void $ runMaybeT do lift do withDownload denv $ do - processBlock h + -- TODO: use-brains-to-download-direct + addDownload Nothing h diff --git a/hbs2-peer/app/EncryptionKeys.hs b/hbs2-peer/app/EncryptionKeys.hs deleted file mode 100644 index 6be4423a..00000000 --- a/hbs2-peer/app/EncryptionKeys.hs +++ /dev/null @@ -1,82 +0,0 @@ -module EncryptionKeys where - -import HBS2.Actors.Peer -import HBS2.Base58 -import HBS2.Clock -import HBS2.Data.Detect -import HBS2.Data.Types.Refs -import HBS2.Events -import HBS2.Hash -import HBS2.Merkle -import HBS2.Net.Auth.Credentials -import HBS2.Net.PeerLocator -import HBS2.Net.Proto -import HBS2.Net.Proto.EncryptionHandshake -import HBS2.Net.Proto.Peer -import HBS2.Net.Proto.Sessions -import HBS2.Prelude.Plated -import HBS2.Storage -import HBS2.Net.Proto.Definition() - -import PeerConfig -import PeerTypes - -import Codec.Serialise -import Control.Concurrent.Async -import Control.Concurrent.STM -import Control.Monad -import Control.Monad.Reader -import Control.Monad.Trans.Maybe -import Data.ByteString qualified as BS -import Data.ByteString.Lazy qualified as LBS -import Data.Foldable(for_) -import Data.Function(fix) -import Data.Functor -import Data.HashMap.Strict qualified as HashMap -import Data.HashSet (HashSet) -import Data.HashSet qualified as HashSet -import Data.Maybe -import Data.Text qualified as Text - - -encryptionHandshakeWorker :: forall e m s . - ( MonadIO m - , m ~ PeerM e IO - , s ~ Encryption e - , e ~ L4Proto - , HasPeerLocator e m - -- , HasPeer e - -- , HasNonces (EncryptionHandshake e) m - -- , Request e (EncryptionHandshake e) m - , Sessions e (EncryptionHandshake e) m - -- , Sessions e (PeerInfo e) m - -- , Sessions e (KnownPeer e) m - -- , Pretty (Peer e) - -- , HasCredentials s m - ) - => PeerConfig - -> PeerCredentials s - -> EncryptionHandshakeAdapter e m s - -> m () - -encryptionHandshakeWorker pconf creds EncryptionHandshakeAdapter{..} = do - - -- e :: PeerEnv e <- ask - ourpubkey <- pure $ pubKeyFromKeypair @s $ encAsymmetricKeyPair - - pl <- getPeerLocator @e - - forever do - liftIO $ pause @'Seconds 30 - - peers <- knownPeers @e pl - - forM_ peers \peer -> do - -- Только если ещё не знаем ключ ноды - mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $ - find (KnownPeerKey peer) id - mkey <- join <$> mapM encGetEncryptionKey mencKeyID - case mkey of - Just _ -> pure () - Nothing -> sendBeginEncryptionExchange @e creds ourpubkey peer - diff --git a/hbs2-peer/app/Fetch.hs b/hbs2-peer/app/Fetch.hs index d472c258..2096ebd9 100644 --- a/hbs2-peer/app/Fetch.hs +++ b/hbs2-peer/app/Fetch.hs @@ -23,7 +23,7 @@ fetchHash penv denv href = do sto <- getStorage missed <- findMissedBlocks sto href for_ missed $ \miss -> do - withDownload denv (processBlock (fromHashRef miss)) + withDownload denv (addDownload Nothing (fromHashRef miss)) where h = fromHashRef href diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index 85a03c4f..30e73442 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/hbs2-peer/app/HttpWorker.hs @@ -2,13 +2,11 @@ module HttpWorker where import HBS2.Prelude -import HBS2.Clock import HBS2.Actors.Peer import HBS2.Storage import HBS2.Data.Types.Refs import HBS2.Merkle (AnnMetaData) -import HBS2.Net.Proto.Types -import HBS2.Net.Proto.RefLog +import HBS2.Peer.Proto import HBS2.Events import PeerTypes diff --git a/hbs2-peer/app/PeerConfig.hs b/hbs2-peer/app/PeerConfig.hs index 464fea18..be90ff3a 100644 --- a/hbs2-peer/app/PeerConfig.hs +++ b/hbs2-peer/app/PeerConfig.hs @@ -10,9 +10,7 @@ module PeerConfig import HBS2.Prelude.Plated import HBS2.Base58 -import HBS2.Net.Proto.Types import HBS2.Net.Auth.Credentials -import HBS2.Net.Proto.Definition() import Data.Config.Suckless.Syntax import Data.Config.Suckless.Parse diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index 9549fd03..952d8ebf 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/hbs2-peer/app/PeerInfo.hs @@ -8,9 +8,8 @@ import HBS2.Clock import HBS2.Data.Types import HBS2.Events import HBS2.Net.PeerLocator -import HBS2.Net.Proto.Event.PeerExpired -import HBS2.Net.Proto.Peer -import HBS2.Net.Proto.PeerExchange +import HBS2.Peer.Proto.Peer +import HBS2.Peer.Proto.PeerExchange import HBS2.Net.Proto.Sessions import HBS2.Net.Proto.Types import HBS2.Prelude.Plated @@ -116,7 +115,7 @@ pexLoop brains tcpEnv = forever do >>= either (const $ warn "tcpSessionWait issue" >> pause @'Seconds 1 >> pure mempty) pure ssids <- forM conns $ \(p,coo) -> do - debug $ "ACTUAL TCP SESSIONS" <+> pretty p <+> pretty coo + trace $ "ACTUAL TCP SESSIONS" <+> pretty p <+> pretty coo pa <- toPeerAddr p pure (pa, coo) @@ -124,6 +123,14 @@ pexLoop brains tcpEnv = forever do pure () + + -- pee <- knownPeers @e pl + -- npi <- newPeerInfo + + -- for_ pee $ \p -> do + -- pinfo <- fetch True npi (PeerInfoKey p) id + -- updatePeerInfo False p pinfo + void $ ContT $ withAsync $ forever do pips <- knownPeers @e pl diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index d5bea625..5d023f9c 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -9,7 +9,6 @@ import HBS2.Prelude.Plated import HBS2.Actors.Peer import HBS2.Base58 -import HBS2.Clock import HBS2.Defaults import HBS2.Events import HBS2.Hash @@ -23,16 +22,9 @@ import HBS2.Net.Messaging.TCP import HBS2.Net.Messaging.Unix import HBS2.Net.Messaging.Encrypted.ByPass import HBS2.Net.PeerLocator -import HBS2.Net.Proto.Definition -import HBS2.Net.Proto.Peer -import HBS2.Net.Proto.PeerAnnounce -import HBS2.Net.Proto.PeerExchange -import HBS2.Net.Proto.PeerMeta -import HBS2.Net.Proto.RefLog -import HBS2.Net.Proto.RefChan -import HBS2.Net.Proto.Sessions -import HBS2.Net.Proto.Service -import HBS2.Net.Proto.Notify (NotifyProto) +import HBS2.Peer.Proto +import HBS2.Peer.Proto.RefChan qualified as R +import HBS2.Net.Proto.Notify import HBS2.OrDie import HBS2.Storage.Simple import HBS2.Storage.Operations.Missed @@ -128,7 +120,7 @@ instance Exception GoAgainException -- TODO: write-workers-to-config defStorageThreads :: Integral a => a -defStorageThreads = 4 +defStorageThreads = 1 defLocalMulticast :: String defLocalMulticast = "239.192.152.145:10153" @@ -247,9 +239,8 @@ runCLI = do <> command "poll" (info pPoll (progDesc "polling management")) <> command "log" (info pLog (progDesc "set logging level")) <> command "bypass" (info pByPass (progDesc "bypass")) + <> command "gc" (info pRunGC (progDesc "run RAM garbage collector")) <> command "version" (info pVersion (progDesc "show program version")) - -- FIXME: bring-back-dialogue-over-separate-socket - -- <> command "dial" (info pDialog (progDesc "dialog commands")) ) common = do @@ -533,6 +524,13 @@ runCLI = do d <- toMPlus =<< callService @RpcByPassInfo caller () liftIO $ print $ pretty d + pRunGC = do + rpc <- pRpcCommon + pure do + withMyRPC @PeerAPI rpc $ \caller -> do + void $ runMaybeT do + void $ callService @RpcPerformGC caller () + refP :: ReadM (PubKey 'Sign HBS2Basic) refP = maybeReader fromStringMay @@ -822,7 +820,7 @@ runPeer opts = Exception.handle (\e -> myException e trace "refChanNotifyRely!" refChanNotifyRelyFn @e rce r u case u of - Notify rr s -> do + R.Notify rr s -> do emitNotify refChanNotifySource (RefChanNotifyKey r, RefChanNotifyData rr s) _ -> pure () } @@ -853,7 +851,7 @@ runPeer opts = Exception.handle (\e -> myException e withPeerM penv $ withDownload denv (addDownload mzero h) else do -- FIXME: separate-process-to-mark-logs-processed - withPeerM penv $ withDownload denv (processBlock h) + withPeerM penv $ withDownload denv (addDownload Nothing h) let doFetchRef puk = do withPeerM penv $ do @@ -946,10 +944,6 @@ runPeer opts = Exception.handle (\e -> myException e case Map.lookup thatNonce pdkv of - -- TODO: prefer-local-peer-with-same-nonce-over-remote-peer - -- remove remote peer - -- add local peer - -- FIXME: move-protocol-comparison-to-peer-nonce -- @@ -1029,8 +1023,6 @@ runPeer opts = Exception.handle (\e -> myException e peerThread "fillPeerMeta" (fillPeerMeta tcp tcpProbeWait) - peerThread "postponedLoop" (postponedLoop denv) - peerThread "reflogWorker" (reflogWorker @e conf (SomeBrains brains) rwa) peerThread "refChanWorker" (refChanWorker @e rce (SomeBrains brains)) @@ -1091,7 +1083,7 @@ runPeer opts = Exception.handle (\e -> myException e void $ liftIO $ withPeerM penv $ do me <- ownPeer @e runMaybeT do - lift $ runResponseM me $ refChanNotifyProto @e True refChanAdapter (Notify @e puk box) + lift $ runResponseM me $ refChanNotifyProto @e True refChanAdapter (R.Notify @e puk box) menv <- newPeerEnv pl (AnyStorage s) (Fabriq mcast) (getOwnPeer mcast) diff --git a/hbs2-peer/app/PeerMain/Dialog/Server.hs b/hbs2-peer/app/PeerMain/Dialog/Server.hs deleted file mode 100644 index af3c786a..00000000 --- a/hbs2-peer/app/PeerMain/Dialog/Server.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# Language AllowAmbiguousTypes #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE UndecidableInstances #-} -module PeerMain.Dialog.Server where - -import Codec.Serialise -import Control.Monad.Except -import Control.Monad.IO.Class () -import Control.Monad.Reader -import Lens.Micro.Platform - -import HBS2.Actors.Peer -import HBS2.Data.Types.Refs -import HBS2.Base58 -import HBS2.Hash -import HBS2.Net.Dialog.Core -import HBS2.Net.Proto.RefLog -import HBS2.Net.Proto.Types -import HBS2.Prelude -import HBS2.Storage.Simple - -import PeerMain.Dialog.Spec - ---- - -data DialEnv = DialEnv - -newtype DialT m a = DialT { unDialT :: PeerM L4Proto (ReaderT DialEnv (DialHandlerT m)) a } - deriving - ( Generic, Functor, Applicative, Monad - , MonadIO - , MonadReader (PeerEnv L4Proto) - -- , MonadTrans - -- , MonadError ResponseStatus - -- , MonadThrow, MonadCatch, MonadMask - ) - --- instance Monad m => MonadReader DialEnv (DialT m) where --- ask = DialT . lift $ ask --- local f ma = undefined - -instance Monad m => HasStorage (DialT m) where - getStorage = asks (view envStorage) - -instance MonadTrans DialT where - lift = DialT . lift . lift . lift - -instance Monad m => - MonadError ResponseStatus (DialT m) where - -- {-# MINIMAL throwError, catchError #-} - -- throwError :: e -> m a - throwError = DialT . lift . throwError - -- catchError :: m a -> (e -> m a) -> m a - catchError = undefined - ---- - -runDialTtoDialHandlerT :: MonadIO m => DialEnv -> PeerEnv L4Proto -> DialT m a -> DialHandlerT m a -runDialTtoDialHandlerT denv penv = - flip runReaderT denv . withPeerM penv . unDialT - ---- - -dialogRoutes' :: forall m . - ( MonadIO m - , Serialise (PubKey 'Sign (Encryption L4Proto)) - , FromStringMaybe (PubKey 'Sign (Encryption L4Proto)) - , Hashable (PubKey 'Sign (Encryption L4Proto)) - , Pretty (AsBase58 (PubKey 'Sign (Encryption L4Proto))) - ) - => PeerEnv L4Proto - -> DialogRequestRouter m -dialogRoutes' penv = dialogRequestRoutes do - - hand ["ping"] \req -> (, req) <$> Right \reply -> do - reply (Frames [serialiseS (ResponseHeader (ResponseStatus Success200 "") 0), "pong"]) - - hand ["spec"] \req -> (, req) <$> Right \reply -> do - undefined - -- let xs = Map.keys (unDialogRequestRouter (dialogRoutes @m penv)) - - -- forM_ (zip (zip [1..] xs) ((True <$ drop 1 xs) <> [False])) \((j,x),isMore) -> do - -- reply (Frames [serialiseS (ResponseHeader (ResponseStatus (bool Success200 SuccessMore isMore) "") j) - -- , BS.intercalate "/" x - -- ]) - - - hand ["debug", "no-response-header"] \req -> (, req) <$> Right \reply -> do - reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "one"]) - reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 1), "two"]) - reply (Frames []) - - hand ["debug", "wrong-header"] \req -> (, req) <$> Right \reply -> do - reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "correct-header"]) - reply (Frames ["wrong-header"]) - - hand ["debug", "timeout"] \req -> (, req) <$> Right \reply -> do - reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "false more"]) - - - handconv ["reflog", "get"] "ReflogGetReq" \(ReflogGetReq ref) -> do - - sto <- withPeerM penv getStorage - - hash <- maybe (throwError (ResponseStatus NotFound404 "unknown reference")) pure - =<< liftIO do - getRef sto (RefLogKey @(Encryption L4Proto) ref) - - pure (ReflogGetResp hash) - -newtype ReflogGetReq = ReflogGetReq (PubKey 'Sign (Encryption L4Proto)) - deriving (Generic) - -instance Serialise (PubKey 'Sign (Encryption L4Proto)) - => Serialise ReflogGetReq - -newtype ReflogGetResp = ReflogGetResp (Hash HbSync) - deriving (Generic) - -instance Serialise (PubKey 'Sign (Encryption L4Proto)) - => Serialise ReflogGetResp - ---- - -drpcFullDApp :: forall m . - ( MonadIO m - , Unconstraints - ) - => DialEnv -> PeerEnv L4Proto -> DApp m -drpcFullDApp denv penv = - mkDApp - (Proxy @(NamedSpec DialogRPCSpec)) - EmptyCtx - (runDialTtoDialHandlerT denv penv) - -- (drpcFullH :: DialogRPCSpec (ModeServerT (DialT m))) - drpcFullH - -type ConstraintsH m = - ( MonadIO m - , MonadError ResponseStatus m - , HasStorage m - , Unconstraints - ) - -type Unconstraints = - ( Serialise (PubKey 'Sign (Encryption L4Proto)) - , Hashable (PubKey 'Sign (Encryption L4Proto)) - , Show (PubKey 'Sign (Encryption L4Proto)) - , Pretty (AsBase58 (PubKey 'Sign (Encryption L4Proto))) - , Typeable (PubKey 'Sign (Encryption L4Proto)) - , FromStringMaybe (PubKey 'Sign (Encryption L4Proto)) - ) - -drpcFullH :: ( ConstraintsH m ) - => DialogRPCSpec (ModeServerT m) -drpcFullH = DialogRPCSpec - { drpcPing = pure "pong" - , drpcSpec = pure "tbd" - , drpcReflog = reflogH - } - -reflogH :: ( ConstraintsH m ) - => RPCReflogSpec (ModeServerT m) -reflogH = RPCReflogSpec {..} - where - - reflogGet ref = do - - sto <- getStorage - - hash <- maybe (throwError (ResponseStatus NotFound404 "unknown reference")) pure - =<< liftIO do - getRef sto (RefLogKey @(Encryption L4Proto) ref) - - pure hash - - reflogFetch pk = do - liftIO $ print pk - pure () - diff --git a/hbs2-peer/app/PeerMain/Dialog/Spec.hs b/hbs2-peer/app/PeerMain/Dialog/Spec.hs deleted file mode 100644 index d9dbb898..00000000 --- a/hbs2-peer/app/PeerMain/Dialog/Spec.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE StrictData #-} - -module PeerMain.Dialog.Spec where - --- import Codec.Serialise --- import Streaming -import Data.Text (Text) -import GHC.Generics (Generic) - -import HBS2.Hash -import HBS2.Net.Dialog.Core -import HBS2.Net.Proto.Types - - -data DialogRPCSpec r = DialogRPCSpec - { drpcPing :: r &- "ping" &/ SingleRespCBOR Text - , drpcSpec :: r &- "spec" &/ SingleRespCBOR Text - , drpcReflog :: r &- "reflog" &// RPCReflogSpec - } - deriving (Generic) - -data RPCReflogSpec r = RPCReflogSpec - { reflogGet :: r &- "get" - &/ ReqCBOR (PubKey 'Sign (Encryption L4Proto)) - &/ SingleRespCBOR (Hash HbSync) - - , reflogFetch :: r &- "fetch" - &/ ReqCBOR (PubKey 'Sign (Encryption L4Proto)) - &/ SingleAck - - } - deriving (Generic) - diff --git a/hbs2-peer/app/PeerMeta.hs b/hbs2-peer/app/PeerMeta.hs index 00944219..87bff248 100644 --- a/hbs2-peer/app/PeerMeta.hs +++ b/hbs2-peer/app/PeerMeta.hs @@ -9,8 +9,8 @@ import HBS2.Net.IP.Addr import HBS2.Net.Messaging.TCP import HBS2.Net.PeerLocator import HBS2.Net.Proto -import HBS2.Net.Proto.Peer -import HBS2.Net.Proto.PeerMeta +import HBS2.Peer.Proto.Peer +import HBS2.Peer.Proto.PeerMeta import HBS2.Net.Proto.Sessions import HBS2.Prelude.Plated diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index d604c1f9..c9a97900 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/hbs2-peer/app/PeerTypes.hs @@ -22,15 +22,14 @@ import HBS2.Hash import HBS2.Merkle (AnnMetaData) import HBS2.Net.IP.Addr import HBS2.Net.Proto -import HBS2.Net.Proto.Peer -import HBS2.Net.Proto.BlockInfo -import HBS2.Net.Proto.Definition +import HBS2.Peer.Proto.Peer +import HBS2.Peer.Proto.BlockInfo import HBS2.Net.Proto.Sessions import HBS2.Prelude.Plated import HBS2.Storage import HBS2.Storage.Operations.Missed import HBS2.Net.PeerLocator -import HBS2.Net.Proto.PeerMeta +import HBS2.Peer.Proto import Brains import PeerConfig @@ -44,6 +43,7 @@ import Data.Cache (Cache) import Data.Cache qualified as Cache import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap +import Data.HashSet (HashSet) import Data.List qualified as L import Data.Maybe import Lens.Micro.Platform @@ -247,12 +247,10 @@ data DownloadEnv e = DownloadEnv { _blockInQ :: TVar (HashMap (Hash HbSync) BlockState) , _blockInDirty :: TVar Bool + , _blockCheckQ :: TQueue (Hash HbSync) + , _blockSizeRecvQ :: TQueue (Peer e, Hash HbSync, Maybe Integer) -- 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) () + -- , _blockProposed :: Cache (Hash HbSync, Peer e) () , _downloadMon :: DownloadMonEnv , _downloadBrains :: SomeBrains e } @@ -264,11 +262,9 @@ newDownloadEnv :: (MonadIO m, MyPeer e, HasBrains e brains) => brains -> m (Down newDownloadEnv brains = liftIO do DownloadEnv <$> newTVarIO mempty <*> newTVarIO False - <*> newTVarIO mempty - <*> newTVarIO mempty - <*> Cache.newCache (Just defBlockBanTime) <*> newTQueueIO - <*> Cache.newCache (Just (toTimeSpec (2 :: Timeout 'Seconds))) + <*> newTQueueIO + -- <*> Cache.newCache (Just (toTimeSpec (2 :: Timeout 'Seconds))) <*> downloadMonNew <*> pure (SomeBrains brains) @@ -313,12 +309,13 @@ addDownload :: forall e m . ( DownloadConstr e m addDownload mbh h = do tinq <- asks (view blockInQ) + checkQ <- asks (view blockCheckQ) dirty <- asks (view blockInDirty) brains <- asks (view downloadBrains) here <- isBlockHereCached h if here then do - removeFromWip h + deleteBlockFromQ h else do newBlock <- BlockState <$> liftIO getTimeCoarse @@ -326,75 +323,17 @@ addDownload mbh h = do <*> liftIO (newTVarIO BlkNew) claimBlockCameFrom @e brains mbh h + -- Cache.insert liftIO $ atomically $ do modifyTVar tinq $ HashMap.insert h newBlock + writeTQueue checkQ h writeTVar dirty True -postponedNum :: forall e m . (MyPeer e, MonadIO m) => BlockDownloadM e m Int -postponedNum = do - po <- asks (view blockPostponed) - liftIO $ readTVarIO po <&> HashMap.size - -isPostponed :: forall e m . (MyPeer e, MonadIO m) => Hash HbSync -> BlockDownloadM e m Bool -isPostponed h = do - po <- asks (view blockPostponed) >>= liftIO . readTVarIO - pure $ HashMap.member h po - - -delayLittleBit :: forall e m . (MyPeer e, MonadIO m) => Hash HbSync -> BlockDownloadM e m () -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 - - brains <- asks (view downloadBrains) - po <- asks (view blockPostponed) - tto <- asks (view blockPostponedTo) - tinq <- asks (view blockInQ) - - - liftIO $ do - postponed <- atomically $ do - already <- readTVar po <&> HashMap.member h - unless already do - modifyTVar tinq $ HashMap.delete h - modifyTVar po (HashMap.insert h ()) - pure $ not already - - when postponed do - Cache.insert tto h () - onBlockPostponed @e brains h - -unpostponeBlock :: forall e m . (DownloadConstr e m) => Hash HbSync -> BlockDownloadM e m () -unpostponeBlock h = do - - po <- asks (view blockPostponed) - tto <- asks (view blockPostponedTo) - - liftIO $ do - atomically $ modifyTVar po (HashMap.delete h) - Cache.delete tto h - - trace $ "unpostponeBlock" <+> pretty h - addDownload @e mzero h - -removeFromWip :: (MyPeer e, MonadIO m) => Hash HbSync -> BlockDownloadM e m () -removeFromWip h = do - tinq <- asks (view blockInQ) - liftIO $ atomically $ do - modifyTVar' tinq (HashMap.delete h) failedDownload :: forall e m . ( MyPeer e , MonadIO m diff --git a/hbs2-peer/app/RPC2/Downloads.hs b/hbs2-peer/app/RPC2/Downloads.hs index 8a7c73d2..5169ff36 100644 --- a/hbs2-peer/app/RPC2/Downloads.hs +++ b/hbs2-peer/app/RPC2/Downloads.hs @@ -2,10 +2,9 @@ {-# Language UndecidableInstances #-} module RPC2.Downloads where -import HBS2.Prelude.Plated +import HBS2.Peer.Prelude import HBS2.Net.Proto.Service import HBS2.Peer.Brains -import HBS2.Net.Proto.Definition() import HBS2.Peer.RPC.API.Peer import HBS2.Peer.RPC.Internal.Types diff --git a/hbs2-peer/app/RPC2/Peer.hs b/hbs2-peer/app/RPC2/Peer.hs index 379df0eb..496d6a6a 100644 --- a/hbs2-peer/app/RPC2/Peer.hs +++ b/hbs2-peer/app/RPC2/Peer.hs @@ -11,6 +11,7 @@ import RPC2.Peers() import RPC2.PexInfo() import RPC2.Ping() import RPC2.Poke() +import RPC2.PerformGC() import RPC2.RefLog() import RPC2.RefChan() import RPC2.Die() diff --git a/hbs2-peer/app/RPC2/Peers.hs b/hbs2-peer/app/RPC2/Peers.hs index e4202653..7429f529 100644 --- a/hbs2-peer/app/RPC2/Peers.hs +++ b/hbs2-peer/app/RPC2/Peers.hs @@ -6,12 +6,10 @@ import HBS2.Actors.Peer import HBS2.Data.Types.Peer import HBS2.Net.Proto.Types import HBS2.Net.Proto.Service -import HBS2.Net.Proto.Peer +import HBS2.Peer.Proto.Peer import HBS2.Net.Proto.Sessions import HBS2.Prelude.Plated -import HBS2.Net.Proto.Definition() - import PeerTypes import HBS2.Peer.RPC.Internal.Types diff --git a/hbs2-peer/app/RPC2/PerformGC.hs b/hbs2-peer/app/RPC2/PerformGC.hs new file mode 100644 index 00000000..1d8a4d08 --- /dev/null +++ b/hbs2-peer/app/RPC2/PerformGC.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} +module RPC2.PerformGC where + +import HBS2.Prelude.Plated +import HBS2.Net.Proto.Service + +import HBS2.Peer.RPC.Internal.Types +import HBS2.Peer.RPC.API.Peer + +import PeerLogger + +import System.Mem + +instance ( MonadIO m + , HasRpcContext PeerAPI RPC2Context m) + + => HandleMethod m RpcPerformGC where + + handleMethod _ = do + debug $ "rpc.performGC" + liftIO performGC + pure () + + diff --git a/hbs2-peer/app/RPC2/PexInfo.hs b/hbs2-peer/app/RPC2/PexInfo.hs index bace3711..1dcdbeeb 100644 --- a/hbs2-peer/app/RPC2/PexInfo.hs +++ b/hbs2-peer/app/RPC2/PexInfo.hs @@ -2,12 +2,12 @@ {-# Language UndecidableInstances #-} module RPC2.PexInfo where +import HBS2.Peer.Prelude import HBS2.Actors.Peer import HBS2.Net.Proto.Service -import HBS2.Prelude.Plated -import HBS2.Net.Proto.Definition() -import HBS2.Net.Proto.PeerExchange +import HBS2.Peer.Proto +-- import HBS2.Peer.Proto.PeerExchange import HBS2.Peer.RPC.Internal.Types import HBS2.Peer.RPC.API.Peer diff --git a/hbs2-peer/app/RPC2/Poll.hs b/hbs2-peer/app/RPC2/Poll.hs index 461546b2..ec895721 100644 --- a/hbs2-peer/app/RPC2/Poll.hs +++ b/hbs2-peer/app/RPC2/Poll.hs @@ -2,10 +2,9 @@ {-# Language UndecidableInstances #-} module RPC2.Poll where -import HBS2.Prelude.Plated +import HBS2.Peer.Prelude import HBS2.Net.Proto.Service import HBS2.Peer.Brains -import HBS2.Net.Proto.Definition() import HBS2.Peer.RPC.API.Peer import HBS2.Peer.RPC.Internal.Types diff --git a/hbs2-peer/app/RPC2/RefChan.hs b/hbs2-peer/app/RPC2/RefChan.hs index 4276ad1b..43a78df7 100644 --- a/hbs2-peer/app/RPC2/RefChan.hs +++ b/hbs2-peer/app/RPC2/RefChan.hs @@ -5,14 +5,13 @@ module RPC2.RefChan , module HBS2.Peer.RPC.Internal.Types ) where -import HBS2.Prelude.Plated +import HBS2.Peer.Prelude import HBS2.Actors.Peer import HBS2.Base58 import HBS2.Data.Types.Refs (HashRef(..)) -import HBS2.Net.Proto.Definition() import HBS2.Net.Proto.Service -import HBS2.Net.Proto.RefChan +import HBS2.Peer.Proto.RefChan import HBS2.Net.Messaging.Unix import HBS2.Storage @@ -21,7 +20,6 @@ import HBS2.Peer.RPC.Internal.Types import PeerTypes -import Data.Functor import Control.Monad.Reader type RefChanContext m = (MonadIO m, HasRpcContext RefChanAPI RPC2Context m) diff --git a/hbs2-peer/app/RPC2/RefLog.hs b/hbs2-peer/app/RPC2/RefLog.hs index 7a872334..5c318ac9 100644 --- a/hbs2-peer/app/RPC2/RefLog.hs +++ b/hbs2-peer/app/RPC2/RefLog.hs @@ -5,16 +5,14 @@ module RPC2.RefLog , module HBS2.Peer.RPC.Internal.Types ) where -import HBS2.Prelude.Plated +import HBS2.Peer.Prelude import HBS2.Actors.Peer import HBS2.Hash import HBS2.Base58 import HBS2.Data.Types.Refs (HashRef(..)) import HBS2.Events -import HBS2.Net.Proto.Definition() -import HBS2.Net.Proto.RefLog -import HBS2.Net.Proto.Service +import HBS2.Peer.Proto import HBS2.Storage import HBS2.Net.Messaging.Unix @@ -24,7 +22,6 @@ import RefLog (doRefLogBroadCast) import HBS2.Peer.RPC.Internal.Types import HBS2.Peer.RPC.API.RefLog -import Data.Functor import Lens.Micro.Platform import Control.Monad.Reader diff --git a/hbs2-peer/app/RefChan.hs b/hbs2-peer/app/RefChan.hs index fb28ac20..eb19d8e9 100644 --- a/hbs2-peer/app/RefChan.hs +++ b/hbs2-peer/app/RefChan.hs @@ -19,7 +19,6 @@ import HBS2.Prelude.Plated import HBS2.Actors.Peer import HBS2.Base58 import HBS2.Hash -import HBS2.Clock import HBS2.Data.Detect import HBS2.Defaults import HBS2.Data.Types.Refs @@ -28,13 +27,10 @@ import HBS2.Events import HBS2.Merkle import HBS2.Net.Auth.Credentials import HBS2.Net.Messaging.Unix -import HBS2.Net.Proto -import HBS2.Net.Proto.Definition() -import HBS2.Net.Proto.Peer -import HBS2.Net.Proto.RefChan +import HBS2.Peer.Proto.Peer +import HBS2.Peer.Proto.RefChan import HBS2.Net.Proto.Sessions import HBS2.Storage -import HBS2.Storage.Operations.Missed import PeerTypes hiding (downloads) import PeerConfig @@ -204,7 +200,7 @@ refChanAddDownload env chan r onComlete = do penv <- ask t <- getTimeCoarse withPeerM penv $ withDownload (_refChanWorkerEnvDEnv env) - $ processBlock @e (fromHashRef r) + $ addDownload @e Nothing (fromHashRef r) atomically $ modifyTVar (view refChanWorkerEnvDownload env) (HashMap.insert r (chan,(t, onComlete))) diff --git a/hbs2-peer/app/RefChanNotifyLog.hs b/hbs2-peer/app/RefChanNotifyLog.hs index 090a5c06..eb67dce0 100644 --- a/hbs2-peer/app/RefChanNotifyLog.hs +++ b/hbs2-peer/app/RefChanNotifyLog.hs @@ -17,9 +17,8 @@ import HBS2.Storage import HBS2.Data.Types.Refs import HBS2.Net.Auth.Credentials import HBS2.Net.Messaging.Unix -import HBS2.Net.Proto.Definition() -import HBS2.Net.Proto.Peer -import HBS2.Net.Proto.RefChan +import HBS2.Peer.Proto.Peer +import HBS2.Peer.Proto.RefChan import HBS2.Net.Proto.Sessions import HBS2.Peer.RefChanNotifyLog diff --git a/hbs2-peer/app/RefLog.hs b/hbs2-peer/app/RefLog.hs index da83c315..2205e7e4 100644 --- a/hbs2-peer/app/RefLog.hs +++ b/hbs2-peer/app/RefLog.hs @@ -14,9 +14,7 @@ import HBS2.Base58 import HBS2.Storage import HBS2.Storage.Operations.Missed import HBS2.Hash -import HBS2.Net.Proto.Peer -import HBS2.Net.Proto.RefLog -import HBS2.Net.Proto.Sessions +import HBS2.Peer.Proto import HBS2.Net.Auth.Credentials import HBS2.Merkle diff --git a/hbs2-peer/app/SendBlockAnnounce.hs b/hbs2-peer/app/SendBlockAnnounce.hs index 977bbd55..a14167a7 100644 --- a/hbs2-peer/app/SendBlockAnnounce.hs +++ b/hbs2-peer/app/SendBlockAnnounce.hs @@ -5,7 +5,7 @@ import HBS2.Hash import HBS2.Actors.Peer import HBS2.Storage(Storage(..)) import HBS2.Net.Proto.Types -import HBS2.Net.Proto.BlockAnnounce +import HBS2.Peer.Proto.BlockAnnounce import PeerTypes diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 3e0adde2..45259898 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -137,9 +137,27 @@ library default-language: Haskell2010 exposed-modules: + HBS2.Peer.Prelude HBS2.Peer.Brains HBS2.Peer.Notify HBS2.Peer.RefChanNotifyLog + + HBS2.Peer.Proto + HBS2.Peer.Proto.Peer + HBS2.Peer.Proto.PeerAnnounce + HBS2.Peer.Proto.PeerMeta + HBS2.Peer.Proto.BlockAnnounce + HBS2.Peer.Proto.BlockChunks + HBS2.Peer.Proto.BlockInfo + HBS2.Peer.Proto.PeerExchange + HBS2.Peer.Proto.RefLog + HBS2.Peer.Proto.RefChan + HBS2.Peer.Proto.RefChan.Types + HBS2.Peer.Proto.RefChan.RefChanHead + HBS2.Peer.Proto.RefChan.RefChanNotify + HBS2.Peer.Proto.RefChan.RefChanUpdate + HBS2.Peer.Proto.AnyRef + HBS2.Peer.RPC.Class HBS2.Peer.RPC.API.Peer HBS2.Peer.RPC.API.RefLog @@ -167,8 +185,6 @@ executable hbs2-peer , DownloadMon , Bootstrap , PeerInfo - , PeerMain.Dialog.Server - , PeerMain.Dialog.Spec , PeerMeta , SendBlockAnnounce , CheckBlockAnnounce @@ -178,6 +194,7 @@ executable hbs2-peer , RPC2 , RPC2.Peer , RPC2.Poke + , RPC2.PerformGC , RPC2.Announce , RPC2.Fetch , RPC2.Die diff --git a/hbs2-peer/lib/HBS2/Peer/Notify.hs b/hbs2-peer/lib/HBS2/Peer/Notify.hs index eb80e84a..e2bb6292 100644 --- a/hbs2-peer/lib/HBS2/Peer/Notify.hs +++ b/hbs2-peer/lib/HBS2/Peer/Notify.hs @@ -18,14 +18,12 @@ module HBS2.Peer.Notify import HBS2.Prelude import HBS2.Base58 import HBS2.Data.Types.Refs -import HBS2.Actors.Peer.Types import HBS2.Net.Proto.Types import HBS2.Net.Proto.Notify -import HBS2.Net.Proto.RefChan -import HBS2.Net.Proto.RefLog +import HBS2.Peer.Proto.RefChan +import HBS2.Peer.Proto.RefLog import HBS2.Net.Messaging.Unix (UNIX) import HBS2.Data.Types.SignedBox -import HBS2.Net.Proto.Definition() import Codec.Serialise import Data.ByteString.Lazy (ByteString) diff --git a/hbs2-peer/lib/HBS2/Peer/Prelude.hs b/hbs2-peer/lib/HBS2/Peer/Prelude.hs new file mode 100644 index 00000000..3b93ee45 --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Prelude.hs @@ -0,0 +1,15 @@ +module HBS2.Peer.Prelude + ( module HBS2.Prelude.Plated + , module HBS2.Net.Auth.Credentials + , defCookieTimeoutSec, defCookieTimeout + ) where + +import HBS2.Prelude.Plated +import HBS2.Net.Auth.Credentials + +defCookieTimeoutSec :: Timeout 'Seconds +defCookieTimeoutSec = 7200 + +defCookieTimeout :: TimeSpec +defCookieTimeout = toTimeSpec defCookieTimeoutSec + diff --git a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs b/hbs2-peer/lib/HBS2/Peer/Proto.hs similarity index 63% rename from hbs2-core/lib/HBS2/Net/Proto/Definition.hs rename to hbs2-peer/lib/HBS2/Peer/Proto.hs index edd8881f..43f971d8 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto.hs @@ -1,72 +1,43 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module HBS2.Net.Proto.Definition - ( module HBS2.Net.Proto.BlockAnnounce - , module HBS2.Net.Proto.BlockChunks - , module HBS2.Net.Proto.BlockInfo - ) - where +module HBS2.Peer.Proto + ( module HBS2.Peer.Proto.PeerMeta + , module HBS2.Peer.Proto.BlockAnnounce + , module HBS2.Peer.Proto.BlockChunks + , module HBS2.Peer.Proto.BlockInfo + , module HBS2.Peer.Proto.Peer + , module HBS2.Peer.Proto.PeerAnnounce + , module HBS2.Peer.Proto.PeerExchange + , module HBS2.Peer.Proto.RefLog + , module HBS2.Peer.Proto.RefChan + , module HBS2.Peer.Proto.AnyRef + , module HBS2.Net.Proto.Types + , module HBS2.Net.Proto.Sessions + , module HBS2.Net.Proto.Service + ) where --- FIXME: move-module-to-hbs2-peer +import HBS2.Peer.Prelude +import HBS2.Net.Proto.Types +import HBS2.Peer.Proto.PeerMeta +import HBS2.Peer.Proto.BlockAnnounce +import HBS2.Peer.Proto.BlockChunks +import HBS2.Peer.Proto.BlockInfo +import HBS2.Peer.Proto.Peer +import HBS2.Peer.Proto.PeerAnnounce +import HBS2.Peer.Proto.PeerExchange +import HBS2.Peer.Proto.RefLog +import HBS2.Peer.Proto.RefChan hiding (Notify) +import HBS2.Peer.Proto.AnyRef -import HBS2.Clock -import HBS2.Defaults -import HBS2.Hash import HBS2.Actors.Peer.Types -import HBS2.Net.Auth.Credentials -import HBS2.Net.Proto -import HBS2.Net.Proto.BlockAnnounce -import HBS2.Net.Proto.BlockChunks -import HBS2.Net.Proto.BlockInfo -import HBS2.Net.Proto.Dialog -import HBS2.Net.Proto.EncryptionHandshake -import HBS2.Net.Proto.Peer -import HBS2.Net.Proto.PeerAnnounce -import HBS2.Net.Proto.PeerExchange -import HBS2.Net.Proto.PeerMeta -import HBS2.Net.Proto.RefLog -import HBS2.Net.Proto.RefChan -import HBS2.Net.Proto.Service import HBS2.Net.Messaging.Unix (UNIX) -import HBS2.Prelude.Plated +import HBS2.Net.Proto.Sessions +import HBS2.Net.Proto.Service -import Control.Monad -import Data.Functor import Data.ByteString.Lazy (ByteString) import Data.ByteString qualified as BS -import Data.ByteString.Lazy qualified as BSL -import Codec.Serialise (deserialiseOrFail,serialise) - +import Codec.Serialise import Crypto.Saltine.Core.Box qualified as Crypto import Crypto.Saltine.Class qualified as Crypto -import Crypto.Saltine.Core.Sign qualified as Sign -import Crypto.Saltine.Core.Box qualified as Encrypt - - - --- FIXME: move-to-types-crypto-ASAP -type instance Encryption L4Proto = HBS2Basic - -type instance Encryption UNIX = HBS2Basic - -type instance PubKey 'Sign HBS2Basic = Sign.PublicKey -type instance PrivKey 'Sign HBS2Basic = Sign.SecretKey -type instance PubKey 'Encrypt HBS2Basic = Encrypt.PublicKey -type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey - -type instance KeyActionOf Sign.PublicKey = 'Sign -type instance KeyActionOf Encrypt.PublicKey = 'Encrypt - --- FIXME: proper-serialise-for-keys --- Возможно, нужно написать ручные инстансы Serialise --- использовать encode/decode для каждого инстанса ниже $(c:end + 4) --- и это будет более правильная сериализация. --- но возможно, будет работать и так, ведь ключи --- это же всего лишь байтстроки внутри. - -deserialiseCustom :: (Serialise a, MonadPlus m) => ByteString -> m a -deserialiseCustom = either (const mzero) pure . deserialiseOrFail --- deserialiseCustom = either (\msg -> trace ("deserialiseCustom: " <> show msg) mzero) pure . deserialiseOrFail --- deserialiseCustom = either (error . show) pure . deserialiseOrFail instance HasProtocol L4Proto (BlockInfo L4Proto) where type instance ProtocolId (BlockInfo L4Proto) = 1 @@ -128,14 +99,6 @@ instance HasProtocol L4Proto (RefLogRequest L4Proto) where decode = deserialiseCustom encode = serialise -instance HasProtocol L4Proto (PeerMetaProto L4Proto) where - type instance ProtocolId (PeerMetaProto L4Proto) = 9 - type instance Encoded L4Proto = ByteString - decode = deserialiseCustom - encode = serialise - - -- FIXME: real-period - requestPeriodLim = ReqLimPerMessage 0.25 instance HasProtocol L4Proto (RefChanHead L4Proto) where type instance ProtocolId (RefChanHead L4Proto) = 11001 @@ -146,14 +109,6 @@ instance HasProtocol L4Proto (RefChanHead L4Proto) where -- TODO: find-out-optimal-max-frequency requestPeriodLim = ReqLimPerMessage 60 -instance HasProtocol L4Proto (EncryptionHandshake L4Proto) where - type instance ProtocolId (EncryptionHandshake L4Proto) = 10 - type instance Encoded L4Proto = ByteString - decode = deserialiseCustom - encode = serialise - - requestPeriodLim = ReqLimPerProto 0.5 - instance HasProtocol L4Proto (RefChanUpdate L4Proto) where type instance ProtocolId (RefChanUpdate L4Proto) = 11002 @@ -192,18 +147,6 @@ instance HasProtocol L4Proto (RefChanNotify L4Proto) where requestPeriodLim = NoLimit -instance HasProtocol L4Proto (DialReq L4Proto) where - type instance ProtocolId (DialReq L4Proto) = 96000 - type instance Encoded L4Proto = ByteString - decode = dialReqDecode . BSL.toStrict - encode = BSL.fromStrict . dialReqEncode - -instance HasProtocol L4Proto (DialResp L4Proto) where - type instance ProtocolId (DialResp L4Proto) = 96001 - type instance Encoded L4Proto = ByteString - decode = dialRespDecode . BSL.toStrict - encode = BSL.fromStrict . dialRespEncode - instance Serialise (RefChanValidate UNIX) => HasProtocol UNIX (RefChanValidate UNIX) where type instance ProtocolId (RefChanValidate UNIX) = 0xFFFA0001 type instance Encoded UNIX = ByteString @@ -252,12 +195,6 @@ instance Expires (SessionKey L4Proto (PeerHandshake L4Proto)) where instance Expires (EventKey L4Proto (PeerAnnounce L4Proto)) where expiresIn _ = Nothing -instance Expires (EventKey L4Proto (PeerMetaProto L4Proto)) where - expiresIn _ = Just 600 - -instance Expires (SessionKey L4Proto (EncryptionHandshake L4Proto)) where - expiresIn _ = Just defCookieTimeoutSec - instance MonadIO m => HasNonces (PeerHandshake L4Proto) m where type instance Nonce (PeerHandshake L4Proto) = BS.ByteString newNonce = do @@ -282,16 +219,3 @@ instance MonadIO m => HasNonces () m where n <- liftIO ( Crypto.newNonce <&> Crypto.encode ) pure $ BS.take 32 n -instance Asymm HBS2Basic where - type AsymmKeypair HBS2Basic = Encrypt.Keypair - type AsymmPrivKey HBS2Basic = Encrypt.SecretKey - type AsymmPubKey HBS2Basic = Encrypt.PublicKey - type CommonSecret HBS2Basic = Encrypt.CombinedKey - asymmNewKeypair = liftIO Encrypt.newKeypair - privKeyFromKeypair = Encrypt.secretKey - pubKeyFromKeypair = Encrypt.publicKey - genCommonSecret = Encrypt.beforeNM - -instance Hashed HbSync Sign.PublicKey where - hashObject pk = hashObject (Crypto.encode pk) - diff --git a/hbs2-core/lib/HBS2/Net/Proto/AnyRef.hs b/hbs2-peer/lib/HBS2/Peer/Proto/AnyRef.hs similarity index 96% rename from hbs2-core/lib/HBS2/Net/Proto/AnyRef.hs rename to hbs2-peer/lib/HBS2/Peer/Proto/AnyRef.hs index 5c97cbe4..41de5e63 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/AnyRef.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/AnyRef.hs @@ -1,5 +1,5 @@ {-# Language UndecidableInstances #-} -module HBS2.Net.Proto.AnyRef where +module HBS2.Peer.Proto.AnyRef where import HBS2.Prelude import HBS2.Hash diff --git a/hbs2-core/lib/HBS2/Net/Proto/BlockAnnounce.hs b/hbs2-peer/lib/HBS2/Peer/Proto/BlockAnnounce.hs similarity index 98% rename from hbs2-core/lib/HBS2/Net/Proto/BlockAnnounce.hs rename to hbs2-peer/lib/HBS2/Peer/Proto/BlockAnnounce.hs index 252a066d..8b3fa717 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/BlockAnnounce.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/BlockAnnounce.hs @@ -1,6 +1,6 @@ {-# Language TemplateHaskell #-} {-# Language UndecidableInstances #-} -module HBS2.Net.Proto.BlockAnnounce where +module HBS2.Peer.Proto.BlockAnnounce where import HBS2.Prelude.Plated import HBS2.Net.Proto diff --git a/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs b/hbs2-peer/lib/HBS2/Peer/Proto/BlockChunks.hs similarity index 98% rename from hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs rename to hbs2-peer/lib/HBS2/Peer/Proto/BlockChunks.hs index b36a292c..72eb28c7 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/BlockChunks.hs @@ -1,10 +1,10 @@ {-# Language RankNTypes #-} -module HBS2.Net.Proto.BlockChunks where +module HBS2.Peer.Proto.BlockChunks where import HBS2.Events import HBS2.Hash import HBS2.Net.Proto -import HBS2.Net.Proto.Peer +import HBS2.Peer.Proto.Peer import HBS2.Prelude.Plated import HBS2.Storage import HBS2.Actors.Peer diff --git a/hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs b/hbs2-peer/lib/HBS2/Peer/Proto/BlockInfo.hs similarity index 95% rename from hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs rename to hbs2-peer/lib/HBS2/Peer/Proto/BlockInfo.hs index 44149446..672105e3 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/BlockInfo.hs @@ -1,12 +1,14 @@ -module HBS2.Net.Proto.BlockInfo where +module HBS2.Peer.Proto.BlockInfo where import HBS2.Prelude.Plated import HBS2.Net.Proto -import HBS2.Net.Proto.Peer +import HBS2.Peer.Proto.Peer import HBS2.Net.Proto.Sessions import HBS2.Events import HBS2.Hash +import HBS2.System.Logger.Simple + import Data.Maybe data BlockInfo e = GetBlockSize (Hash HbSync) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Peer.hs similarity index 94% rename from hbs2-core/lib/HBS2/Net/Proto/Peer.hs rename to hbs2-peer/lib/HBS2/Peer/Proto/Peer.hs index 8e7c1881..f6d415e6 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Peer.hs @@ -1,29 +1,42 @@ {-# Language TemplateHaskell #-} {-# Language UndecidableInstances #-} -module HBS2.Net.Proto.Peer where +module HBS2.Peer.Proto.Peer where -- import HBS2.Base58 import HBS2.Actors.Peer import HBS2.Data.Types import HBS2.Events import HBS2.Net.Proto -import HBS2.Net.Proto.Types import HBS2.Clock import HBS2.Net.Proto.Sessions import HBS2.Prelude.Plated import HBS2.Net.Auth.Credentials -import HBS2.System.Logger.Simple -import Control.Monad -import Crypto.Saltine.Core.Box qualified as Encrypt import Data.Maybe import Codec.Serialise() -import Data.ByteString qualified as BS import Data.Hashable -import Data.String.Conversions (cs) import Lens.Micro.Platform import Type.Reflection (someTypeRep) +data PeerExpires = PeerExpires + +data instance EventKey e PeerExpires = + PeerExpiredEventKey + deriving stock (Typeable, Eq, Generic) + +data instance Event e PeerExpires = + PeerExpiredEvent (Peer e) -- (Maybe (PeerData e)) + deriving stock (Typeable) + +instance EventType (Event e PeerExpires) where + isPersistent = True + +instance Expires (EventKey e PeerExpires) where + expiresIn _ = Nothing + +instance Hashable (EventKey e PeerExpires) + + data PeerHandshake e = PeerPing PingNonce | PeerPong PingNonce (Signature (Encryption e)) (PeerData e) diff --git a/hbs2-core/lib/HBS2/Net/Proto/PeerAnnounce.hs b/hbs2-peer/lib/HBS2/Peer/Proto/PeerAnnounce.hs similarity index 97% rename from hbs2-core/lib/HBS2/Net/Proto/PeerAnnounce.hs rename to hbs2-peer/lib/HBS2/Peer/Proto/PeerAnnounce.hs index 049cf947..4333defe 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/PeerAnnounce.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/PeerAnnounce.hs @@ -1,5 +1,5 @@ {-# Language UndecidableInstances #-} -module HBS2.Net.Proto.PeerAnnounce where +module HBS2.Peer.Proto.PeerAnnounce where import HBS2.Prelude.Plated import HBS2.Net.Proto diff --git a/hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs b/hbs2-peer/lib/HBS2/Peer/Proto/PeerExchange.hs similarity index 98% rename from hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs rename to hbs2-peer/lib/HBS2/Peer/Proto/PeerExchange.hs index f0f3c3de..87a4ad00 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/PeerExchange.hs @@ -1,9 +1,9 @@ {-# Language UndecidableInstances #-} -module HBS2.Net.Proto.PeerExchange where +module HBS2.Peer.Proto.PeerExchange where import HBS2.Prelude.Plated import HBS2.Net.Proto -import HBS2.Net.Proto.Peer +import HBS2.Peer.Proto.Peer import HBS2.Net.PeerLocator import HBS2.Net.Proto.Sessions import HBS2.Events diff --git a/hbs2-core/lib/HBS2/Net/Proto/PeerMeta.hs b/hbs2-peer/lib/HBS2/Peer/Proto/PeerMeta.hs similarity index 83% rename from hbs2-core/lib/HBS2/Net/Proto/PeerMeta.hs rename to hbs2-peer/lib/HBS2/Peer/Proto/PeerMeta.hs index a2b0a9cc..bd2492d3 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/PeerMeta.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/PeerMeta.hs @@ -1,14 +1,17 @@ -module HBS2.Net.Proto.PeerMeta where +module HBS2.Peer.Proto.PeerMeta where import HBS2.Base58 +import HBS2.Clock import HBS2.Events import HBS2.Hash import HBS2.Merkle import HBS2.Net.Proto -import HBS2.Net.Proto.Peer +import HBS2.Peer.Proto.Peer import HBS2.Net.Proto.Sessions import HBS2.Prelude.Plated +import HBS2.Actors.Peer.Types + import HBS2.System.Logger.Simple import Codec.Serialise @@ -19,6 +22,19 @@ import Data.Functor import Data.Maybe import Data.Text.Encoding qualified as TE +instance HasProtocol L4Proto (PeerMetaProto L4Proto) where + type instance ProtocolId (PeerMetaProto L4Proto) = 9 + type instance Encoded L4Proto = LBS.ByteString + decode = deserialiseCustom + encode = serialise + + -- FIXME: real-period + requestPeriodLim = ReqLimPerMessage 0.25 + +instance Expires (EventKey L4Proto (PeerMetaProto L4Proto)) where + expiresIn _ = Just 600 + + data PeerMetaProto e = GetPeerMeta | ThePeerMeta AnnMetaData diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan.hs new file mode 100644 index 00000000..2fabd151 --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan.hs @@ -0,0 +1,14 @@ +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +module HBS2.Peer.Proto.RefChan + ( module HBS2.Peer.Proto.RefChan.Types + , module HBS2.Peer.Proto.RefChan.RefChanHead + , module HBS2.Peer.Proto.RefChan.RefChanUpdate + , module HBS2.Peer.Proto.RefChan.RefChanNotify + ) where + +import HBS2.Peer.Proto.RefChan.Types +import HBS2.Peer.Proto.RefChan.RefChanHead +import HBS2.Peer.Proto.RefChan.RefChanUpdate +import HBS2.Peer.Proto.RefChan.RefChanNotify + diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefChan/RefChanHead.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanHead.hs similarity index 94% rename from hbs2-core/lib/HBS2/Net/Proto/RefChan/RefChanHead.hs rename to hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanHead.hs index 0c636cc7..5181f0a4 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefChan/RefChanHead.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanHead.hs @@ -1,18 +1,18 @@ {-# Language UndecidableInstances #-} {-# Language AllowAmbiguousTypes #-} -module HBS2.Net.Proto.RefChan.RefChanHead where +module HBS2.Peer.Proto.RefChan.RefChanHead where import HBS2.Prelude.Plated import HBS2.Net.Proto import HBS2.Net.Auth.Credentials import HBS2.Base58 -import HBS2.Net.Proto.Peer -import HBS2.Net.Proto.BlockAnnounce +import HBS2.Peer.Proto.Peer +import HBS2.Peer.Proto.BlockAnnounce import HBS2.Net.Proto.Sessions import HBS2.Data.Types.Refs import HBS2.Storage -import HBS2.Net.Proto.RefChan.Types +import HBS2.Peer.Proto.RefChan.Types import HBS2.System.Logger.Simple diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefChan/RefChanNotify.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanNotify.hs similarity index 96% rename from hbs2-core/lib/HBS2/Net/Proto/RefChan/RefChanNotify.hs rename to hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanNotify.hs index 18bc7c6d..e43145c7 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefChan/RefChanNotify.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanNotify.hs @@ -1,6 +1,6 @@ {-# Language UndecidableInstances #-} {-# Language AllowAmbiguousTypes #-} -module HBS2.Net.Proto.RefChan.RefChanNotify where +module HBS2.Peer.Proto.RefChan.RefChanNotify where import HBS2.Prelude.Plated @@ -8,14 +8,14 @@ import HBS2.Hash import HBS2.Net.Proto import HBS2.Net.Auth.Credentials import HBS2.Events -import HBS2.Net.Proto.Peer +import HBS2.Peer.Proto.Peer import HBS2.Net.Proto.Sessions import HBS2.Data.Types.Refs import HBS2.Data.Types.SignedBox import HBS2.Actors.Peer.Types import HBS2.Storage -import HBS2.Net.Proto.RefChan.Types +import HBS2.Peer.Proto.RefChan.Types import HBS2.System.Logger.Simple diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefChan/RefChanUpdate.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs similarity index 99% rename from hbs2-core/lib/HBS2/Net/Proto/RefChan/RefChanUpdate.hs rename to hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs index 4591b2c5..2773c2b9 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefChan/RefChanUpdate.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs @@ -4,7 +4,7 @@ {-# Language FunctionalDependencies #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE PatternSynonyms, ViewPatterns #-} -module HBS2.Net.Proto.RefChan.RefChanUpdate where +module HBS2.Peer.Proto.RefChan.RefChanUpdate where import HBS2.Prelude.Plated import HBS2.Hash @@ -13,7 +13,7 @@ import HBS2.Net.Proto import HBS2.Net.Auth.Credentials import HBS2.Base58 import HBS2.Events -import HBS2.Net.Proto.Peer +import HBS2.Peer.Proto.Peer import HBS2.Net.Proto.Sessions import HBS2.Data.Types.Refs import HBS2.Data.Types.SignedBox @@ -21,7 +21,7 @@ import HBS2.Actors.Peer.Types import HBS2.Data.Types.Peer import HBS2.Storage -import HBS2.Net.Proto.RefChan.Types +import HBS2.Peer.Proto.RefChan.Types import HBS2.System.Logger.Simple diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefChan/Types.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs similarity index 99% rename from hbs2-core/lib/HBS2/Net/Proto/RefChan/Types.hs rename to hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs index 1e39268c..1397ef06 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefChan/Types.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs @@ -4,7 +4,7 @@ {-# Language FunctionalDependencies #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE PatternSynonyms, ViewPatterns #-} -module HBS2.Net.Proto.RefChan.Types where +module HBS2.Peer.Proto.RefChan.Types where import HBS2.Prelude.Plated import HBS2.Hash @@ -15,7 +15,7 @@ import HBS2.Net.Auth.Credentials import HBS2.Base58 import HBS2.Defaults import HBS2.Events -import HBS2.Net.Proto.Peer +import HBS2.Peer.Proto.Peer import HBS2.Net.Proto.Sessions import HBS2.Data.Types.Refs import HBS2.Data.Types.SignedBox diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs similarity index 99% rename from hbs2-core/lib/HBS2/Net/Proto/RefLog.hs rename to hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs index 4fd368d3..68e0139b 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs @@ -1,7 +1,7 @@ {-# Language UndecidableInstances #-} {-# Language AllowAmbiguousTypes #-} {-# Language TemplateHaskell #-} -module HBS2.Net.Proto.RefLog where +module HBS2.Peer.Proto.RefLog where import HBS2.Prelude.Plated import HBS2.Hash @@ -11,7 +11,7 @@ import HBS2.Net.Auth.Credentials import HBS2.Base58 import HBS2.Events import HBS2.Actors.Peer.Types -import HBS2.Net.Proto.Peer +import HBS2.Peer.Proto.Peer import HBS2.Net.Proto.Sessions import HBS2.Data.Types.Refs diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/Peer.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/Peer.hs index b4bb9f30..3a012a30 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/Peer.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/API/Peer.hs @@ -2,6 +2,7 @@ module HBS2.Peer.RPC.API.Peer where import HBS2.Prelude.Plated +import HBS2.Net.Auth.Credentials import HBS2.Net.Messaging.Unix import HBS2.Net.Proto.Service import HBS2.Data.Types.Refs (HashRef(..)) @@ -10,7 +11,6 @@ import HBS2.Net.Messaging.Encrypted.ByPass(ByPassStat) import HBS2.Peer.RPC.Internal.Types -import Data.Time.Clock.POSIX (POSIXTime) import Control.Monad.Reader import Data.ByteString.Lazy (ByteString) import Codec.Serialise @@ -33,6 +33,8 @@ data RpcDownloadDel data RpcByPassInfo +data RpcPerformGC + type PeerAPI = '[ RpcPoke , RpcPing , RpcAnnounce @@ -47,6 +49,7 @@ type PeerAPI = '[ RpcPoke , RpcDownloadList , RpcDownloadDel , RpcByPassInfo + , RpcPerformGC ] instance HasProtocol UNIX (ServiceProto PeerAPI UNIX) where @@ -102,6 +105,9 @@ type instance Output RpcLogLevel = () type instance Input RpcByPassInfo = () type instance Output RpcByPassInfo = ByPassStat +type instance Input RpcPerformGC = () +type instance Output RpcPerformGC = () + data SetLogging = DebugOn Bool | TraceOn Bool diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/RefChan.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/RefChan.hs index a5e48156..c6158915 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/RefChan.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/API/RefChan.hs @@ -1,6 +1,7 @@ {-# Language UndecidableInstances #-} module HBS2.Peer.RPC.API.RefChan where +import HBS2.Peer.Prelude import HBS2.Net.Proto.Service import HBS2.Net.Messaging.Unix (UNIX) import HBS2.Data.Types.Refs (HashRef(..)) diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/RefLog.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/RefLog.hs index 31f44938..ed49c79d 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/RefLog.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/API/RefLog.hs @@ -1,10 +1,11 @@ {-# Language UndecidableInstances #-} module HBS2.Peer.RPC.API.RefLog where +import HBS2.Peer.Prelude import HBS2.Net.Messaging.Unix import HBS2.Data.Types.Refs (HashRef(..)) import HBS2.Net.Proto.Service -import HBS2.Net.Proto.RefLog (RefLogUpdate) +import HBS2.Peer.Proto.RefLog (RefLogUpdate) import Data.ByteString.Lazy (ByteString) import Codec.Serialise diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client/StorageClient.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client/StorageClient.hs index 9ab932de..7683faa8 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Client/StorageClient.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Client/StorageClient.hs @@ -16,7 +16,6 @@ import HBS2.Peer.RPC.Internal.Storage() import HBS2.Peer.RPC.API.Storage -import Data.Functor import Data.ByteString.Lazy (ByteString) import Data.Either diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs index 1f643089..d5fcc9d1 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs @@ -5,6 +5,7 @@ module HBS2.Peer.RPC.Internal.Types ) where import HBS2.Actors.Peer +import HBS2.Net.Auth.Credentials import HBS2.Net.Proto.Types import HBS2.Storage() import HBS2.Data.Types.Refs (HashRef) diff --git a/hbs2-peer/lib/HBS2/Peer/RefChanNotifyLog.hs b/hbs2-peer/lib/HBS2/Peer/RefChanNotifyLog.hs index f927fb2d..230582fe 100644 --- a/hbs2-peer/lib/HBS2/Peer/RefChanNotifyLog.hs +++ b/hbs2-peer/lib/HBS2/Peer/RefChanNotifyLog.hs @@ -4,9 +4,7 @@ module HBS2.Peer.RefChanNotifyLog where import HBS2.Data.Types.Refs -import HBS2.Net.Proto.Definition() -import HBS2.Net.Proto.RefChan - +import HBS2.Peer.Proto.RefChan type RefChanNotifyLogKey e = SomeRefKey (String, RefChanId e) diff --git a/hbs2-share/src/HBS2/Share/App.hs b/hbs2-share/src/HBS2/Share/App.hs index 8bfe90f6..b0532f9c 100644 --- a/hbs2-share/src/HBS2/Share/App.hs +++ b/hbs2-share/src/HBS2/Share/App.hs @@ -16,14 +16,13 @@ import HBS2.Defaults (defBlockSize) import HBS2.Hash import HBS2.Clock import HBS2.OrDie -import HBS2.Net.Proto.RefChan.Types +import HBS2.Peer.Proto.RefChan.Types import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Credentials.Sigil import HBS2.Data.Types.SignedBox import HBS2.Net.Auth.GroupKeySymm import HBS2.Net.Auth.GroupKeySymm qualified as Symm -import HBS2.Net.Proto.Definition() -import HBS2.Net.Proto.RefChan +import HBS2.Peer.Proto.RefChan import HBS2.Net.Messaging.Unix import HBS2.Net.Proto.Service diff --git a/hbs2-share/src/HBS2/Share/App/Types.hs b/hbs2-share/src/HBS2/Share/App/Types.hs index 31cc7cb7..78215446 100644 --- a/hbs2-share/src/HBS2/Share/App/Types.hs +++ b/hbs2-share/src/HBS2/Share/App/Types.hs @@ -16,9 +16,8 @@ module HBS2.Share.App.Types import HBS2.Prelude.Plated import HBS2.Base58 import HBS2.Data.Types.Refs -import HBS2.Net.Proto.RefChan +import HBS2.Peer.Proto.RefChan import HBS2.Net.Proto.Types -import HBS2.Net.Proto.Definition() import HBS2.Net.Proto.Service import HBS2.Net.Auth.Credentials diff --git a/hbs2-share/src/HBS2/Share/Keys.hs b/hbs2-share/src/HBS2/Share/Keys.hs index 7f904ad1..d6183b5b 100644 --- a/hbs2-share/src/HBS2/Share/Keys.hs +++ b/hbs2-share/src/HBS2/Share/Keys.hs @@ -4,7 +4,6 @@ import HBS2.Prelude.Plated import HBS2.Hash import HBS2.Data.Types.Refs import HBS2.Net.Proto.Types -import HBS2.Net.Proto.Definition () type GK0 s = GroupKey 'Symm s diff --git a/hbs2-storage-simple/hbs2-storage-simple.cabal b/hbs2-storage-simple/hbs2-storage-simple.cabal index 027dfb4f..134a2ab5 100644 --- a/hbs2-storage-simple/hbs2-storage-simple.cabal +++ b/hbs2-storage-simple/hbs2-storage-simple.cabal @@ -73,6 +73,7 @@ library , microlens-platform , mtl , prettyprinter + , random , stm , stm-chans , streaming diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs index 5d51bfb9..465ab86b 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs +++ b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs @@ -45,8 +45,12 @@ import Data.Time.Clock.POSIX (getPOSIXTime) import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict (HashMap) +import Data.Cache +import Data.Cache qualified as Cache + import System.IO.Posix.MMap ( unsafeMMapFile ) +import Control.Monad.Trans.Cont import Control.Concurrent.STM import Control.Concurrent.STM.TBQueue qualified as TBQ import Control.Concurrent.STM.TBMQueue qualified as TBMQ @@ -54,6 +58,8 @@ import Control.Concurrent.STM.TBMQueue (TBMQueue) import Control.Concurrent.STM.TVar qualified as TV import Codec.Serialise +import System.Random +import System.Mem -- NOTE: random accessing files in a git-like storage @@ -84,6 +90,7 @@ data SimpleStorage a = , _storageStopWriting :: TVar Bool , _storageMMaped :: TVar (HashMap (Key a) ByteString) , _storageMMapedLRU :: TVar (HashMap (Key a) TimeSpec) + , _storageSizeCache :: Cache (Key a) (Maybe Integer) } makeLenses ''SimpleStorage @@ -138,6 +145,7 @@ simpleStorageInit opts = liftIO $ do <*> TV.newTVarIO False <*> TV.newTVarIO mempty <*> TV.newTVarIO mempty + <*> Cache.newCache (Just (toTimeSpec (10 :: Timeout 'Seconds))) createDirectoryIfMissing True (stor ^. storageBlocks) createDirectoryIfMissing True (stor ^. storageTemp) @@ -171,32 +179,42 @@ simpleStorageStop ss = do simpleStorageWorker :: IsSimpleStorageKey h => SimpleStorage h -> IO () simpleStorageWorker ss = do - ops <- async $ fix \next -> do - s <- atomically $ do TBMQ.readTBMQueue ( ss ^. storageOpQ ) - case s of - Nothing -> pure () - Just a -> a >> next + lastKick <- newTVarIO =<< getTimeCoarse - killer <- async $ forever $ do - pause ( 30 :: Timeout 'Seconds ) -- FIXME: setting - simpleAddTask ss $ do + flip runContT pure do - atomically $ do + ContT $ withAsync $ forever $ do + pause ( 30 :: Timeout 'Seconds ) -- FIXME: setting + simpleAddTask ss $ do - alive <- readTVar ( ss ^. storageMMapedLRU ) - mmaped <- readTVar ( ss ^. storageMMaped ) + atomically $ do - let survived = mmaped `HashMap.intersection` alive + alive <- readTVar ( ss ^. storageMMapedLRU ) + mmaped <- readTVar ( ss ^. storageMMaped ) - writeTVar ( ss ^. storageMMaped ) survived + let survived = mmaped `HashMap.intersection` alive - killerLRU <- async $ forever $ do - pause ( 10 :: Timeout 'Seconds ) -- FIXME: setting - atomically $ writeTVar ( ss ^. storageMMapedLRU ) mempty + writeTVar ( ss ^. storageMMaped ) survived - (_, e) <- waitAnyCatchCancel [ops,killer, killerLRU] + ContT $ withAsync $ do + let lru = ss ^. storageMMapedLRU + let timeout = 5 :: Timeout 'Seconds + forever $ do + pause ( 10 :: Timeout 'Seconds ) -- FIXME: setting + now <- getTimeCoarse + let notExpired t0 = not (expired timeout (now - t0)) + atomically do + modifyTVar lru (HashMap.filter notExpired) - pure () + liftIO do + fix \next -> do + s <- atomically $ do TBMQ.readTBMQueue ( ss ^. storageOpQ ) + case s of + Nothing -> pure () + Just a -> do + now <- getTimeCoarse + atomically $ writeTVar lastKick now + a >> next simpleBlockFileName :: Pretty (Hash h) => SimpleStorage h -> Hash h -> FilePath simpleBlockFileName ss h = path @@ -273,7 +291,7 @@ simpleGetChunkLazy s key off size = do atomically $ TBMQ.readTBMQueue resQ >>= maybe (pure Nothing) pure -simplePutBlockLazy :: (IsKey h, Hashed h LBS.ByteString) +simplePutBlockLazy :: (IsSimpleStorageKey h, Hashed h LBS.ByteString) => Bool -- | wait -> SimpleStorage h -> LBS.ByteString @@ -281,6 +299,8 @@ simplePutBlockLazy :: (IsKey h, Hashed h LBS.ByteString) simplePutBlockLazy doWait s lbs = do + let cache = view storageSizeCache s + let hash = hashObject lbs stop <- atomically $ TV.readTVar ( s ^. storageStopWriting ) @@ -296,7 +316,8 @@ simplePutBlockLazy doWait s lbs = do handle (\(_ :: IOError) -> atomically $ TBQ.writeTBQueue waits False) do let fn = simpleBlockFileName s hash - AwBS.atomicWriteFile fn (LBS.toStrict lbs) + let blk = LBS.toStrict lbs + AwBS.atomicWriteFile fn blk atomically $ TBQ.writeTBQueue waits True simpleAddTask s action @@ -312,16 +333,26 @@ simplePutBlockLazy doWait s lbs = do pure $ Just hash -- TODO: should be async as well? -simpleBlockExists :: IsKey h +simpleBlockExists :: IsSimpleStorageKey h => SimpleStorage h -> Hash h -> IO (Maybe Integer) simpleBlockExists ss hash = runMaybeT $ do let fn = simpleBlockFileName ss hash - exists <- liftIO $ doesFileExist fn - unless exists mzero - liftIO $ getFileSize fn + + let cache = view storageSizeCache ss + mbsize <- liftIO $ Cache.lookup cache hash + + case mbsize of + Just (Just n) -> do + pure n + _ -> do + exists <- liftIO $ doesFileExist fn + unless exists mzero + s <- liftIO $ getFileSize fn + liftIO $ Cache.insert cache hash (Just s) + pure s spawnAndWait :: SimpleStorage h -> IO a -> IO (Maybe a) spawnAndWait s act = do @@ -474,10 +505,12 @@ instance ( MonadIO m, IsKey hash pure $ unAsBase58 parsed delBlock ss h = do + let cache = view storageSizeCache ss let fn = simpleBlockFileName ss h void $ liftIO $ spawnAndWait ss do exists <- doesFileExist fn when exists (removeFile fn) + Cache.delete cache h delRef ss ref = do let refHash = hashObject @hash ref diff --git a/hbs2-tests/refchan-dummy-validator/DummyValidatorMain.hs b/hbs2-tests/refchan-dummy-validator/DummyValidatorMain.hs index 4c6c283e..b9eb7212 100644 --- a/hbs2-tests/refchan-dummy-validator/DummyValidatorMain.hs +++ b/hbs2-tests/refchan-dummy-validator/DummyValidatorMain.hs @@ -5,15 +5,13 @@ import HBS2.Base58 import HBS2.OrDie import HBS2.Net.Proto.Types import HBS2.Actors.Peer -import HBS2.Net.Proto.RefChan +import HBS2.Peer.Proto import HBS2.Net.Messaging.Unix -import HBS2.Net.Proto.Definition() import HBS2.Net.Auth.Credentials() import HBS2.System.Logger.Simple import Control.Monad.Reader -import Data.Functor import Data.List qualified as List import Options.Applicative hiding (info) import Options.Applicative qualified as O diff --git a/hbs2-tests/test/TestRawTx.hs b/hbs2-tests/test/TestRawTx.hs index 528d0cba..1474b2a9 100644 --- a/hbs2-tests/test/TestRawTx.hs +++ b/hbs2-tests/test/TestRawTx.hs @@ -6,9 +6,7 @@ import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy.Char8 qualified as LBS import HBS2.Base58 (fromBase58) import HBS2.Net.Auth.Credentials -import HBS2.Net.Proto hiding (request) -import HBS2.Net.Proto.Definition () -import HBS2.Net.Proto.RefLog (makeRefLogUpdate) +import HBS2.Peer.Proto hiding (request) import HBS2.OrDie import HBS2.Prelude import Lens.Micro.Platform diff --git a/hbs2/Main.hs b/hbs2/Main.hs index d2c6fef1..50a66cde 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -3,23 +3,20 @@ module Main where import HBS2.Base58 import HBS2.Data.Detect import HBS2.Data.Types -import HBS2.Data.Types.EncryptedBox import HBS2.Data.Types.SignedBox import HBS2.Data.KeyRing as KeyRing import HBS2.Defaults import HBS2.Merkle -import HBS2.Net.Proto.Types +import HBS2.Peer.Proto import HBS2.Net.Auth.GroupKeyAsymm as Asymm import HBS2.Net.Auth.GroupKeySymm qualified as Symm import HBS2.Net.Auth.GroupKeySymm --- (ToEncrypt(..)) import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Credentials.Sigil -import HBS2.Net.Proto.Definition() -import HBS2.Net.Proto.RefLog(RefLogKey(..)) -import HBS2.Net.Proto.AnyRef(AnyRefKey(..)) import HBS2.Prelude.Plated +import HBS2.Storage import HBS2.Storage.Operations.Class +import HBS2.Storage.Operations.ByteString import HBS2.Storage.Simple import HBS2.Storage.Simple.Extra import HBS2.Data.Bundle @@ -27,11 +24,11 @@ import HBS2.OrDie import HBS2.Version import Paths_hbs2 qualified as Pkg +import HBS2.KeyMan.Keys.Direct import HBS2.System.Logger.Simple hiding (info) import Data.Config.Suckless -import Data.Config.Suckless.KeyValue import Codec.Serialise import Control.Concurrent.STM qualified as STM @@ -47,13 +44,10 @@ import Data.ByteString.Lazy qualified as LBS import Data.ByteString qualified as BS import Data.ByteArray.Hash (SipHash(..), SipKey(..)) import Data.ByteArray.Hash qualified as BA +import Data.HashMap.Strict qualified as HM import Data.Either -import Data.Function -import Data.Functor import Data.List qualified as List -import Data.Map.Strict qualified as Map import Data.Maybe -import Data.Monoid qualified as Monoid import Data.Text qualified as Text import Lens.Micro.Platform import Options.Applicative @@ -64,8 +58,6 @@ import System.Exit qualified as Exit import System.IO qualified as IO import System.IO.Temp (emptySystemTempFile) import UnliftIO -import Network.ByteOrder qualified as N - tracePrefix :: SetLoggerEntry tracePrefix = logPrefix "[trace] " . toStderr @@ -219,56 +211,6 @@ runCat opts ss = do let walk h = walkMerkle h (getBlock ss) stepInside - -- FIXME: switch-to-deep-scan - -- TODO: to-the-library - let walkAnn :: MTreeAnn [HashRef] -> IO () - walkAnn ann = do - bprocess :: Hash HbSync -> ByteString -> IO ByteString <- case (_mtaCrypt ann) of - NullEncryption -> pure (const pure) - - EncryptGroupNaClSymm{} -> do - die "EncryptGroupNaClSymm is not supported yet" - - CryptAccessKeyNaClAsymm crypth -> do - - keyringFile <- pure (uniLastMay @OptKeyringFile opts <&> unOptKeyringFile) - `orDie` "block encrypted. keyring required" - s <- BS.readFile keyringFile - ourKeys <- _peerKeyring - <$> pure (parseCredentials @s (AsCredFile s)) - `orDie` "bad keyring file" - - blkc <- getBlock ss crypth `orDie` (show $ "missed block: " <+> pretty crypth) - recipientKeys :: [(PubKey 'Encrypt s, EncryptedBox (KeyringEntry s))] - <- pure (deserialiseMay blkc) - `orDie` "can not deserialise access key" - - (ourkr, box) - <- pure (Monoid.getFirst - (foldMap (\kr@(KeyringEntry pk _ _) - -> Monoid.First ((kr, ) - <$> Map.lookup pk (Map.fromList recipientKeys))) - ourKeys)) - `orDie` "no available recipient key" - - kr <- pure (openEncryptedKey box ourkr) - `orDie` "can not open sealed secret key with our key" - - pure $ \hx blk -> - pure ((fmap LBS.fromStrict . Encrypt.boxSealOpen (_krPk kr) (_krSk kr) . LBS.toStrict) blk) - `orDie` (show $ "can not decode block: " <+> pretty hx) - - walkMerkleTree (_mtaTree ann) (getBlock ss) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do - case hr of - Left hx -> void $ hPrint stderr $ "missed block:" <+> pretty hx - Right (hrr :: [HashRef]) -> do - forM_ hrr $ \(HashRef hx) -> do - if honly then do - print $ pretty hx - else do - blk <- getBlock ss hx `orDie` (show $ "missed block: " <+> pretty hx) - LBS.putStr =<< bprocess hx blk - case q of Blob h -> getBlock ss h >>= maybe (die "blob not found") LBS.putStr @@ -279,19 +221,29 @@ runCat opts ss = do Left hx -> err $ "missed block" <+> pretty hx Right hr -> print $ vcat (fmap pretty hr) - MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm{}}) -> do + MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do + keyring <- case uniLastMay @OptKeyringFile opts of + Just krf -> do + s <- BS.readFile (unOptKeyringFile krf) + cred <- pure (parseCredentials @HBS2Basic (AsCredFile s)) `orDie` "bad keyring file" + pure $ view peerKeyring cred - krf <- pure (uniLastMay @OptKeyringFile opts) `orDie` "keyring file not set" - s <- BS.readFile (unOptKeyringFile krf) - cred <- pure (parseCredentials @HBS2Basic (AsCredFile s)) `orDie` "bad keyring file" - let keyring = view peerKeyring cred + Nothing -> fromMaybe mempty <$> runMaybeT do + rcpts <- runExceptT (readFromMerkle (AnyStorage ss) (SimpleKey gkh)) + >>= toMPlus + <&> deserialiseOrFail @(GroupKey 'Symm s) + >>= toMPlus + <&> HM.keys . recipients + + lift $ runKeymanClient do + loadKeyRingEntries rcpts <&> fmap snd elbs <- runExceptT $ readFromMerkle ss (ToDecryptBS keyring mhash) case elbs of Right lbs -> LBS.putStr lbs Left e -> die (show e) - MerkleAnn ann -> walkAnn ann + MerkleAnn ann -> die "asymmetric gropup encryption is deprecated" -- FIXME: what-if-multiple-seq-ref-? SeqRef (SequentialRef _ (AnnotatedHashRef _ h)) -> do @@ -351,9 +303,8 @@ runStore opts ss = runResourceT do Just gkfile -> do gkSymm <- liftIO $ Symm.parseGroupKey @HBS2Basic . AsGroupKeyFile <$> LBS.readFile (unOptGroupkeyFile gkfile) - gkAsymm <- liftIO $ Asymm.parseGroupKey . AsGroupKeyFile <$> BS.readFile (unOptGroupkeyFile gkfile) - let mbGk = EncSymm <$> gkSymm <|> EncAsymm <$> gkAsymm + let mbGk = EncSymm <$> gkSymm case mbGk of Nothing -> die "unknown or invalid group key" @@ -584,24 +535,42 @@ main = join . customExecParser (prefs showHelpOnError) $ pure $ withStore o $ runCat $ CatOpts hash (CatHashesOnly <$> onlyh) (OptKeyringFile <$> keyringFile) raw - pGroupKey = hsubparser ( command "asymm" (info pGroupKeyAsymm (progDesc "asymmetric group keys") ) - <> command "symm" (info pGroupKeySymm (progDesc "symmetric group keys") ) - ) - - - pGroupKeyAsymm = hsubparser ( command "gen" (info pGroupKeyAsymmNew (progDesc "generate") ) - ) - - pGroupKeyAsymmNew = do - pubkeysFile <- strArgument ( metavar "FILE" <> help "path to a file with a list of recipient public keys" ) - pure $ runNewGroupKeyAsymm pubkeysFile - + pGroupKey = pGroupKeySymm pGroupKeySymm = hsubparser ( command "gen" (info pGroupKeySymmGen (progDesc "generate") ) + <> command "from-sigils" (info pGroupKeyFromSigils (progDesc "generate from sigils") ) + <> command "from-keys" (info pGroupKeyFromKeys (progDesc "generate from list of encryption pubkeys") ) <> command "dump" (info pGroupKeySymmDump (progDesc "dump") ) <> command "update" (info pGroupKeySymmUpdate (progDesc "update") ) ) + + pGroupKeyFromSigils = do + fns <- many $ strArgument ( metavar "SIGIL-FILES" <> help "sigil file list" ) + pure $ do + members <- for fns $ \fn -> do + + sigil <- (BS.readFile fn <&> parseSerialisableFromBase58 @(Sigil L4Proto)) + `orDie` "parse sigil failed" + (_,sd) <- pure (unboxSignedBox0 @(SigilData L4Proto) (sigilData sigil)) + `orDie` ("signature check failed " <> fn) + + pure (sigilDataEncKey sd) + + gk <- Symm.generateGroupKey @HBS2Basic Nothing members + print $ pretty (AsGroupKeyFile gk) + + pGroupKeyFromKeys = do + pure $ do + input <- getContents <&> words + members <- for input $ \s -> do + fromStringMay @(PubKey 'Encrypt HBS2Basic) s + & maybe (die "invalid public key") pure + + gk <- Symm.generateGroupKey @HBS2Basic Nothing members + print $ pretty (AsGroupKeyFile gk) + + pGroupKeySymmGen = do fn <- optional $ strArgument ( metavar "FILE" <> help "group key definition file" ) pure $ do diff --git a/hbs2/hbs2.cabal b/hbs2/hbs2.cabal index eb427680..99124598 100644 --- a/hbs2/hbs2.cabal +++ b/hbs2/hbs2.cabal @@ -64,7 +64,7 @@ executable hbs2 other-modules: Paths_hbs2 -- other-extensions: - build-depends: base, hbs2-core, hbs2-storage-simple + build-depends: base, hbs2-core, hbs2-peer, hbs2-storage-simple, hbs2-keyman , aeson , async , base58-bytestring @@ -100,6 +100,7 @@ executable hbs2 , stm , unliftio , network-byte-order + , unordered-containers hs-source-dirs: . default-language: Haskell2010 diff --git a/nix/peer/.gitignore b/nix/peer/.gitignore new file mode 100644 index 00000000..de506ce6 --- /dev/null +++ b/nix/peer/.gitignore @@ -0,0 +1 @@ +./flake.lock diff --git a/nix/peer/flake.lock b/nix/peer/flake.lock index f83eda4a..1607319a 100644 --- a/nix/peer/flake.lock +++ b/nix/peer/flake.lock @@ -9,11 +9,11 @@ ] }, "locked": { - "lastModified": 1700834043, - "narHash": "sha256-VDExjkJ2maIP+Baw5V3fhmRtJ4nHpQV/Fxg1H8g69ME=", + "lastModified": 1708680396, + "narHash": "sha256-ZPwDreNdnyCS/hNdaE0OqVhytm+SzZGRfGRTRvBuSzE=", "ref": "refs/heads/master", - "rev": "6050d7949f390c4717293d1d410123439e0fda67", - "revCount": 6, + "rev": "221fde04a00a9c38d2f6c0d05b1e1c3457d5a827", + "revCount": 7, "type": "git", "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft" }, @@ -295,16 +295,17 @@ "suckless-conf": "suckless-conf_2" }, "locked": { - "lastModified": 1708329902, - "narHash": "sha256-DrXP90f4etkB+AyqnHXNfdB3fE8Eg4f4uEcDbk5ppQI=", - "ref": "newest-hbs2-git", - "rev": "f1ded0ae7d580a00f23574cc11c2ba6793857b0c", - "revCount": 1046, + "lastModified": 1709273510, + "narHash": "sha256-wyerw00pnZq64wQGg+azHnLWzDz4C7PvBqCK3U5ejRI=", + "ref": "totally-new-download", + "rev": "a6e955aa611c3f9485976ce7eba33570a43f2eb7", + "revCount": 1036, "type": "git", "url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP" }, "original": { - "ref": "newest-hbs2-git", + "ref": "totally-new-download", + "rev": "a6e955aa611c3f9485976ce7eba33570a43f2eb7", "type": "git", "url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP" } @@ -316,11 +317,11 @@ ] }, "locked": { - "lastModified": 1707467182, - "narHash": "sha256-/Bw/xgCXfj4nXDd8Xq+r1kaorfsYkkomMf5w5MpsDyA=", + "lastModified": 1709204054, + "narHash": "sha256-U1idK0JHs1XOfSI1APYuXi4AEADf+B+ZU4Wifc0pBHk=", "owner": "nix-community", "repo": "home-manager", - "rev": "5b9156fa9a8b8beba917b8f9adbfd27bf63e16af", + "rev": "2f3367769a93b226c467551315e9e270c3f78b15", "type": "github" }, "original": { @@ -369,11 +370,11 @@ }, "nixpkgs_2": { "locked": { - "lastModified": 1707451808, - "narHash": "sha256-UwDBUNHNRsYKFJzyTMVMTF5qS4xeJlWoeyJf+6vvamU=", + "lastModified": 1709200309, + "narHash": "sha256-lKdtMbhnBNU1lr978T+wEYet3sfIXXgyiDZNEgx8CV8=", "owner": "nixos", "repo": "nixpkgs", - "rev": "442d407992384ed9c0e6d352de75b69079904e4e", + "rev": "ebe6e807793e7c9cc59cf81225fdee1a03413811", "type": "github" }, "original": { diff --git a/nix/peer/flake.nix b/nix/peer/flake.nix index 4aa3dfb9..b8f1e540 100644 --- a/nix/peer/flake.nix +++ b/nix/peer/flake.nix @@ -6,7 +6,8 @@ inputs = { extra-container.url = "github:erikarvstedt/extra-container"; nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; - hbs2.url = "git+http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP?ref=newest-hbs2-git"; + hbs2.url = + "git+http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP?ref=totally-new-download&rev=a6e955aa611c3f9485976ce7eba33570a43f2eb7"; hbs2.inputs.nixpkgs.follows = "nixpkgs"; home-manager.url = "github:nix-community/home-manager"; @@ -112,55 +113,8 @@ key "./default.key" networking.firewall.enable = false; - nixpkgs.overlays = [ - inputs.hbs2.overlays.default - (let - packagePostOverrides = with pkgs; with haskell.lib; [ - disableExecutableProfiling - disableLibraryProfiling - dontBenchmark - dontCoverage - dontDistribute - dontHaddock - dontCheck - ]; - - hsPkgsToOverride = [ - "hbs2" - "hbs2-peer" - "hbs2-core" - "hbs2-storage-simple" - "hbs2-git" - "hbs2-qblf" - "hbs2-keyman" - "hbs2-share" - "hbs21-git" - "hspup" - "fixme" - "suckless-conf" - "db-pipe" - "saltine" - ]; - - foldCompose = builtins.foldl' (f: g: a: f (g a)) (x: x); - getAttrs = names: attrs: pkgs.lib.attrsets.genAttrs names (n: attrs.${n}); - hpOverrides = new: old: - (builtins.mapAttrs - (_name: (foldCompose packagePostOverrides)) - (getAttrs hsPkgsToOverride old) - ); - - in final: prev: { - haskellPackages = prev.haskellPackages.override (oldAttrs: { - overrides = prev.lib.composeExtensions (oldAttrs.overrides or (_: _: { })) hpOverrides; - }); - } - ) - - ]; - environment.systemPackages = with pkgs; [ - haskellPackages.hbs2 + inputs.hbs2.packages.${pkgs.system}.default screen tshark tmux diff --git a/weeder.toml b/weeder.toml new file mode 100644 index 00000000..af2ef20f --- /dev/null +++ b/weeder.toml @@ -0,0 +1,3 @@ +roots = [ "^Main.main$" ] +type-class-roots = true +