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

merged new download and some intermediate changes

This commit is contained in:
Dmitry Zuikov 2024-03-06 16:10:24 +03:00
parent ba25f0c564
commit e9c7c9dbae
117 changed files with 1777 additions and 1931 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile
View File

@ -12,6 +12,7 @@ BINS := \
hbs2-peer \
hbs2-reposync \
hbs2-keyman \
hbs2-git-reposync \
git-remote-hbs2 \
git-hbs2 \

18
code-of-conduct
View File

@ -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.

4
docs/devlog.md
View File

@ -1,3 +1,7 @@
## 2024-02-24
wtf?
## 2024-02-06
Новый формат репозиториев и реворк hbs2-git, статус - wip.

4
examples/refchan-qblf/app/RefChanQBLFMain.hs
View File

@ -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

5
examples/refchan-qblf/lib/Demo/QBLF/Transactions.hs
View File

@ -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

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

@ -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

8
flake.lock
View File

@ -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"
},

5
flake.nix
View File

@ -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
'';
};

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

@ -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:

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

@ -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)
)

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

@ -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

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

@ -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

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

@ -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

3
hbs2-core/lib/HBS2/Misc/PrettyStuff.hs
View File

@ -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

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

@ -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)

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

@ -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

53
hbs2-core/lib/HBS2/Net/Auth/Schema.hs Normal file
View File

@ -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

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

@ -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

195
hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs
View File

@ -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)

35
hbs2-core/lib/HBS2/Net/Proto/Event/PeerExpired.hs
View File

@ -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

14
hbs2-core/lib/HBS2/Net/Proto/RefChan.hs
View File

@ -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

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

@ -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

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

@ -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

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

@ -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

5
hbs2-core/lib/HBS2/Storage/Operations/Class.hs
View File

@ -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

2
hbs2-core/test/Main.hs
View File

@ -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

35
hbs2-core/test/TestDerivedKey.hs Normal file
View File

@ -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 ()

30
hbs2-git-reposync/LICENSE Normal file
View File

@ -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.

114
hbs2-git/reposync/ReposyncMain.hs → hbs2-git-reposync/ReposyncMain.hs
View File

@ -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

0
hbs2-git/reposync/examples/config → hbs2-git-reposync/examples/config
View File

135
hbs2-git-reposync/hbs2-git-reposync.cabal Normal file
View File

@ -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

1
hbs2-git/git-hbs2/GitRemoteTypes.hs
View File

@ -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

1
hbs2-git/git-hbs2/Main.hs
View File

@ -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

31
hbs2-git/hbs2-git.cabal
View File

@ -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

6
hbs2-git/lib/HBS2Git/Annotations.hs
View File

@ -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)

4
hbs2-git/lib/HBS2Git/App.hs
View File

@ -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

6
hbs2-git/lib/HBS2Git/Encryption.hs
View File

@ -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

11
hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs
View File

@ -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

4
hbs2-git/lib/HBS2Git/Export.hs
View File

@ -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)

2
hbs2-git/lib/HBS2Git/Import.hs
View File

@ -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)

11
hbs2-git/lib/HBS2Git/KeysCommand.hs
View File

@ -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

25
hbs2-git/lib/HBS2Git/KeysMetaData.hs
View File

@ -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

15
hbs2-git/lib/HBS2Git/Prelude.hs Normal file
View File

@ -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

12
hbs2-git/lib/HBS2Git/State.hs
View File

@ -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

3
hbs2-git/lib/HBS2Git/Types.hs
View File

@ -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

62
hbs2-keyman/app/Main.hs
View File

@ -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

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

@ -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:

8
hbs2-keyman/src/HBS2/KeyMan/App/Types.hs
View File

@ -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

4
hbs2-keyman/src/HBS2/KeyMan/Keys.hs
View File

@ -1,4 +0,0 @@
module HBS2.KeyMan.Keys where

40
hbs2-keyman/src/HBS2/KeyMan/Keys/Direct.hs
View File

@ -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)

8
hbs2-keyman/src/HBS2/KeyMan/Prelude.hs Normal file
View File

@ -0,0 +1,8 @@
module HBS2.KeyMan.Prelude
( module HBS2.Prelude.Plated
) where
import HBS2.Prelude.Plated

66
hbs2-keyman/src/HBS2/KeyMan/State.hs
View File

@ -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

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

File diff suppressed because it is too large Load Diff

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

@ -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

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

@ -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

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

@ -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

