mirror of https://github.com/voidlizard/hbs2
Squashed commit of the following:
commit cc3d5a357eee5c0e01f530808f8122f83b5103a2
Author: Dmitry Zuikov <dzuikov@gmail.com>
Date: Tue Jul 4 15:29:09 2023 +0300
fixme
commit abae50a7895fdfc70e3a9204288a1af1a00f1c77
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Mon Jul 3 20:05:08 2023 +0400
encryption debug -> traces
commit e8cab85da295ad81896726bf41f118bc2eb6e79e
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Mon Jul 3 00:21:34 2023 +0400
bus encryption fixed
commit cbb3e796b0d919d6d425a5d8c669cfce2ed02182
Merge: a740db8 55cdf97
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Sat Jul 1 23:17:52 2023 +0400
Merge branch 'master' into iv/bus-crypt
commit a740db82351dcbc40604413df9af210212e1cbc1
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Wed Jun 21 16:08:05 2023 +0400
drop one traceShowId uasge
commit 82de8d8c675cf21e732dc8db9b64139c7c2407ad
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Wed Jun 21 13:33:34 2023 +0400
Edit README.md fix typo
commit ec4dc7733215f19009da9334b82fd568e16eb143
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Wed Jun 21 13:32:54 2023 +0400
Rename deserialiseTrace -> deserialiseCustom
commit 863394449798d8c534c58dc2d69add3e5a807e56
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Thu Jun 15 05:37:52 2023 +0400
PR bus-crypt
commit 78dd65959906944935f99371ee973fc6c2c659b9
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Thu Jun 15 05:33:13 2023 +0400
Drop unused lines
commit 9736077a96061c62e928b657e7c7558f9172636c
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Thu Jun 15 05:24:33 2023 +0400
Encryption works
commit c69aede965242281b525c088e1f27708a6741651
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Wed Jun 14 20:52:48 2023 +0400
wip
commit 88fc2aac5b4fc1d452e74bf99213a57dad09b1c3
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Wed Jun 14 15:52:32 2023 +0400
Test roundtrip combineNonceBS/extractNonce
commit 2d2f6945f4c917347c8f30e195764e2b0837fb25
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Tue Jun 13 14:08:56 2023 +0400
wip
commit 31466fd036d74d8c4b769c7ffb0fa9dfda03eb26
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Tue Jun 13 10:03:15 2023 +0400
trace locked requests
commit 85eb68a6747fb307c07fb0fcf681118250b37fab
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Mon Jun 12 20:02:32 2023 +0400
added Show instances
commit 74383bd7db9dd6838b4d026a3997c5c5b4799fa4
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Mon Jun 12 09:56:14 2023 +0400
DEBUG
commit d62b30dbcdae6584f78cc2b6d8a801ff46cfdfa8
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Sun Jun 11 18:28:49 2023 +0400
wip
commit 78b3f24ae1c4b632756f3a28873f4d03bbaa1330
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Sun Jun 11 08:45:58 2023 +0400
trace encrypted receiveing
commit 93e2b9f7a7c2b579e5e46b6329a6509b8e5119de
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Sat Jun 10 16:57:59 2023 +0400
wip
commit 4686274d0fb401b722fca10ec0c2dbee00a4c68a
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Fri Jun 9 23:38:56 2023 +0400
Use PeerDataExt
commit 0c24c2702b47db262fa086efb6cff108b8ce28e8
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Thu Jun 8 03:04:39 2023 +0400
Encrypted Handshake
commit 789536f20bc4f95320d2a4779a4a5b06d52b98f2
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Wed Jun 7 00:56:34 2023 +0400
Fixed fillPeerMeta timeout algorithm
commit d52ac19777ba1c47f1123c5452309da4391ca21f
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Fri Jun 2 01:50:17 2023 +0400
wip
commit ea6833f812f9f137880229547622a3cf1ae55222
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Tue May 30 22:14:25 2023 +0400
wip
commit 4ffdfc60ccc5c053da2d81ea16847f25f14c6220
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Sat May 27 21:42:01 2023 +0400
Symmetrical encryption in ProxyMessaging
commit 7cd1214e9e00901fcd3d9e2966348dd800ab4119
Author: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Fri May 26 15:03:43 2023 +0400
pex monitor
This commit is contained in:
Dmitry Zuikov
parent
0af3056664
commit
01982d37c1
|
|
@ -258,7 +258,7 @@ keeyring "/path/to/new.key"
|
|||
5. Add git remote and push
|
||||
|
||||
```
|
||||
git add mynerepo hbs2://eq5ZFnB9HQTMTeYasYC3pSZLedcP7Zp2eDkJNdehVVk
|
||||
git remote add mynerepo hbs2://eq5ZFnB9HQTMTeYasYC3pSZLedcP7Zp2eDkJNdehVVk
|
||||
git push mynerepo
|
||||
```
|
||||
|
||||
|
|
|
|||
|
|
@ -1295,3 +1295,11 @@ PR: implement-http-block-download-worker
|
|||
PR: tcp-pex
|
||||
branch: iv/tcp-pex_3
|
||||
commit: f1de7c58d5dc36dec5c318a3297733791de9a3d8
|
||||
|
||||
## 2023-06-15
|
||||
|
||||
PR: bus-crypt
|
||||
branch: iv/bus-crypt
|
||||
Шифрование протокола общения нод.
|
||||
Обмен асимметричными публичными ключами выполняется на стадии хэндшейка в ping/pong.
|
||||
Для шифрования данных создаётся симметричный ключ по diffie-hellman.
|
||||
|
|
|
|||
|
|
@ -53,6 +53,7 @@ common shared-properties
|
|||
, MultiParamTypeClasses
|
||||
, OverloadedStrings
|
||||
, QuasiQuotes
|
||||
, RecordWildCards
|
||||
, ScopedTypeVariables
|
||||
, StandaloneDeriving
|
||||
, TupleSections
|
||||
|
|
@ -69,6 +70,7 @@ library
|
|||
, HBS2.Actors.Peer
|
||||
, HBS2.Base58
|
||||
, HBS2.Clock
|
||||
, HBS2.Crypto
|
||||
, HBS2.Data.Detect
|
||||
, HBS2.Data.Types
|
||||
, HBS2.Data.Types.Crypto
|
||||
|
|
@ -149,9 +151,11 @@ library
|
|||
, stm
|
||||
, stm-chans
|
||||
, streaming
|
||||
, string-conversions
|
||||
, suckless-conf
|
||||
, temporary
|
||||
, text
|
||||
, time
|
||||
, transformers
|
||||
, uniplate
|
||||
, unordered-containers
|
||||
|
|
@ -188,17 +192,21 @@ test-suite test
|
|||
, mtl
|
||||
, prettyprinter
|
||||
, QuickCheck
|
||||
, quickcheck-instances
|
||||
, random
|
||||
, safe
|
||||
, serialise
|
||||
, stm
|
||||
, streaming
|
||||
, tasty
|
||||
, tasty-quickcheck
|
||||
, tasty-hunit
|
||||
, transformers
|
||||
, uniplate
|
||||
, vector
|
||||
, saltine
|
||||
, simple-logger
|
||||
, string-conversions
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@ import HBS2.Clock
|
|||
import HBS2.Defaults
|
||||
import HBS2.Events
|
||||
import HBS2.Hash
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Messaging
|
||||
import HBS2.Net.PeerLocator
|
||||
import HBS2.Net.PeerLocator.Static
|
||||
|
|
@ -17,7 +18,9 @@ import HBS2.Net.Proto
|
|||
import HBS2.Net.Proto.Sessions
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Storage
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Concurrent.Async
|
||||
import Control.Monad.Reader
|
||||
|
|
@ -36,10 +39,13 @@ import Data.HashMap.Strict qualified as HashMap
|
|||
import Control.Concurrent.STM.TVar
|
||||
import Control.Concurrent.STM
|
||||
import Data.Hashable (hash)
|
||||
import Crypto.Saltine.Core.SecretBox qualified as SBox -- Симметричное шифрование с nonce без подписи
|
||||
import Crypto.Saltine.Core.Box qualified as Encrypt -- Асимметричное шифрование без подписи
|
||||
|
||||
import Codec.Serialise (serialise, deserialiseOrFail)
|
||||
|
||||
import Prettyprinter hiding (pipe)
|
||||
-- import Debug.Trace
|
||||
|
||||
|
||||
data AnyStorage = forall zu . ( Block ByteString ~ ByteString
|
||||
|
|
@ -148,6 +154,7 @@ data PeerEnv e =
|
|||
, _envSweepers :: TVar (HashMap SKey [PeerM e IO ()])
|
||||
, _envReqMsgLimit :: Cache (Peer e, Integer, Encoded e) ()
|
||||
, _envReqProtoLimit :: Cache (Peer e, Integer) ()
|
||||
, _envAsymmetricKeyPair :: AsymmKeypair (Encryption e)
|
||||
}
|
||||
|
||||
newtype PeerM e m a = PeerM { fromPeerM :: ReaderT (PeerEnv e) m a }
|
||||
|
|
@ -278,14 +285,16 @@ instance (MonadIO m, HasProtocol e p, Hashable (Encoded e))
|
|||
pure (not here)
|
||||
|
||||
instance ( MonadIO m
|
||||
, HasProtocol e p
|
||||
, HasProtocol e msg
|
||||
, HasFabriq e m -- (PeerM e m)
|
||||
, HasOwnPeer e m
|
||||
, PeerMessaging e
|
||||
, HasTimeLimits e p m
|
||||
) => Request e p m where
|
||||
request p msg = do
|
||||
let proto = protoId @e @p (Proxy @p)
|
||||
, HasTimeLimits e msg m
|
||||
, Show (Peer e)
|
||||
, Show msg
|
||||
) => Request e msg m where
|
||||
request peer_e msg = do
|
||||
let proto = protoId @e @msg (Proxy @msg)
|
||||
pipe <- getFabriq @e
|
||||
me <- ownPeer @e
|
||||
|
||||
|
|
@ -294,12 +303,17 @@ instance ( MonadIO m
|
|||
--
|
||||
-- TODO: where to store the timeout?
|
||||
-- TODO: where the timeout come from?
|
||||
-- withTimeLimit @e @p p msg $ do
|
||||
-- withTimeLimit @e @msg peer_e msg $ do
|
||||
-- liftIO $ print "request!"
|
||||
allowed <- tryLockForPeriod p msg
|
||||
allowed <- tryLockForPeriod peer_e msg
|
||||
|
||||
when (not allowed) do
|
||||
trace $ "REQUEST: not allowed to send" <+> viaShow msg
|
||||
|
||||
when allowed do
|
||||
sendTo pipe (To p) (From me) (AnyMessage @(Encoded e) @e proto (encode msg))
|
||||
sendTo pipe (To peer_e) (From me) (AnyMessage @(Encoded e) @e proto (encode msg))
|
||||
-- trace $ "REQUEST: after sendTo" <+> viaShow peer_e <+> viaShow msg
|
||||
|
||||
|
||||
|
||||
instance ( Typeable (EventHandler e p (PeerM e IO))
|
||||
|
|
@ -383,6 +397,7 @@ newPeerEnv :: forall e m . ( MonadIO m
|
|||
, Ord (Peer e)
|
||||
, Pretty (Peer e)
|
||||
, HasNonces () m
|
||||
, Asymm (Encryption e)
|
||||
)
|
||||
=> AnyStorage
|
||||
-> Fabriq e
|
||||
|
|
@ -390,18 +405,20 @@ newPeerEnv :: forall e m . ( MonadIO m
|
|||
-> m (PeerEnv e)
|
||||
|
||||
newPeerEnv s bus p = do
|
||||
|
||||
pl <- AnyPeerLocator <$> newStaticPeerLocator @e mempty
|
||||
|
||||
nonce <- newNonce @()
|
||||
|
||||
PeerEnv p nonce bus s pl <$> newPipeline defProtoPipelineSize
|
||||
<*> liftIO (Cache.newCache (Just defCookieTimeout))
|
||||
<*> liftIO (newTVarIO mempty)
|
||||
<*> liftIO (Cache.newCache (Just defCookieTimeout))
|
||||
<*> liftIO (newTVarIO mempty)
|
||||
<*> liftIO (Cache.newCache (Just defRequestLimit))
|
||||
<*> liftIO (Cache.newCache (Just defRequestLimit))
|
||||
let _envSelf = p
|
||||
_envPeerNonce <- newNonce @()
|
||||
let _envFab = bus
|
||||
let _envStorage = s
|
||||
_envPeerLocator <- AnyPeerLocator <$> newStaticPeerLocator @e mempty
|
||||
_envDeferred <- newPipeline defProtoPipelineSize
|
||||
_envSessions <- liftIO (Cache.newCache (Just defCookieTimeout))
|
||||
_envEvents <- liftIO (newTVarIO mempty)
|
||||
_envExpireTimes <- liftIO (Cache.newCache (Just defCookieTimeout))
|
||||
_envSweepers <- liftIO (newTVarIO mempty)
|
||||
_envReqMsgLimit <- liftIO (Cache.newCache (Just defRequestLimit))
|
||||
_envReqProtoLimit <- liftIO (Cache.newCache (Just defRequestLimit))
|
||||
_envAsymmetricKeyPair <- asymmNewKeypair @(Encryption e)
|
||||
pure PeerEnv {..}
|
||||
|
||||
runPeerM :: forall e m . ( MonadIO m
|
||||
, HasPeer e
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@ import Control.Monad.IO.Class
|
|||
import Data.Fixed
|
||||
import Data.Int (Int64)
|
||||
import Data.Proxy
|
||||
import Data.Time
|
||||
import Prettyprinter
|
||||
import System.Clock
|
||||
|
||||
|
|
@ -35,6 +36,9 @@ class IsTimeout a where
|
|||
toTimeSpec :: Timeout a -> TimeSpec
|
||||
toTimeSpec x = fromNanoSecs (fromIntegral (toNanoSeconds x))
|
||||
|
||||
toNominalDiffTime :: IsTimeout t => Timeout t -> NominalDiffTime
|
||||
toNominalDiffTime = fromRational . (/ (10^6)) . fromIntegral . toMicroSeconds
|
||||
|
||||
class IsTimeout a => MonadPause a m where
|
||||
pause :: Timeout a -> m ()
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,28 @@
|
|||
module HBS2.Crypto where
|
||||
|
||||
import Control.Monad
|
||||
import Crypto.Saltine.Class as SCl
|
||||
import Crypto.Saltine.Core.Box qualified as Encrypt
|
||||
import Crypto.Saltine.Internal.Box qualified as Encrypt
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.String.Conversions (cs)
|
||||
|
||||
|
||||
combineNonceBS :: Encrypt.Nonce -> ByteString -> ByteString
|
||||
combineNonceBS n = (SCl.encode n <>)
|
||||
|
||||
extractNonce :: ByteString -> Maybe (Encrypt.Nonce, ByteString)
|
||||
extractNonce bs = do
|
||||
let (p,bs') = BS.splitAt Encrypt.box_noncebytes bs
|
||||
guard (BS.length p == Encrypt.box_noncebytes)
|
||||
nonce <- SCl.decode p
|
||||
pure (nonce, bs')
|
||||
|
||||
boxAfterNMLazy :: Encrypt.CombinedKey -> Encrypt.Nonce -> LBS.ByteString -> LBS.ByteString
|
||||
boxAfterNMLazy k n = cs . combineNonceBS n . Encrypt.boxAfterNM k n . cs
|
||||
|
||||
boxOpenAfterNMLazy :: Encrypt.CombinedKey -> Encrypt.Nonce -> ByteString -> Maybe LBS.ByteString
|
||||
boxOpenAfterNMLazy k n = fmap cs . Encrypt.boxOpenAfterNM k n
|
||||
|
|
@ -38,6 +38,15 @@ class Signatures e where
|
|||
makeSign :: PrivKey 'Sign e -> ByteString -> Signature e
|
||||
verifySign :: PubKey 'Sign e -> Signature e -> ByteString -> Bool
|
||||
|
||||
class AsymmPubKey e ~ PubKey 'Encrypt e => Asymm e where
|
||||
type family AsymmKeypair e :: Type
|
||||
type family AsymmPrivKey e :: Type
|
||||
type family AsymmPubKey e :: Type
|
||||
type family CommonSecret e :: Type
|
||||
asymmNewKeypair :: MonadIO m => m (AsymmKeypair e)
|
||||
privKeyFromKeypair :: AsymmKeypair e -> AsymmPrivKey e
|
||||
pubKeyFromKeypair :: AsymmKeypair e -> AsymmPubKey e
|
||||
genCommonSecret :: Asymm e => AsymmPrivKey e -> AsymmPubKey e -> CommonSecret e
|
||||
|
||||
class HasCredentials s m where
|
||||
getCredentials :: m (PeerCredentials s)
|
||||
|
|
|
|||
|
|
@ -42,6 +42,8 @@ instance Serialise (BlockAnnounceInfo e)
|
|||
data BlockAnnounce e = BlockAnnounce PeerNonce (BlockAnnounceInfo e)
|
||||
deriving stock (Generic)
|
||||
|
||||
deriving instance (Show (Nonce ())) => Show (BlockAnnounce e)
|
||||
|
||||
instance Serialise PeerNonce => Serialise (BlockAnnounce e)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -51,14 +51,14 @@ data BlockChunksI e m =
|
|||
|
||||
|
||||
data BlockChunks e = BlockChunks (Cookie e) (BlockChunksProto e)
|
||||
deriving stock (Generic)
|
||||
deriving stock (Generic, Show)
|
||||
|
||||
data BlockChunksProto e = BlockGetAllChunks (Hash HbSync) ChunkSize
|
||||
| BlockGetChunks (Hash HbSync) ChunkSize Word32 Word32
|
||||
| BlockNoChunks
|
||||
| BlockChunk ChunkNum ByteString
|
||||
| BlockLost
|
||||
deriving stock (Generic)
|
||||
deriving stock (Generic, Show)
|
||||
|
||||
|
||||
instance HasCookie e (BlockChunks e) where
|
||||
|
|
|
|||
|
|
@ -21,12 +21,12 @@ import HBS2.Net.Proto.PeerMeta
|
|||
import HBS2.Net.Proto.RefLog
|
||||
import HBS2.Prelude
|
||||
|
||||
import Control.Monad
|
||||
import Data.Functor
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.ByteString qualified as BS
|
||||
import Codec.Serialise (deserialiseOrFail,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
|
||||
|
|
@ -52,10 +52,15 @@ instance Serialise Encrypt.PublicKey
|
|||
instance Serialise Sign.SecretKey
|
||||
instance Serialise Encrypt.SecretKey
|
||||
|
||||
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
|
||||
type instance Encoded L4Proto = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
decode = deserialiseCustom
|
||||
encode = serialise
|
||||
|
||||
-- FIXME: requestMinPeriod-breaks-fast-block-download
|
||||
|
|
@ -65,7 +70,7 @@ instance HasProtocol L4Proto (BlockInfo L4Proto) where
|
|||
instance HasProtocol L4Proto (BlockChunks L4Proto) where
|
||||
type instance ProtocolId (BlockChunks L4Proto) = 2
|
||||
type instance Encoded L4Proto = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
decode = deserialiseCustom
|
||||
encode = serialise
|
||||
|
||||
instance Expires (SessionKey L4Proto (BlockChunks L4Proto)) where
|
||||
|
|
@ -74,13 +79,13 @@ instance Expires (SessionKey L4Proto (BlockChunks L4Proto)) where
|
|||
instance HasProtocol L4Proto (BlockAnnounce L4Proto) where
|
||||
type instance ProtocolId (BlockAnnounce L4Proto) = 3
|
||||
type instance Encoded L4Proto = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
decode = deserialiseCustom
|
||||
encode = serialise
|
||||
|
||||
instance HasProtocol L4Proto (PeerHandshake L4Proto) where
|
||||
type instance ProtocolId (PeerHandshake L4Proto) = 4
|
||||
type instance Encoded L4Proto = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
decode = deserialiseCustom
|
||||
encode = serialise
|
||||
|
||||
requestPeriodLim = ReqLimPerProto 0.5
|
||||
|
|
@ -88,19 +93,19 @@ instance HasProtocol L4Proto (PeerHandshake L4Proto) where
|
|||
instance HasProtocol L4Proto (PeerAnnounce L4Proto) where
|
||||
type instance ProtocolId (PeerAnnounce L4Proto) = 5
|
||||
type instance Encoded L4Proto = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
decode = deserialiseCustom
|
||||
encode = serialise
|
||||
|
||||
instance HasProtocol L4Proto (PeerExchange L4Proto) where
|
||||
type instance ProtocolId (PeerExchange L4Proto) = 6
|
||||
type instance Encoded L4Proto = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
decode = deserialiseCustom
|
||||
encode = serialise
|
||||
|
||||
instance HasProtocol L4Proto (RefLogUpdate L4Proto) where
|
||||
type instance ProtocolId (RefLogUpdate L4Proto) = 7
|
||||
type instance Encoded L4Proto = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
decode = deserialiseCustom
|
||||
encode = serialise
|
||||
|
||||
requestPeriodLim = ReqLimPerMessage 600
|
||||
|
|
@ -108,13 +113,13 @@ instance HasProtocol L4Proto (RefLogUpdate L4Proto) where
|
|||
instance HasProtocol L4Proto (RefLogRequest L4Proto) where
|
||||
type instance ProtocolId (RefLogRequest L4Proto) = 8
|
||||
type instance Encoded L4Proto = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
decode = deserialiseCustom
|
||||
encode = serialise
|
||||
|
||||
instance HasProtocol L4Proto (PeerMetaProto L4Proto) where
|
||||
type instance ProtocolId (PeerMetaProto L4Proto) = 9
|
||||
type instance Encoded L4Proto = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
decode = deserialiseCustom
|
||||
encode = serialise
|
||||
|
||||
-- FIXME: real-period
|
||||
|
|
@ -147,31 +152,31 @@ instance Expires (EventKey L4Proto (PeerMetaProto L4Proto)) where
|
|||
-- instance MonadIO m => HasNonces () m where
|
||||
-- type instance Nonce (PeerHandshake L4Proto) = BS.ByteString
|
||||
-- newNonce = do
|
||||
-- n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
|
||||
-- n <- liftIO ( Encrypt.newNonce <&> Crypto.encode )
|
||||
-- pure $ BS.take 32 n
|
||||
|
||||
instance MonadIO m => HasNonces (PeerHandshake L4Proto) m where
|
||||
type instance Nonce (PeerHandshake L4Proto) = BS.ByteString
|
||||
newNonce = do
|
||||
n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
|
||||
n <- liftIO ( Encrypt.newNonce <&> Crypto.encode )
|
||||
pure $ BS.take 32 n
|
||||
|
||||
instance MonadIO m => HasNonces (PeerExchange L4Proto) m where
|
||||
type instance Nonce (PeerExchange L4Proto) = BS.ByteString
|
||||
newNonce = do
|
||||
n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
|
||||
n <- liftIO ( Encrypt.newNonce <&> Crypto.encode )
|
||||
pure $ BS.take 32 n
|
||||
|
||||
instance MonadIO m => HasNonces (RefLogUpdate L4Proto) m where
|
||||
type instance Nonce (RefLogUpdate L4Proto) = BS.ByteString
|
||||
newNonce = do
|
||||
n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
|
||||
n <- liftIO ( Encrypt.newNonce <&> Crypto.encode )
|
||||
pure $ BS.take 32 n
|
||||
|
||||
instance MonadIO m => HasNonces () m where
|
||||
type instance Nonce () = BS.ByteString
|
||||
newNonce = do
|
||||
n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
|
||||
n <- liftIO ( Encrypt.newNonce <&> Crypto.encode )
|
||||
pure $ BS.take 32 n
|
||||
|
||||
instance Serialise Sign.Signature
|
||||
|
|
@ -181,6 +186,16 @@ instance Signatures HBS2Basic where
|
|||
makeSign = Sign.signDetached
|
||||
verifySign = Sign.signVerifyDetached
|
||||
|
||||
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)
|
||||
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
module HBS2.Net.Proto.Peer where
|
||||
|
||||
-- import HBS2.Base58
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.Data.Types
|
||||
import HBS2.Events
|
||||
import HBS2.Net.Proto
|
||||
|
|
@ -10,13 +11,15 @@ import HBS2.Clock
|
|||
import HBS2.Net.Proto.Sessions
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
-- 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)
|
||||
|
||||
|
|
@ -30,13 +33,36 @@ data PeerData e =
|
|||
}
|
||||
deriving stock (Typeable,Generic)
|
||||
|
||||
deriving instance
|
||||
( Show (PubKey 'Sign (Encryption e))
|
||||
, Show (Nonce ())
|
||||
)
|
||||
=> Show (PeerData e)
|
||||
|
||||
makeLenses 'PeerData
|
||||
|
||||
data PeerDataExt e = PeerDataExt
|
||||
{ _peerData :: PeerData e
|
||||
, _peerEncPubKey :: Maybe (PubKey 'Encrypt (Encryption e))
|
||||
}
|
||||
deriving stock (Typeable,Generic)
|
||||
|
||||
makeLenses 'PeerDataExt
|
||||
|
||||
data PeerHandshake e =
|
||||
PeerPing PingNonce
|
||||
| PeerPong PingNonce (Signature (Encryption e)) (PeerData e)
|
||||
| PeerPingCrypted PingNonce (PubKey 'Encrypt (Encryption e))
|
||||
| PeerPongCrypted PingNonce (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) (PeerData e)
|
||||
deriving stock (Generic)
|
||||
|
||||
deriving instance
|
||||
( Show (PubKey 'Encrypt (Encryption e))
|
||||
, Show (Signature (Encryption e))
|
||||
, Show (PeerData e)
|
||||
)
|
||||
=> Show (PeerHandshake e)
|
||||
|
||||
newtype KnownPeer e = KnownPeer (PeerData e)
|
||||
deriving stock (Typeable,Generic)
|
||||
|
||||
|
|
@ -48,12 +74,13 @@ data PeerPingData e =
|
|||
PeerPingData
|
||||
{ _peerPingNonce :: PingNonce
|
||||
, _peerPingSent :: TimeSpec
|
||||
, _peerPingEncPubKey :: Maybe (PubKey 'Encrypt (Encryption e))
|
||||
}
|
||||
deriving stock (Generic,Typeable)
|
||||
|
||||
makeLenses 'PeerPingData
|
||||
|
||||
type instance SessionData e (KnownPeer e) = PeerData e
|
||||
type instance SessionData e (KnownPeer e) = PeerDataExt e
|
||||
|
||||
newtype instance SessionKey e (PeerHandshake e) =
|
||||
PeerHandshakeKey (PingNonce, Peer e)
|
||||
|
|
@ -82,10 +109,28 @@ sendPing :: forall e m . ( MonadIO m
|
|||
sendPing pip = do
|
||||
nonce <- newNonce @(PeerHandshake e)
|
||||
tt <- liftIO $ getTimeCoarse
|
||||
let pdd = PeerPingData nonce tt
|
||||
let pdd = PeerPingData nonce tt Nothing
|
||||
update pdd (PeerHandshakeKey (nonce,pip)) id
|
||||
request pip (PeerPing @e nonce)
|
||||
|
||||
sendPingCrypted :: forall e m . ( MonadIO m
|
||||
, Request e (PeerHandshake e) m
|
||||
, Sessions e (PeerHandshake e) m
|
||||
, HasNonces (PeerHandshake e) m
|
||||
, Nonce (PeerHandshake e) ~ PingNonce
|
||||
, Pretty (Peer e)
|
||||
, HasProtocol e (PeerHandshake e)
|
||||
, e ~ L4Proto
|
||||
)
|
||||
=> Peer e -> PubKey 'Encrypt (Encryption e) -> m ()
|
||||
|
||||
sendPingCrypted pip pubkey = do
|
||||
nonce <- newNonce @(PeerHandshake e)
|
||||
tt <- liftIO $ getTimeCoarse
|
||||
let pdd = PeerPingData nonce tt (Just pubkey)
|
||||
update pdd (PeerHandshakeKey (nonce,pip)) id
|
||||
request pip (PeerPingCrypted @e nonce pubkey)
|
||||
|
||||
newtype PeerHandshakeAdapter e m =
|
||||
PeerHandshakeAdapter
|
||||
{ onPeerRTT :: (Peer e, Integer) -> m ()
|
||||
|
|
@ -103,15 +148,20 @@ peerHandShakeProto :: forall e s m . ( MonadIO m
|
|||
, Pretty (Peer e)
|
||||
, EventEmitter e (PeerHandshake e) m
|
||||
, EventEmitter e (ConcretePeer e) m
|
||||
, EventEmitter e (PeerAsymmInfo e) m
|
||||
, HasCredentials s m
|
||||
, Asymm s
|
||||
, Signatures s
|
||||
, Serialise (PubKey 'Encrypt (Encryption e))
|
||||
, s ~ Encryption e
|
||||
, e ~ L4Proto
|
||||
)
|
||||
=> PeerHandshakeAdapter e m
|
||||
-> PeerHandshake e -> m ()
|
||||
-> PeerEnv e
|
||||
-> PeerHandshake e
|
||||
-> m ()
|
||||
|
||||
peerHandShakeProto adapter =
|
||||
peerHandShakeProto adapter penv =
|
||||
\case
|
||||
PeerPing nonce -> do
|
||||
pip <- thatPeer proto
|
||||
|
|
@ -138,7 +188,11 @@ peerHandShakeProto adapter =
|
|||
|
||||
se' <- find @e (PeerHandshakeKey (nonce0,pip)) id
|
||||
|
||||
maybe1 se' (pure ()) $ \(PeerPingData nonce t0) -> do
|
||||
maybe1 se' (pure ()) $ \(PeerPingData nonce t0 mpubkey) -> do
|
||||
|
||||
-- Мы отправляли ключ шифрования, но собеседник отказался
|
||||
-- от шифрованной сессии
|
||||
-- when (isJust mpubkey) do
|
||||
|
||||
let pk = view peerSignKey d
|
||||
|
||||
|
|
@ -155,10 +209,76 @@ peerHandShakeProto adapter =
|
|||
|
||||
-- FIXME: check if peer is blacklisted
|
||||
-- right here
|
||||
update d (KnownPeerKey pip) id
|
||||
let pde = PeerDataExt d Nothing
|
||||
update pde (KnownPeerKey pip) id
|
||||
|
||||
emit AnyKnownPeerEventKey (KnownPeerEvent pip d)
|
||||
emit (ConcretePeerKey pip) (ConcretePeerData pip d)
|
||||
emit AnyKnownPeerEventKey (KnownPeerEvent pip pde)
|
||||
emit (ConcretePeerKey pip) (ConcretePeerData pip pde)
|
||||
|
||||
---- Crypted
|
||||
PeerPingCrypted nonce theirpubkey -> do
|
||||
pip <- thatPeer proto
|
||||
trace $ "GOT PING CRYPTED from" <+> pretty pip
|
||||
|
||||
-- взять свои ключи
|
||||
creds <- getCredentials @s
|
||||
|
||||
let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
|
||||
|
||||
-- подписать нонс
|
||||
let sign = makeSign @s (view peerSignSk creds) (nonce <> (cs . serialise) ourpubkey)
|
||||
|
||||
own <- peerNonce @e
|
||||
|
||||
-- отправить обратно вместе с публичным ключом
|
||||
response (PeerPongCrypted @e nonce sign ourpubkey (PeerData (view peerSignPk creds) own))
|
||||
|
||||
-- да и пингануть того самим
|
||||
|
||||
se <- find (KnownPeerKey pip) id <&> isJust
|
||||
|
||||
-- Нужно ли запомнить его theirpubkey или достаточно того, что будет
|
||||
-- получено в обратном PeerPongCrypted?
|
||||
-- Нужно!
|
||||
emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey)
|
||||
|
||||
unless se $ do
|
||||
sendPingCrypted pip ourpubkey
|
||||
|
||||
PeerPongCrypted nonce0 sign theirpubkey pd -> do
|
||||
pip <- thatPeer proto
|
||||
trace $ "GOT PONG CRYPTED from" <+> pretty pip
|
||||
|
||||
se' <- find @e (PeerHandshakeKey (nonce0,pip)) id
|
||||
|
||||
maybe1 se' (pure ()) $ \(PeerPingData nonce t0 mpubkey) -> do
|
||||
|
||||
-- TODO: Мы не отправляли ключ шифрования, а собеседник ответил как будто
|
||||
-- отправляли. Как тут поступать?
|
||||
-- guard (isNothing mpubkey)
|
||||
|
||||
let pk = view peerSignKey pd
|
||||
pde = PeerDataExt pd (Just theirpubkey)
|
||||
|
||||
let signed = verifySign @s pk sign (nonce <> (cs . serialise) theirpubkey)
|
||||
|
||||
when signed $ do
|
||||
|
||||
now <- liftIO getTimeCoarse
|
||||
let rtt = toNanoSecs $ now - t0
|
||||
|
||||
onPeerRTT adapter (pip,rtt)
|
||||
|
||||
expire (PeerHandshakeKey (nonce0,pip))
|
||||
|
||||
-- FIXME: check if peer is blacklisted
|
||||
-- right here
|
||||
update pde (KnownPeerKey pip) id
|
||||
|
||||
emit AnyKnownPeerEventKey (KnownPeerEvent pip pde)
|
||||
emit (ConcretePeerKey pip) (ConcretePeerData pip pde)
|
||||
|
||||
---- /Crypted
|
||||
|
||||
where
|
||||
proto = Proxy @(PeerHandshake e)
|
||||
|
|
@ -173,15 +293,32 @@ deriving stock instance (Eq (Peer e)) => Eq (EventKey e (ConcretePeer e))
|
|||
instance (Hashable (Peer e)) => Hashable (EventKey e (ConcretePeer e))
|
||||
|
||||
data instance Event e (ConcretePeer e) =
|
||||
ConcretePeerData (Peer e) (PeerData e)
|
||||
ConcretePeerData (Peer e) (PeerDataExt e)
|
||||
deriving stock (Typeable)
|
||||
|
||||
---
|
||||
|
||||
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)
|
||||
|
||||
---
|
||||
|
||||
data instance EventKey e (PeerHandshake e) =
|
||||
AnyKnownPeerEventKey
|
||||
deriving stock (Typeable, Eq,Generic)
|
||||
|
||||
data instance Event e (PeerHandshake e) =
|
||||
KnownPeerEvent (Peer e) (PeerData e)
|
||||
KnownPeerEvent (Peer e) (PeerDataExt e)
|
||||
deriving stock (Typeable)
|
||||
|
||||
instance ( Typeable (KnownPeer e)
|
||||
|
|
@ -197,6 +334,9 @@ instance EventType ( Event e ( PeerHandshake e) ) where
|
|||
instance Expires (EventKey e (PeerHandshake e)) where
|
||||
expiresIn _ = Nothing
|
||||
|
||||
instance Expires (EventKey e (PeerAsymmInfo e)) where
|
||||
expiresIn _ = Nothing
|
||||
|
||||
instance Expires (EventKey e (ConcretePeer e)) where
|
||||
expiresIn _ = Just 60
|
||||
|
||||
|
|
@ -209,6 +349,7 @@ deriving instance Eq (Peer e) => Eq (SessionKey e (PeerHandshake e))
|
|||
instance Hashable (Peer e) => Hashable (SessionKey e (PeerHandshake e))
|
||||
|
||||
instance ( Serialise (PubKey 'Sign (Encryption e))
|
||||
, Serialise (PubKey 'Encrypt (Encryption e))
|
||||
, Serialise (Signature (Encryption e))
|
||||
, Serialise PeerNonce
|
||||
)
|
||||
|
|
@ -216,6 +357,7 @@ instance ( Serialise (PubKey 'Sign (Encryption e))
|
|||
=> Serialise (PeerData e)
|
||||
|
||||
instance ( Serialise (PubKey 'Sign (Encryption e))
|
||||
, Serialise (PubKey 'Encrypt (Encryption e))
|
||||
, Serialise (Signature (Encryption e))
|
||||
, Serialise PeerNonce
|
||||
)
|
||||
|
|
|
|||
|
|
@ -30,6 +30,8 @@ newtype PeerAnnounce e =
|
|||
PeerAnnounce PeerNonce
|
||||
deriving stock (Typeable, Generic)
|
||||
|
||||
deriving instance Show (Nonce ()) => Show (PeerAnnounce e)
|
||||
|
||||
|
||||
peerAnnounceProto :: forall e m . ( MonadIO m
|
||||
, EventEmitter e (PeerAnnounce e) m
|
||||
|
|
|
|||
|
|
@ -31,6 +31,11 @@ data PeerExchange e =
|
|||
| PeerExchangePeers2 (Nonce (PeerExchange e)) [PeerAddr e]
|
||||
deriving stock (Generic, Typeable)
|
||||
|
||||
deriving instance
|
||||
( Show (Nonce (PeerExchange e))
|
||||
, Show (PeerAddr e)
|
||||
) => Show (PeerExchange e)
|
||||
|
||||
data PeerExchangePeersEv e
|
||||
|
||||
|
||||
|
|
@ -110,30 +115,47 @@ peerExchangeProto pexFilt msg = do
|
|||
|
||||
case pex of
|
||||
PEX1 -> do
|
||||
|
||||
-- TODO: tcp-peer-support-in-pex
|
||||
pa' <- forM pips $ \p -> do
|
||||
auth <- find (KnownPeerKey p) id <&> isJust
|
||||
pa <- toPeerAddr p
|
||||
case pa of
|
||||
(L4Address UDP x) | auth -> pure [x]
|
||||
_ -> pure mempty
|
||||
|
||||
let pa = take defPexMaxPeers $ mconcat pa'
|
||||
|
||||
pa <- take defPexMaxPeers <$> getAllPex1Peers
|
||||
response (PeerExchangePeers @e n pa)
|
||||
|
||||
PEX2 -> do
|
||||
|
||||
pa' <- forM pips $ \p -> do
|
||||
auth <- find (KnownPeerKey p) id
|
||||
maybe1 auth (pure mempty) ( const $ fmap L.singleton (toPeerAddr p) )
|
||||
|
||||
-- FIXME: asap-random-shuffle-peers
|
||||
let pa = take defPexMaxPeers $ mconcat pa'
|
||||
|
||||
pa <- take defPexMaxPeers <$> getAllPex2Peers
|
||||
response (PeerExchangePeers2 @e n pa)
|
||||
|
||||
getAllPex1Peers :: forall e m .
|
||||
( MonadIO m
|
||||
, Sessions e (KnownPeer e) m
|
||||
, HasPeerLocator L4Proto m
|
||||
, e ~ L4Proto
|
||||
)
|
||||
=> m [IPAddrPort L4Proto]
|
||||
getAllPex1Peers = do
|
||||
pl <- getPeerLocator @e
|
||||
pips <- knownPeers @e pl
|
||||
-- TODO: tcp-peer-support-in-pex
|
||||
pa' <- forM pips $ \p -> do
|
||||
auth <- find (KnownPeerKey p) id <&> isJust
|
||||
pa <- toPeerAddr p
|
||||
case pa of
|
||||
(L4Address UDP x) | auth -> pure [x]
|
||||
_ -> pure mempty
|
||||
pure $ mconcat pa'
|
||||
|
||||
getAllPex2Peers :: forall e m .
|
||||
( MonadIO m
|
||||
, Sessions e (KnownPeer e) m
|
||||
, HasPeerLocator L4Proto m
|
||||
, e ~ L4Proto
|
||||
)
|
||||
=> m [PeerAddr L4Proto]
|
||||
getAllPex2Peers = do
|
||||
pl <- getPeerLocator @e
|
||||
pips <- knownPeers @e pl
|
||||
pa' <- forM pips $ \p -> do
|
||||
auth <- find (KnownPeerKey p) id
|
||||
maybe1 auth (pure mempty) ( const $ fmap L.singleton (toPeerAddr p) )
|
||||
-- FIXME: asap-random-shuffle-peers
|
||||
pure $ mconcat pa'
|
||||
|
||||
newtype instance SessionKey e (PeerExchange e) =
|
||||
PeerExchangeKey (Nonce (PeerExchange e))
|
||||
|
|
|
|||
|
|
@ -27,6 +27,10 @@ data RefLogRequest e =
|
|||
| RefLogResponse (PubKey 'Sign (Encryption e)) (Hash HbSync)
|
||||
deriving stock (Generic)
|
||||
|
||||
deriving instance
|
||||
( Show (PubKey 'Sign (Encryption e))
|
||||
) => Show (RefLogRequest e)
|
||||
|
||||
data RefLogUpdate e =
|
||||
RefLogUpdate
|
||||
{ _refLogId :: PubKey 'Sign (Encryption e)
|
||||
|
|
@ -36,6 +40,12 @@ data RefLogUpdate e =
|
|||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
deriving instance
|
||||
( Show (PubKey 'Sign (Encryption e))
|
||||
, Show (Signature (Encryption e))
|
||||
, Show (Nonce (RefLogUpdate e))
|
||||
) => Show (RefLogUpdate e)
|
||||
|
||||
makeLenses 'RefLogUpdate
|
||||
|
||||
newtype RefLogUpdateI e m =
|
||||
|
|
|
|||
|
|
@ -107,7 +107,8 @@ data ReqLimPeriod = NoLimit
|
|||
| ReqLimPerProto (Timeout 'Seconds)
|
||||
| ReqLimPerMessage (Timeout 'Seconds)
|
||||
|
||||
class (KnownNat (ProtocolId p), HasPeer e) => HasProtocol e p | p -> e where
|
||||
class (KnownNat (ProtocolId p), HasPeer e, Show (Encoded e)
|
||||
) => HasProtocol e p | p -> e where
|
||||
type family ProtocolId p = (id :: Nat) | id -> p
|
||||
type family Encoded e :: Type
|
||||
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@ module Main where
|
|||
import TestFakeMessaging
|
||||
import TestActors
|
||||
-- import TestUniqProtoId
|
||||
import TestCrypto
|
||||
|
||||
import Test.Tasty
|
||||
import Test.Tasty.HUnit
|
||||
|
|
@ -15,6 +16,7 @@ main =
|
|||
testCase "testFakeMessaging1" testFakeMessaging1
|
||||
, testCase "testActorsBasic" testActorsBasic
|
||||
-- , testCase "testUniqProtoId" testUniqProtoId
|
||||
, testCrypto
|
||||
]
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,53 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module TestCrypto where
|
||||
|
||||
import Test.QuickCheck.Instances.ByteString
|
||||
import Test.Tasty
|
||||
import Test.Tasty.QuickCheck as QC
|
||||
|
||||
-- import Control.Monad.Trans.Maybe
|
||||
import Control.Monad
|
||||
import Crypto.Saltine.Class qualified as Saltine
|
||||
import Crypto.Saltine.Core.Box qualified as Encrypt
|
||||
import Crypto.Saltine.Internal.Box qualified as Encrypt
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.Maybe
|
||||
import Data.String.Conversions (cs)
|
||||
|
||||
import HBS2.Crypto
|
||||
|
||||
|
||||
testCrypto :: TestTree
|
||||
testCrypto = testGroup "testCrypto"
|
||||
[ QC.testProperty "roundtripCombineExtractNonce" prop_roundtripCombineExtractNonce
|
||||
, QC.testProperty "roundtripEncodingAfterNM" prop_roundtripEncodingAfterNM
|
||||
]
|
||||
|
||||
instance Arbitrary Encrypt.Nonce where
|
||||
arbitrary = Encrypt.Nonce . BS.pack <$> vectorOf Encrypt.box_noncebytes arbitrary
|
||||
|
||||
instance Arbitrary Encrypt.SecretKey where
|
||||
arbitrary = (fromMaybe (error "Should be Just value") . Saltine.decode)
|
||||
. BS.pack <$> vectorOf Encrypt.box_beforenmbytes arbitrary
|
||||
|
||||
instance Arbitrary Encrypt.PublicKey where
|
||||
arbitrary = (fromMaybe (error "Should be Just value") . Saltine.decode)
|
||||
. BS.pack <$> vectorOf Encrypt.box_beforenmbytes arbitrary
|
||||
|
||||
prop_roundtripCombineExtractNonce :: (Encrypt.Nonce, ByteString) -> Bool
|
||||
prop_roundtripCombineExtractNonce (n, b) =
|
||||
extractNonce (combineNonceBS n b) == Just (n, b)
|
||||
|
||||
prop_roundtripEncodingAfterNM :: (Encrypt.SecretKey, Encrypt.PublicKey, Encrypt.Nonce, ByteString) -> Bool
|
||||
prop_roundtripEncodingAfterNM (sk, pk, n, b) = fromMaybe False do
|
||||
let
|
||||
ck = Encrypt.beforeNM sk pk
|
||||
|
||||
let box = boxAfterNMLazy ck n (cs b)
|
||||
|
||||
(n', x) <- extractNonce (cs box)
|
||||
guard (n' == n)
|
||||
b'' <- boxOpenAfterNMLazy ck n' x
|
||||
|
||||
pure (cs b'' == b)
|
||||
|
|
@ -5,6 +5,7 @@ import HBS2.Actors.Peer
|
|||
import HBS2.Net.Proto.PeerMeta
|
||||
import HBS2.Storage
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Merkle (AnnMetaData)
|
||||
import HBS2.Net.Proto.Types
|
||||
|
||||
import HBS2.System.Logger.Simple
|
||||
|
|
@ -31,9 +32,10 @@ httpWorker :: forall e s m . ( MyPeer e
|
|||
, HasStorage m
|
||||
, IsRefPubKey s
|
||||
, s ~ Encryption e
|
||||
) => PeerConfig -> DownloadEnv e -> m ()
|
||||
)
|
||||
=> PeerConfig -> AnnMetaData -> DownloadEnv e -> m ()
|
||||
|
||||
httpWorker conf e = do
|
||||
httpWorker conf pmeta e = do
|
||||
|
||||
sto <- getStorage
|
||||
let port' = cfgValue @PeerHttpPortKey conf <&> fromIntegral
|
||||
|
|
@ -71,7 +73,7 @@ httpWorker conf e = do
|
|||
text [qc|{pretty val}|]
|
||||
|
||||
get "/metadata" do
|
||||
raw $ serialise $ mkPeerMeta conf
|
||||
raw $ serialise $ pmeta
|
||||
|
||||
put "/" do
|
||||
-- FIXME: optional-header-based-authorization
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@ module PeerInfo where
|
|||
import HBS2.Actors.Peer
|
||||
import HBS2.Clock
|
||||
import HBS2.Events
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.PeerLocator
|
||||
import HBS2.Net.Proto.Peer
|
||||
import HBS2.Net.Proto.PeerExchange
|
||||
|
|
@ -145,8 +146,8 @@ peerPingLoop :: forall e m . ( HasPeerLocator e m
|
|||
, m ~ PeerM e IO
|
||||
, e ~ L4Proto
|
||||
)
|
||||
=> PeerConfig -> m ()
|
||||
peerPingLoop cfg = do
|
||||
=> PeerConfig -> PeerEnv e -> m ()
|
||||
peerPingLoop cfg penv = do
|
||||
|
||||
e <- ask
|
||||
|
||||
|
|
@ -240,7 +241,18 @@ peerPingLoop cfg = do
|
|||
pips <- knownPeers @e pl <&> (<> sas) <&> List.nub
|
||||
|
||||
for_ pips $ \p -> do
|
||||
trace $ "SEND PING TO" <+> pretty p
|
||||
-- trace $ "SEND PING TO" <+> pretty p
|
||||
sendPing @e p
|
||||
-- trace $ "SENT PING TO" <+> pretty p
|
||||
pause dt
|
||||
sendPingCrypted @e p
|
||||
(pubKeyFromKeypair @(Encryption e) (view envAsymmetricKeyPair penv))
|
||||
-- trace $ "SENT PING CRYPTED TO" <+> pretty p
|
||||
|
||||
where
|
||||
dt = case (requestPeriodLim @e @(PeerHandshake e)) of
|
||||
NoLimit -> 0
|
||||
ReqLimPerProto t -> t + 0.1
|
||||
ReqLimPerMessage t -> t + 0.1
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -15,10 +15,11 @@ import HBS2.Data.Types.Refs (RefLogKey(..))
|
|||
import HBS2.Merkle
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.IP.Addr
|
||||
import HBS2.Net.Messaging
|
||||
import HBS2.Net.Messaging.UDP
|
||||
import HBS2.Net.Messaging.TCP
|
||||
import HBS2.Net.PeerLocator
|
||||
import HBS2.Net.Proto
|
||||
import HBS2.Net.Proto as Proto
|
||||
import HBS2.Net.Proto.Definition
|
||||
import HBS2.Net.Proto.Peer
|
||||
import HBS2.Net.Proto.PeerAnnounce
|
||||
|
|
@ -49,7 +50,7 @@ import HttpWorker
|
|||
import ProxyMessaging
|
||||
import PeerMeta
|
||||
|
||||
import Codec.Serialise
|
||||
import Codec.Serialise as Serialise
|
||||
-- import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception as Exception
|
||||
|
|
@ -62,7 +63,8 @@ import Data.ByteString.Lazy qualified as LBS
|
|||
import Data.ByteString qualified as BS
|
||||
import Data.Cache qualified as Cache
|
||||
import Data.Function
|
||||
import Data.List qualified as L
|
||||
import Data.List qualified as L
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as Map
|
||||
import Data.Maybe
|
||||
import Data.Set qualified as Set
|
||||
|
|
@ -73,7 +75,7 @@ import Data.Text (Text)
|
|||
import Data.HashSet qualified as HashSet
|
||||
import GHC.Stats
|
||||
import GHC.TypeLits
|
||||
import Lens.Micro.Platform
|
||||
import Lens.Micro.Platform as Lens
|
||||
import Network.Socket
|
||||
import Options.Applicative
|
||||
import System.Directory
|
||||
|
|
@ -83,6 +85,7 @@ import System.Mem
|
|||
import System.Metrics
|
||||
import System.Posix.Process
|
||||
import System.Environment
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
|
||||
import UnliftIO.Exception qualified as U
|
||||
-- import UnliftIO.STM
|
||||
|
|
@ -177,6 +180,7 @@ data RPCCommand =
|
|||
| CHECK PeerNonce (PeerAddr L4Proto) (Hash HbSync)
|
||||
| FETCH (Hash HbSync)
|
||||
| PEERS
|
||||
| PEXINFO
|
||||
| SETLOG SetLogging
|
||||
| REFLOGUPDATE ByteString
|
||||
| REFLOGFETCH (PubKey 'Sign (Encryption L4Proto))
|
||||
|
|
@ -245,6 +249,7 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
|
|||
<> command "fetch" (info pFetch (progDesc "fetch block"))
|
||||
<> command "reflog" (info pRefLog (progDesc "reflog commands"))
|
||||
<> command "peers" (info pPeers (progDesc "show known peers"))
|
||||
<> command "pexinfo" (info pPexInfo (progDesc "show pex"))
|
||||
<> command "log" (info pLog (progDesc "set logging level"))
|
||||
)
|
||||
|
||||
|
|
@ -306,6 +311,10 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
|
|||
rpc <- pRpcCommon
|
||||
pure $ runRpcCommand rpc PEERS
|
||||
|
||||
pPexInfo = do
|
||||
rpc <- pRpcCommon
|
||||
pure $ runRpcCommand rpc PEXINFO
|
||||
|
||||
onOff l =
|
||||
hsubparser ( command "on" (info (pure (l True) ) (progDesc "on") ) )
|
||||
<|> hsubparser ( command "off" (info (pure (l False) ) (progDesc "off") ) )
|
||||
|
|
@ -496,16 +505,16 @@ runPeer opts = U.handle (\e -> myException e
|
|||
liftIO $ print $ pretty accptAnn
|
||||
|
||||
-- FIXME: move-peerBanned-somewhere
|
||||
let peerBanned p d = do
|
||||
let k = view peerSignKey d
|
||||
let peerBanned p pd = do
|
||||
let k = view peerSignKey pd
|
||||
let blacklisted = k `Set.member` blkeys
|
||||
let whitelisted = Set.null wlkeys || (k `Set.member` wlkeys)
|
||||
pure $ blacklisted || not whitelisted
|
||||
|
||||
let acceptAnnounce p d = do
|
||||
let acceptAnnounce p pd = do
|
||||
case accptAnn of
|
||||
AcceptAnnounceAll -> pure True
|
||||
AcceptAnnounceFrom s -> pure $ view peerSignKey d `Set.member` s
|
||||
AcceptAnnounceFrom s -> pure $ view peerSignKey pd `Set.member` s
|
||||
|
||||
rpcQ <- liftIO $ newTQueueIO @RPCCommand
|
||||
|
||||
|
|
@ -571,6 +580,8 @@ runPeer opts = U.handle (\e -> myException e
|
|||
|
||||
penv <- newPeerEnv (AnyStorage s) (Fabriq proxy) (getOwnPeer mess)
|
||||
|
||||
let peerMeta = mkPeerMeta conf penv
|
||||
|
||||
nbcache <- liftIO $ Cache.newCache (Just $ toTimeSpec ( 600 :: Timeout 'Seconds))
|
||||
|
||||
void $ async $ forever do
|
||||
|
|
@ -590,8 +601,8 @@ runPeer opts = U.handle (\e -> myException e
|
|||
let onNoBlock (p, h) = do
|
||||
already <- liftIO $ Cache.lookup nbcache (p,h) <&> isJust
|
||||
unless already do
|
||||
pd' <- find (KnownPeerKey p) id
|
||||
maybe1 pd' none $ \pd -> do
|
||||
mpde <- find (KnownPeerKey p) id
|
||||
maybe1 mpde none $ \pde@(PeerDataExt {_peerData = pd}) -> do
|
||||
let pk = view peerSignKey pd
|
||||
when (Set.member pk helpFetchKeys) do
|
||||
liftIO $ Cache.insert nbcache (p,h) ()
|
||||
|
|
@ -644,26 +655,40 @@ runPeer opts = U.handle (\e -> myException e
|
|||
subscribe @e PeerAnnounceEventKey $ \(PeerAnnounceEvent pip nonce) -> do
|
||||
unless (nonce == pnonce) $ do
|
||||
debug $ "Got peer announce!" <+> pretty pip
|
||||
pd <- find (KnownPeerKey pip) id -- <&> isJust
|
||||
banned <- maybe (pure False) (peerBanned pip) pd
|
||||
let known = isJust pd && not banned
|
||||
mpde :: Maybe (PeerDataExt e) <- find (KnownPeerKey pip) id
|
||||
banned <- maybe (pure False) (peerBanned pip . view peerData) mpde
|
||||
let known = isJust mpde && not banned
|
||||
sendPing pip
|
||||
|
||||
subscribe @e BlockAnnounceInfoKey $ \(BlockAnnounceEvent p bi no) -> do
|
||||
pa <- toPeerAddr p
|
||||
liftIO $ atomically $ writeTQueue rpcQ (CHECK no pa (view biHash bi))
|
||||
|
||||
subscribe @e AnyKnownPeerEventKey $ \(KnownPeerEvent p d) -> do
|
||||
subscribe @e PeerAsymmInfoKey $ \(PeerAsymmPubKey p peerpubkey) -> do
|
||||
defPeerInfo <- newPeerInfo
|
||||
fetch True defPeerInfo (PeerInfoKey p) id >>= \pinfo -> do
|
||||
let updj = genCommonSecret @s (privKeyFromKeypair @s (view envAsymmetricKeyPair penv))
|
||||
$ peerpubkey
|
||||
liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys proxy) $ Lens.at p .~ Just updj
|
||||
liftIO $ trace [qc| UPDJust from PeerAsymmInfoKey at {p} {updj} |]
|
||||
|
||||
let thatNonce = view peerOwnNonce d
|
||||
subscribe @e AnyKnownPeerEventKey $ \(KnownPeerEvent p pde@(PeerDataExt{_peerData = pd})) -> do
|
||||
|
||||
let thatNonce = view peerOwnNonce pd
|
||||
|
||||
now <- liftIO getTimeCoarse
|
||||
pinfo' <- find (PeerInfoKey p) id -- (view peerPingFailed)
|
||||
maybe1 pinfo' none $ \pinfo -> do
|
||||
liftIO $ atomically $ writeTVar (view peerPingFailed pinfo) 0
|
||||
liftIO $ atomically $ writeTVar (view peerLastWatched pinfo) now
|
||||
|
||||
banned <- peerBanned p d
|
||||
defPeerInfo <- newPeerInfo
|
||||
fetch True defPeerInfo (PeerInfoKey p) id >>= \pinfo -> do
|
||||
liftIO $ atomically $ writeTVar (view peerPingFailed pinfo) 0
|
||||
liftIO $ atomically $ writeTVar (view peerLastWatched pinfo) now
|
||||
let mupd = genCommonSecret @s (privKeyFromKeypair @s (view envAsymmetricKeyPair penv))
|
||||
<$> view peerEncPubKey pde
|
||||
forM_ mupd \upd -> do
|
||||
liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys proxy) $ Lens.at p .~ Just upd
|
||||
liftIO $ trace [qc| UPDJust from AnyKnownPeerEventKey at {p} {upd} |]
|
||||
|
||||
banned <- peerBanned p pd
|
||||
|
||||
let doAddPeer p = do
|
||||
addPeers pl [p]
|
||||
|
|
@ -675,7 +700,7 @@ runPeer opts = U.handle (\e -> myException e
|
|||
|
||||
unless here do
|
||||
debug $ "Got authorized peer!" <+> pretty p
|
||||
<+> pretty (AsBase58 (view peerSignKey d))
|
||||
<+> pretty (AsBase58 (view peerSignKey pd))
|
||||
request @e p (GetPeerMeta @e)
|
||||
|
||||
|
||||
|
|
@ -691,14 +716,11 @@ runPeer opts = U.handle (\e -> myException e
|
|||
|
||||
| otherwise -> do
|
||||
|
||||
update d (KnownPeerKey p) id
|
||||
update pde (KnownPeerKey p) id
|
||||
|
||||
pd' <- knownPeers @e pl >>=
|
||||
\peers -> forM peers $ \pip -> do
|
||||
pd <- find (KnownPeerKey pip) (view peerOwnNonce)
|
||||
pure $ (,pip) <$> pd
|
||||
|
||||
let pd = Map.fromList $ catMaybes pd'
|
||||
pd :: Map BS.ByteString (Peer L4Proto) <- fmap (Map.fromList . catMaybes)
|
||||
$ knownPeers @e pl >>= mapM \pip ->
|
||||
fmap (, pip) <$> find (KnownPeerKey pip) (view (peerData . peerOwnNonce))
|
||||
|
||||
let proto1 = view sockType p
|
||||
|
||||
|
|
@ -767,11 +789,11 @@ runPeer opts = U.handle (\e -> myException e
|
|||
|
||||
-- peerThread "tcpWorker" (tcpWorker conf)
|
||||
|
||||
peerThread "httpWorker" (httpWorker conf denv)
|
||||
peerThread "httpWorker" (httpWorker conf peerMeta denv)
|
||||
|
||||
peerThread "checkMetrics" (checkMetrics metrics)
|
||||
|
||||
peerThread "peerPingLoop" (peerPingLoop @e conf)
|
||||
peerThread "peerPingLoop" (peerPingLoop @e conf penv)
|
||||
|
||||
peerThread "knownPeersPingLoop" (knownPeersPingLoop @e conf)
|
||||
|
||||
|
|
@ -805,13 +827,64 @@ runPeer opts = U.handle (\e -> myException e
|
|||
PING pa r -> do
|
||||
debug $ "ping" <+> pretty pa
|
||||
pip <- fromPeerAddr @e pa
|
||||
subscribe (ConcretePeerKey pip) $ \(ConcretePeerData{}) -> do
|
||||
subscribe (ConcretePeerKey pip) $ \(ConcretePeerData _ pde) -> do
|
||||
|
||||
maybe1 r (pure ()) $ \rpcPeer -> do
|
||||
pinged <- toPeerAddr pip
|
||||
request rpcPeer (RPCPong @e pinged)
|
||||
-- case (view peerEncPubKey pde) of
|
||||
-- Nothing -> unencrypted ping
|
||||
-- Just pubkey -> encryptengd
|
||||
|
||||
sendPing pip
|
||||
let
|
||||
requestPlain :: forall m msg .
|
||||
( MonadIO m
|
||||
-- , HasProtocol L4Proto msg
|
||||
, msg ~ PeerHandshake L4Proto
|
||||
, HasOwnPeer L4Proto m
|
||||
-- , Messaging MessagingTCP L4Proto (AnyMessage ByteString L4Proto)
|
||||
-- , Messaging MessagingUDP L4Proto (AnyMessage ByteString L4Proto)
|
||||
, HasTimeLimits L4Proto (PeerHandshake L4Proto) m
|
||||
) => Peer e -> msg -> m ()
|
||||
requestPlain peer_e msg = do
|
||||
let protoN = protoId @e @msg (Proxy @msg)
|
||||
me <- ownPeer @e
|
||||
|
||||
allowed <- tryLockForPeriod peer_e msg
|
||||
|
||||
when (not allowed) do
|
||||
trace $ "REQUEST: not allowed to send" <+> viaShow msg
|
||||
|
||||
-- when allowed do
|
||||
-- sendTo proxy (To peer_e) (From me) (AnyMessage @(Encoded e) @e protoN (encode msg))
|
||||
|
||||
when allowed do
|
||||
sendToPlainProxyMessaging (PlainProxyMessaging proxy) (To peer_e) (From me)
|
||||
-- (AnyMessage @(Encoded e) @e protoN (Proto.encode msg))
|
||||
(serialise (protoN, (Proto.encode msg)))
|
||||
|
||||
let
|
||||
sendPingCrypted' pip pubkey = do
|
||||
nonce <- newNonce @(PeerHandshake e)
|
||||
tt <- liftIO $ getTimeCoarse
|
||||
let pdd = PeerPingData nonce tt (Just pubkey)
|
||||
update pdd (PeerHandshakeKey (nonce,pip)) id
|
||||
requestPlain pip (PeerPingCrypted @e nonce pubkey)
|
||||
|
||||
let
|
||||
sendPing' pip = do
|
||||
nonce <- newNonce @(PeerHandshake e)
|
||||
tt <- liftIO $ getTimeCoarse
|
||||
let pdd = PeerPingData nonce tt Nothing
|
||||
update pdd (PeerHandshakeKey (nonce,pip)) id
|
||||
requestPlain pip (PeerPing @e nonce)
|
||||
|
||||
sendPingCrypted' pip (pubKeyFromKeypair @s (view envAsymmetricKeyPair penv))
|
||||
pause $ case (requestPeriodLim @e @(PeerHandshake e)) of
|
||||
NoLimit -> 0
|
||||
ReqLimPerProto t -> t + 0.1
|
||||
ReqLimPerMessage t -> t + 0.1
|
||||
sendPing' pip
|
||||
|
||||
ANNOUNCE h -> do
|
||||
debug $ "got announce rpc" <+> pretty h
|
||||
|
|
@ -839,18 +912,18 @@ runPeer opts = U.handle (\e -> myException e
|
|||
|
||||
unless (nonce == n1) do
|
||||
|
||||
peer <- find @e (KnownPeerKey pip) id
|
||||
mpde <- find @e (KnownPeerKey pip) id
|
||||
|
||||
debug $ "received announce from"
|
||||
<+> pretty pip
|
||||
<+> pretty h
|
||||
|
||||
case peer of
|
||||
case mpde of
|
||||
Nothing -> do
|
||||
sendPing @e pip
|
||||
-- TODO: enqueue-announce-from-unknown-peer?
|
||||
|
||||
Just pd -> do
|
||||
Just (pde@(PeerDataExt {_peerData = pd})) -> do
|
||||
|
||||
banned <- peerBanned pip pd
|
||||
|
||||
|
|
@ -893,11 +966,11 @@ runPeer opts = U.handle (\e -> myException e
|
|||
[ makeResponse (blockSizeProto blk dontHandle onNoBlock)
|
||||
, makeResponse (blockChunksProto adapter)
|
||||
, makeResponse blockAnnounceProto
|
||||
, makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter)
|
||||
, makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter penv)
|
||||
, makeResponse (peerExchangeProto pexFilt)
|
||||
, makeResponse (refLogUpdateProto reflogAdapter)
|
||||
, makeResponse (refLogRequestProto reflogReqAdapter)
|
||||
, makeResponse (peerMetaProto (mkPeerMeta conf))
|
||||
, makeResponse (peerMetaProto peerMeta)
|
||||
]
|
||||
|
||||
void $ liftIO $ waitAnyCancel workers
|
||||
|
|
@ -941,11 +1014,19 @@ runPeer opts = U.handle (\e -> myException e
|
|||
let peersAction _ = do
|
||||
who <- thatPeer (Proxy @(RPC e))
|
||||
void $ liftIO $ async $ withPeerM penv $ do
|
||||
forKnownPeers @e $ \p pd -> do
|
||||
forKnownPeers @e $ \p pde -> do
|
||||
pa <- toPeerAddr p
|
||||
let k = view peerSignKey pd
|
||||
let k = view (peerData . peerSignKey) pde
|
||||
request who (RPCPeersAnswer @e pa k)
|
||||
|
||||
let pexInfoAction :: RPC L4Proto -> ResponseM L4Proto (RpcM (ResourceT IO)) ()
|
||||
pexInfoAction _ = do
|
||||
who <- thatPeer (Proxy @(RPC e))
|
||||
void $ liftIO $ async $ withPeerM penv $ do
|
||||
-- FIXME: filter-pexinfo-entries
|
||||
ps <- getAllPex2Peers
|
||||
request who (RPCPexInfoAnswer @e ps)
|
||||
|
||||
let logLevelAction = \case
|
||||
DebugOn True -> do
|
||||
setLogging @DEBUG debugPrefix
|
||||
|
|
@ -981,21 +1062,25 @@ runPeer opts = U.handle (\e -> myException e
|
|||
h <- liftIO $ getRef sto (RefLogKey @(Encryption e) puk)
|
||||
request who (RPCRefLogGetAnswer @e h)
|
||||
|
||||
let arpc = RpcAdapter pokeAction
|
||||
dieAction
|
||||
dontHandle
|
||||
dontHandle
|
||||
annAction
|
||||
pingAction
|
||||
dontHandle
|
||||
fetchAction
|
||||
peersAction
|
||||
dontHandle
|
||||
logLevelAction
|
||||
reflogUpdateAction
|
||||
reflogFetchAction
|
||||
reflogGetAction
|
||||
dontHandle
|
||||
let arpc = RpcAdapter
|
||||
{ rpcOnPoke = pokeAction
|
||||
, rpcOnDie = dieAction
|
||||
, rpcOnPokeAnswer = dontHandle
|
||||
, rpcOnPokeAnswerFull = dontHandle
|
||||
, rpcOnAnnounce = annAction
|
||||
, rpcOnPing = pingAction
|
||||
, rpcOnPong = dontHandle
|
||||
, rpcOnFetch = fetchAction
|
||||
, rpcOnPeers = peersAction
|
||||
, rpcOnPeersAnswer = dontHandle
|
||||
, rpcOnPexInfo = pexInfoAction
|
||||
, rpcOnPexInfoAnswer = dontHandle
|
||||
, rpcOnLogLevel = logLevelAction
|
||||
, rpcOnRefLogUpdate = reflogUpdateAction
|
||||
, rpcOnRefLogFetch = reflogFetchAction
|
||||
, rpcOnRefLogGet = reflogGetAction
|
||||
, rpcOnRefLogGetAnsw = dontHandle
|
||||
}
|
||||
|
||||
rpc <- async $ runRPC udp1 do
|
||||
runProto @e
|
||||
|
|
@ -1071,26 +1156,25 @@ withRPC o cmd = rpcClientMain o $ runResourceT do
|
|||
|
||||
refQ <- liftIO newTQueueIO
|
||||
|
||||
let adapter =
|
||||
RpcAdapter dontHandle
|
||||
dontHandle
|
||||
(liftIO . atomically . writeTQueue pokeQ)
|
||||
(liftIO . atomically . writeTQueue pokeFQ)
|
||||
(const $ liftIO exitSuccess)
|
||||
(const $ notice "ping?")
|
||||
(liftIO . atomically . writeTQueue pingQ)
|
||||
dontHandle
|
||||
dontHandle
|
||||
|
||||
(\(pa, k) -> Log.info $ pretty (AsBase58 k) <+> pretty pa
|
||||
)
|
||||
|
||||
dontHandle
|
||||
dontHandle
|
||||
dontHandle
|
||||
dontHandle
|
||||
|
||||
( liftIO . atomically . writeTQueue refQ )
|
||||
let adapter = RpcAdapter
|
||||
{ rpcOnPoke = dontHandle
|
||||
, rpcOnDie = dontHandle
|
||||
, rpcOnPokeAnswer = (liftIO . atomically . writeTQueue pokeQ)
|
||||
, rpcOnPokeAnswerFull = (liftIO . atomically . writeTQueue pokeFQ)
|
||||
, rpcOnAnnounce = (const $ liftIO exitSuccess)
|
||||
, rpcOnPing = (const $ notice "ping?")
|
||||
, rpcOnPong = (liftIO . atomically . writeTQueue pingQ)
|
||||
, rpcOnFetch = dontHandle
|
||||
, rpcOnPeers = dontHandle
|
||||
, rpcOnPeersAnswer = (\(pa, k) -> Log.info $ pretty (AsBase58 k) <+> pretty pa)
|
||||
, rpcOnPexInfo = dontHandle
|
||||
, rpcOnPexInfoAnswer = (\ps -> mapM_ (Log.info . pretty) ps)
|
||||
, rpcOnLogLevel = dontHandle
|
||||
, rpcOnRefLogUpdate = dontHandle
|
||||
, rpcOnRefLogFetch = dontHandle
|
||||
, rpcOnRefLogGet = dontHandle
|
||||
, rpcOnRefLogGetAnsw = ( liftIO . atomically . writeTQueue refQ )
|
||||
}
|
||||
|
||||
prpc <- async $ runRPC udp1 do
|
||||
env <- ask
|
||||
|
|
@ -1132,6 +1216,10 @@ withRPC o cmd = rpcClientMain o $ runResourceT do
|
|||
pause @'Seconds 1
|
||||
exitSuccess
|
||||
|
||||
RPCPexInfo{} -> liftIO do
|
||||
pause @'Seconds 1
|
||||
exitSuccess
|
||||
|
||||
RPCLogLevel{} -> liftIO exitSuccess
|
||||
|
||||
RPCRefLogUpdate{} -> liftIO do
|
||||
|
|
@ -1166,6 +1254,7 @@ runRpcCommand opt = \case
|
|||
ANNOUNCE h -> withRPC opt (RPCAnnounce h)
|
||||
FETCH h -> withRPC opt (RPCFetch h)
|
||||
PEERS -> withRPC opt RPCPeers
|
||||
PEXINFO -> withRPC opt RPCPexInfo
|
||||
SETLOG s -> withRPC opt (RPCLogLevel s)
|
||||
REFLOGUPDATE bs -> withRPC opt (RPCRefLogUpdate bs)
|
||||
REFLOGFETCH k -> withRPC opt (RPCRefLogFetch k)
|
||||
|
|
|
|||
|
|
@ -21,12 +21,16 @@ import Control.Concurrent.Async
|
|||
import Control.Concurrent.STM
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.State.Strict qualified as State
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Foldable hiding (find)
|
||||
import Data.HashMap.Strict qualified as HashMap
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Maybe
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.Encoding qualified as TE
|
||||
import Data.Time
|
||||
import Data.Word
|
||||
import Lens.Micro.Platform
|
||||
import Network.HTTP.Simple (getResponseBody, httpLbs, parseRequest, getResponseStatus)
|
||||
|
|
@ -53,14 +57,24 @@ fillPeerMeta mtcp probePeriod = do
|
|||
debug "I'm fillPeerMeta"
|
||||
pl <- getPeerLocator @e
|
||||
|
||||
pause @'Seconds 10 -- wait 'till everything calm down
|
||||
pause @'Seconds 5 -- wait 'till everything calm down
|
||||
flip State.evalStateT Map.empty $ forever do
|
||||
pause @'Seconds 12
|
||||
|
||||
forever $ (>> pause probePeriod) $ do
|
||||
ps <- knownPeers pl
|
||||
now <- liftIO getCurrentTime
|
||||
let pss = Set.fromList ps
|
||||
psActual <- Map.filterWithKey (\k _ -> k `Set.member` pss) <$> State.get
|
||||
let psNew = pss Set.\\ (Map.keysSet psActual)
|
||||
let psReady = Map.keysSet . Map.filter (\t -> t < now) $ psActual
|
||||
let ps' = Set.toList (psNew <> psReady)
|
||||
(State.put . (<> psActual) . Map.fromList) $
|
||||
(, now & addUTCTime (toNominalDiffTime probePeriod)) <$> ps'
|
||||
|
||||
ps <- knownPeers @e pl
|
||||
debug $ "fillPeerMeta peers:" <+> pretty ps
|
||||
npi <- newPeerInfo
|
||||
for_ ps $ \p -> do
|
||||
when ((not . null) ps') $ lift do
|
||||
debug $ "fillPeerMeta peers:" <+> pretty ps'
|
||||
for_ ps' $ \p -> do
|
||||
npi <- newPeerInfo
|
||||
|
||||
pinfo <- fetch True npi (PeerInfoKey p) id
|
||||
mmApiAddr <- liftIO $ readTVarIO (_peerHttpApiAddress pinfo)
|
||||
|
|
|
|||
|
|
@ -9,6 +9,8 @@ import HBS2.Clock
|
|||
import HBS2.Defaults
|
||||
import HBS2.Events
|
||||
import HBS2.Hash
|
||||
import HBS2.Merkle (AnnMetaData)
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.IP.Addr
|
||||
import HBS2.Net.Proto
|
||||
import HBS2.Net.Proto.Peer
|
||||
|
|
@ -29,12 +31,15 @@ import Data.Foldable (for_)
|
|||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Writer qualified as W
|
||||
import Crypto.Saltine.Core.Box qualified as Encrypt
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.Cache (Cache)
|
||||
import Data.Cache qualified as Cache
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HashMap
|
||||
import Data.List qualified as L
|
||||
import Data.Maybe
|
||||
import Lens.Micro.Platform
|
||||
import Data.Hashable
|
||||
|
|
@ -43,6 +48,7 @@ import Data.IntMap (IntMap)
|
|||
import Data.IntSet (IntSet)
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.Encoding qualified as TE
|
||||
import Data.Word
|
||||
|
||||
|
||||
data PeerInfo e =
|
||||
|
|
@ -72,23 +78,25 @@ makeLenses 'PeerInfo
|
|||
|
||||
newPeerInfo :: MonadIO m => m (PeerInfo e)
|
||||
newPeerInfo = liftIO do
|
||||
PeerInfo <$> newTVarIO defBurst
|
||||
<*> newTVarIO Nothing
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO []
|
||||
<*> newTVarIO (Left 0)
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO Nothing
|
||||
_peerBurst <- newTVarIO defBurst
|
||||
_peerBurstMax <- newTVarIO Nothing
|
||||
_peerBurstSet <- newTVarIO mempty
|
||||
_peerErrors <- newTVarIO 0
|
||||
_peerErrorsLast <- newTVarIO 0
|
||||
_peerErrorsPerSec <- newTVarIO 0
|
||||
_peerLastWatched <- newTVarIO 0
|
||||
_peerDownloaded <- newTVarIO 0
|
||||
_peerDownloadedLast <- newTVarIO 0
|
||||
_peerPingFailed <- newTVarIO 0
|
||||
_peerDownloadedBlk <- newTVarIO 0
|
||||
_peerDownloadFail <- newTVarIO 0
|
||||
_peerDownloadMiss <- newTVarIO 0
|
||||
_peerRTTBuffer <- newTVarIO []
|
||||
-- Acts like a circular buffer.
|
||||
_peerHttpApiAddress <- newTVarIO (Left 0)
|
||||
_peerHttpDownloaded <- newTVarIO 0
|
||||
_peerMeta <- newTVarIO Nothing
|
||||
pure PeerInfo {..}
|
||||
|
||||
type instance SessionData e (PeerInfo e) = PeerInfo e
|
||||
|
||||
|
|
@ -351,13 +359,13 @@ forKnownPeers :: forall e m . ( MonadIO m
|
|||
, Sessions e (KnownPeer e) m
|
||||
, HasPeer e
|
||||
)
|
||||
=> ( Peer e -> PeerData e -> m () ) -> m ()
|
||||
=> ( Peer e -> PeerDataExt e -> m () ) -> m ()
|
||||
forKnownPeers m = do
|
||||
pl <- getPeerLocator @e
|
||||
pips <- knownPeers @e pl
|
||||
for_ pips $ \p -> do
|
||||
pd' <- find (KnownPeerKey p) id
|
||||
maybe1 pd' (pure ()) (m p)
|
||||
mpde <- find (KnownPeerKey p) id
|
||||
maybe1 mpde (pure ()) (m p)
|
||||
|
||||
getKnownPeers :: forall e m . ( MonadIO m
|
||||
, HasPeerLocator e m
|
||||
|
|
@ -374,16 +382,27 @@ getKnownPeers = do
|
|||
maybe1 pd' (pure mempty) (const $ pure [p])
|
||||
pure $ mconcat r
|
||||
|
||||
mkPeerMeta conf = do
|
||||
let mHttpPort = cfgValue @PeerHttpPortKey conf <&> fromIntegral
|
||||
let mTcpPort =
|
||||
mkPeerMeta :: PeerConfig -> PeerEnv e -> AnnMetaData
|
||||
mkPeerMeta conf penv = do
|
||||
let mHttpPort :: Maybe Integer
|
||||
mHttpPort = cfgValue @PeerHttpPortKey conf <&> fromIntegral
|
||||
let mTcpPort :: Maybe Word16
|
||||
mTcpPort =
|
||||
(
|
||||
fmap (\(L4Address _ (IPAddrPort (_, p))) -> p)
|
||||
. fromStringMay @(PeerAddr L4Proto)
|
||||
)
|
||||
=<< cfgValue @PeerListenTCPKey conf
|
||||
annMetaFromPeerMeta . PeerMeta . catMaybes $
|
||||
[ mHttpPort <&> \p -> ("http-port", TE.encodeUtf8 . Text.pack . show $ p)
|
||||
, mTcpPort <&> \p -> ("listen-tcp", TE.encodeUtf8 . Text.pack . show $ p)
|
||||
]
|
||||
-- let useEncryption = True -- move to config
|
||||
annMetaFromPeerMeta . PeerMeta $ W.execWriter do
|
||||
mHttpPort `forM` \p -> elem "http-port" (TE.encodeUtf8 . Text.pack . show $ p)
|
||||
mTcpPort `forM` \p -> elem "listen-tcp" (TE.encodeUtf8 . Text.pack . show $ p)
|
||||
-- when useEncryption do
|
||||
-- elem "ekey" (TE.encodeUtf8 . Text.pack . show $
|
||||
-- (Encrypt.publicKey . _envAsymmetricKeyPair) penv
|
||||
-- -- mayby sign this pubkey by node key ?
|
||||
-- )
|
||||
|
||||
where
|
||||
elem k = W.tell . L.singleton . (k ,)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,37 +1,64 @@
|
|||
{-# Language TemplateHaskell #-}
|
||||
module ProxyMessaging
|
||||
( ProxyMessaging
|
||||
, PlainProxyMessaging(..)
|
||||
, newProxyMessaging
|
||||
, runProxyMessaging
|
||||
, proxyEncryptionKeys
|
||||
, sendToPlainProxyMessaging
|
||||
) where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Net.Messaging
|
||||
import HBS2.Clock
|
||||
import HBS2.Crypto
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Proto.Definition ()
|
||||
import HBS2.Net.Proto.Peer
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Net.Messaging.UDP
|
||||
import HBS2.Net.Messaging.TCP
|
||||
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import Crypto.Saltine.Class as SCl
|
||||
import Crypto.Saltine.Core.Box qualified as Encrypt
|
||||
|
||||
import Codec.Serialise
|
||||
import Control.Applicative
|
||||
import Control.Arrow hiding ((<+>))
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM
|
||||
import Control.Concurrent.STM.TQueue
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Maybe
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.List qualified as L
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as Map
|
||||
import Lens.Micro.Platform
|
||||
import Control.Monad
|
||||
|
||||
-- TODO: protocol-encryption-goes-here
|
||||
|
||||
data ProxyMessaging =
|
||||
data ProxyMessaging =
|
||||
ProxyMessaging
|
||||
{ _proxyUDP :: MessagingUDP
|
||||
, _proxyTCP :: Maybe MessagingTCP
|
||||
, _proxyAnswers :: TQueue (From L4Proto, ByteString)
|
||||
, _proxyAnswers :: TQueue (From L4Proto, LBS.ByteString)
|
||||
, _proxyEncryptionKeys :: TVar (Map (Peer L4Proto) (CommonSecret (Encryption L4Proto)))
|
||||
}
|
||||
|
||||
newtype PlainProxyMessaging = PlainProxyMessaging ProxyMessaging
|
||||
|
||||
-- 1 нода X создаёт себе Encrypt.Keypair
|
||||
-- 2 подписывает из него публичный ключ ключом подписи ноды X и отправляет ноде Y
|
||||
-- 3 нода Y получила Публичный ключ ноды X, создала симметричный Key,
|
||||
-- зашифровала его для полученного Публичного ключа ноды X и отравила ей
|
||||
|
||||
makeLenses 'ProxyMessaging
|
||||
|
||||
newProxyMessaging :: forall m . MonadIO m
|
||||
|
|
@ -42,6 +69,7 @@ newProxyMessaging :: forall m . MonadIO m
|
|||
newProxyMessaging u t = liftIO do
|
||||
ProxyMessaging u t
|
||||
<$> newTQueueIO
|
||||
<*> newTVarIO mempty
|
||||
|
||||
runProxyMessaging :: forall m . MonadIO m
|
||||
=> ProxyMessaging
|
||||
|
|
@ -66,23 +94,82 @@ runProxyMessaging env = liftIO do
|
|||
|
||||
liftIO $ mapM_ waitCatch [u,t]
|
||||
|
||||
instance Messaging ProxyMessaging L4Proto ByteString where
|
||||
instance Messaging PlainProxyMessaging L4Proto LBS.ByteString where
|
||||
sendTo = sendToPlainProxyMessaging
|
||||
receive (PlainProxyMessaging bus) = receive bus
|
||||
|
||||
sendTo bus t@(To whom) f m = do
|
||||
-- sendTo (view proxyUDP bus) t f m
|
||||
-- trace $ "PROXY: SEND" <+> pretty whom
|
||||
sendToPlainProxyMessaging :: (MonadIO m)
|
||||
=> PlainProxyMessaging
|
||||
-> To L4Proto
|
||||
-> From L4Proto
|
||||
-> LBS.ByteString
|
||||
-- -> AnyMessage LBS.ByteString L4Proto
|
||||
-> m ()
|
||||
sendToPlainProxyMessaging (PlainProxyMessaging bus) t@(To whom) proto msg = do
|
||||
let udp = view proxyUDP bus
|
||||
case view sockType whom of
|
||||
UDP -> sendTo udp t f m
|
||||
UDP -> sendTo udp t proto msg
|
||||
TCP -> maybe1 (view proxyTCP bus) none $ \tcp -> do
|
||||
sendTo tcp t f m
|
||||
sendTo tcp t proto msg
|
||||
|
||||
receive bus _ = liftIO do
|
||||
instance Messaging ProxyMessaging L4Proto LBS.ByteString where
|
||||
sendTo = sendToProxyMessaging
|
||||
receive = receiveFromProxyMessaging
|
||||
|
||||
sendToProxyMessaging bus t@(To whom) proto msg = do
|
||||
-- sendTo (view proxyUDP bus) t proto msg
|
||||
-- trace $ "PROXY: SEND" <+> pretty whom
|
||||
encKey <- Map.lookup whom <$> (liftIO . readTVarIO) (view proxyEncryptionKeys bus)
|
||||
cf <- case encKey of
|
||||
Nothing -> do
|
||||
trace $ "ENCRYPTION SEND: sending plain message to" <+> pretty whom
|
||||
pure id
|
||||
Just k -> do
|
||||
trace $ "ENCRYPTION SEND: sending encrypted message to" <+> pretty whom <+> "with key" <+> viaShow k
|
||||
boxAfterNMLazy k <$> liftIO Encrypt.newNonce
|
||||
sendTo (PlainProxyMessaging bus) t proto (cf msg)
|
||||
|
||||
receiveFromProxyMessaging :: MonadIO m
|
||||
=> ProxyMessaging -> To L4Proto -> m [(From L4Proto, LBS.ByteString)]
|
||||
receiveFromProxyMessaging bus _ = liftIO do
|
||||
-- trace "PROXY: RECEIVE"
|
||||
-- receive (view proxyUDP bus) w
|
||||
let answ = view proxyAnswers bus
|
||||
atomically $ do
|
||||
r <- readTQueue answ
|
||||
rs <- flushTQueue answ
|
||||
pure (r:rs)
|
||||
rs <- atomically $ liftM2 (:) (readTQueue answ) (flushTQueue answ)
|
||||
fmap catMaybes $ forM rs \(w@(From whom), msg) -> do
|
||||
encKeys <- (liftIO . readTVarIO) (view proxyEncryptionKeys bus)
|
||||
fmap (w, ) <$> dfm whom (Map.lookup whom encKeys) msg
|
||||
|
||||
where
|
||||
dfm :: Peer L4Proto -> Maybe Encrypt.CombinedKey -> LBS.ByteString -> IO (Maybe LBS.ByteString)
|
||||
dfm = \whom mk msg -> case mk of
|
||||
Nothing -> do
|
||||
trace $ "ENCRYPTION RECEIVE: we do not have a key to decode" <+> pretty whom
|
||||
pure (Just msg)
|
||||
Just k -> runMaybeT $ (<|> pure msg) $ do
|
||||
trace $ "ENCRYPTION RECEIVE: we have a key to decode from" <+> pretty whom <+> ":" <+> viaShow k
|
||||
case ((extractNonce . cs) msg) of
|
||||
Nothing -> do
|
||||
trace $ "ENCRYPTION RECEIVE: can not extract nonce from" <+> pretty whom <+> "message" <+> viaShow msg
|
||||
pure msg
|
||||
Just (nonce, msg') ->
|
||||
((MaybeT . pure) (boxOpenAfterNMLazy k nonce msg')
|
||||
<* (trace $ "ENCRYPTION RECEIVE: message successfully decoded from" <+> pretty whom)
|
||||
)
|
||||
<|>
|
||||
(do
|
||||
(trace $ "ENCRYPTION RECEIVE: can not decode message from" <+> pretty whom)
|
||||
|
||||
-- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать
|
||||
pure msg
|
||||
|
||||
-- -- Попытаться десериализовать сообщение как PeerPing или PeerPingCrypted
|
||||
-- case deserialiseOrFail msg of
|
||||
-- Right (_ :: PeerHandshake L4Proto) -> do
|
||||
-- trace $ "ENCRYPTION RECEIVE: plain message decoded as PeerHandshake" <+> pretty whom
|
||||
-- pure msg
|
||||
-- Left _ -> do
|
||||
-- trace $ "ENCRYPTION RECEIVE: failed" <+> pretty whom
|
||||
-- mzero
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -33,6 +33,8 @@ data RPC e =
|
|||
| RPCFetch (Hash HbSync)
|
||||
| RPCPeers
|
||||
| RPCPeersAnswer (PeerAddr e) (PubKey 'Sign (Encryption e))
|
||||
| RPCPexInfo
|
||||
| RPCPexInfoAnswer [PeerAddr L4Proto]
|
||||
| RPCLogLevel SetLogging
|
||||
| RPCRefLogUpdate ByteString
|
||||
| RPCRefLogFetch (PubKey 'Sign (Encryption e))
|
||||
|
|
@ -40,6 +42,11 @@ data RPC e =
|
|||
| RPCRefLogGetAnswer (Maybe (Hash HbSync))
|
||||
deriving stock (Generic)
|
||||
|
||||
deriving instance
|
||||
( Show (PubKey 'Sign (Encryption e))
|
||||
, Show (PeerAddr e)
|
||||
) => Show (RPC e)
|
||||
|
||||
instance (Serialise (PeerAddr e), Serialise (PubKey 'Sign (Encryption e))) => Serialise (RPC e)
|
||||
|
||||
instance HasProtocol L4Proto (RPC L4Proto) where
|
||||
|
|
@ -69,6 +76,8 @@ data RpcAdapter e m =
|
|||
, rpcOnFetch :: Hash HbSync -> m ()
|
||||
, rpcOnPeers :: RPC e -> m ()
|
||||
, rpcOnPeersAnswer :: (PeerAddr e, PubKey 'Sign (Encryption e)) -> m ()
|
||||
, rpcOnPexInfo :: RPC e -> m ()
|
||||
, rpcOnPexInfoAnswer :: [PeerAddr L4Proto] -> m ()
|
||||
, rpcOnLogLevel :: SetLogging -> m ()
|
||||
, rpcOnRefLogUpdate :: ByteString -> m ()
|
||||
, rpcOnRefLogFetch :: PubKey 'Sign (Encryption e) -> m ()
|
||||
|
|
@ -124,6 +133,8 @@ rpcHandler adapter = \case
|
|||
(RPCFetch h) -> rpcOnFetch adapter h
|
||||
p@RPCPeers{} -> rpcOnPeers adapter p
|
||||
(RPCPeersAnswer pa k) -> rpcOnPeersAnswer adapter (pa,k)
|
||||
p@RPCPexInfo{} -> rpcOnPexInfo adapter p
|
||||
(RPCPexInfoAnswer pa) -> rpcOnPexInfoAnswer adapter pa
|
||||
(RPCLogLevel l) -> rpcOnLogLevel adapter l
|
||||
(RPCRefLogUpdate bs) -> rpcOnRefLogUpdate adapter bs
|
||||
(RPCRefLogFetch e) -> rpcOnRefLogFetch adapter e
|
||||
|
|
|
|||
|
|
@ -48,6 +48,7 @@ common common-deps
|
|||
, stm
|
||||
, streaming
|
||||
, sqlite-simple
|
||||
, time
|
||||
, temporary
|
||||
, text
|
||||
, timeit
|
||||
|
|
@ -59,6 +60,7 @@ common common-deps
|
|||
, filelock
|
||||
, ekg-core
|
||||
, scotty
|
||||
, string-conversions
|
||||
, warp
|
||||
, http-conduit
|
||||
, http-types
|
||||
|
|
@ -103,6 +105,7 @@ common shared-properties
|
|||
, MultiParamTypeClasses
|
||||
, OverloadedStrings
|
||||
, QuasiQuotes
|
||||
, RecordWildCards
|
||||
, ScopedTypeVariables
|
||||
, StandaloneDeriving
|
||||
, TupleSections
|
||||
|
|
|
|||
|
|
@ -568,6 +568,7 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
<> command "lref-update" (info pUpdateLRef (progDesc "updates a linear ref"))
|
||||
<> command "reflog" (info pReflog (progDesc "reflog commands"))
|
||||
-- <> command "lref-del" (info pDelLRef (progDesc "removes a linear ref from node linear ref list"))
|
||||
<> command "showpex" (info pReflog (progDesc "reflog commands"))
|
||||
)
|
||||
|
||||
common = do
|
||||
|
|
|
|||
Loading…
Reference in New Issue