10
hbs2-peer/app/CLI/RefChan.hs
View File

@ -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 ())

5
hbs2-peer/app/CheckBlockAnnounce.hs
View File

@ -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

82
hbs2-peer/app/EncryptionKeys.hs
View File

@ -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

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

@ -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

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

@ -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

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

@ -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

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

@ -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

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

@ -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)

181
hbs2-peer/app/PeerMain/Dialog/Server.hs
View File

@ -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 ()

35
hbs2-peer/app/PeerMain/Dialog/Spec.hs
View File

@ -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)

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

@ -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

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

@ -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

3
hbs2-peer/app/RPC2/Downloads.hs
View File

@ -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

1
hbs2-peer/app/RPC2/Peer.hs
View File

@ -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()

4
hbs2-peer/app/RPC2/Peers.hs
View File

@ -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

25
hbs2-peer/app/RPC2/PerformGC.hs Normal file
View File

@ -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 ()

6
hbs2-peer/app/RPC2/PexInfo.hs
View File

@ -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

3
hbs2-peer/app/RPC2/Poll.hs
View File

@ -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

6
hbs2-peer/app/RPC2/RefChan.hs
View File

@ -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)

7
hbs2-peer/app/RPC2/RefLog.hs
View File

@ -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

10
hbs2-peer/app/RefChan.hs
View File

@ -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)))

5
hbs2-peer/app/RefChanNotifyLog.hs
View File

@ -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

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

@ -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

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

@ -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

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

@ -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

6
hbs2-peer/lib/HBS2/Peer/Notify.hs
View File

@ -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)

15
hbs2-peer/lib/HBS2/Peer/Prelude.hs Normal file
View File

@ -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

136
hbs2-core/lib/HBS2/Net/Proto/Definition.hs → hbs2-peer/lib/HBS2/Peer/Proto.hs
View File

@ -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)

2
hbs2-core/lib/HBS2/Net/Proto/AnyRef.hs → hbs2-peer/lib/HBS2/Peer/Proto/AnyRef.hs
View File

@ -1,5 +1,5 @@
{-# Language UndecidableInstances #-}
module HBS2.Net.Proto.AnyRef where
module HBS2.Peer.Proto.AnyRef where
import HBS2.Prelude
import HBS2.Hash

2
hbs2-core/lib/HBS2/Net/Proto/BlockAnnounce.hs → hbs2-peer/lib/HBS2/Peer/Proto/BlockAnnounce.hs
View File

@ -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

4
hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs → hbs2-peer/lib/HBS2/Peer/Proto/BlockChunks.hs
View File

@ -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

6
hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs → hbs2-peer/lib/HBS2/Peer/Proto/BlockInfo.hs
View File

@ -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)

27
hbs2-core/lib/HBS2/Net/Proto/Peer.hs → hbs2-peer/lib/HBS2/Peer/Proto/Peer.hs
View File

@ -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)

2
hbs2-core/lib/HBS2/Net/Proto/PeerAnnounce.hs → hbs2-peer/lib/HBS2/Peer/Proto/PeerAnnounce.hs
View File

@ -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

4
hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs → hbs2-peer/lib/HBS2/Peer/Proto/PeerExchange.hs
View File

@ -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

20
hbs2-core/lib/HBS2/Net/Proto/PeerMeta.hs → hbs2-peer/lib/HBS2/Peer/Proto/PeerMeta.hs
View File

@ -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

14
hbs2-peer/lib/HBS2/Peer/Proto/RefChan.hs Normal file
View File

@ -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

8
hbs2-core/lib/HBS2/Net/Proto/RefChan/RefChanHead.hs → hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanHead.hs
View File

@ -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

6
hbs2-core/lib/HBS2/Net/Proto/RefChan/RefChanNotify.hs → hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanNotify.hs
View File

@ -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

6
hbs2-core/lib/HBS2/Net/Proto/RefChan/RefChanUpdate.hs → hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs
View File

@ -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

4
hbs2-core/lib/HBS2/Net/Proto/RefChan/Types.hs → hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs
View File

@ -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

4
hbs2-core/lib/HBS2/Net/Proto/RefLog.hs → hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs
View File

@ -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

8
hbs2-peer/lib/HBS2/Peer/RPC/API/Peer.hs
View File

@ -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

1
hbs2-peer/lib/HBS2/Peer/RPC/API/RefChan.hs
View File

@ -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(..))

Some files were not shown because too many files have changed in this diff Show More