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

Merge iv/integrate-encryption-test-dev2 into refchan-merge-2 (using imerge)

This commit is contained in:
Sergey Ivanov 2023-07-25 16:11:47 +04:00
parent b6ca7cad85 03ccf9b088
commit 75f03b9c95
36 changed files with 1147 additions and 197 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
README.md
View File

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

8
docs/devlog.md
View File

@ -1299,3 +1299,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.

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

@ -53,11 +53,13 @@ common shared-properties
, MultiParamTypeClasses
, OverloadedStrings
, QuasiQuotes
, RecordWildCards
, ScopedTypeVariables
, StandaloneDeriving
, TupleSections
, TypeApplications
, TypeFamilies
, TemplateHaskell
@ -70,9 +72,11 @@ library
, HBS2.Actors.Peer.Types
, HBS2.Base58
, HBS2.Clock
, HBS2.Crypto
, HBS2.Data.Detect
, HBS2.Data.Types
, HBS2.Data.Types.Crypto
, HBS2.Data.Types.Peer
, HBS2.Data.Types.Refs
, HBS2.Defaults
, HBS2.Events
@ -92,6 +96,8 @@ library
, HBS2.Net.Proto.BlockChunks
, HBS2.Net.Proto.BlockInfo
, HBS2.Net.Proto.Definition
, HBS2.Net.Proto.EncryptionHandshake
, HBS2.Net.Proto.Event.PeerExpired
, HBS2.Net.Proto.Peer
, HBS2.Net.Proto.PeerAnnounce
, HBS2.Net.Proto.PeerExchange
@ -151,9 +157,11 @@ library
, stm
, stm-chans
, streaming
, string-conversions
, suckless-conf
, temporary
, text
, time
, transformers
, uniplate
, unordered-containers
@ -190,17 +198,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

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

@ -11,9 +11,11 @@ module HBS2.Actors.Peer
import HBS2.Actors
import HBS2.Actors.Peer.Types
import HBS2.Clock
import HBS2.Data.Types.Peer
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
@ -21,7 +23,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
@ -30,18 +34,24 @@ import Data.Cache (Cache)
import Data.Cache qualified as Cache
import Data.Dynamic
import Data.Foldable hiding (find)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe
import GHC.TypeLits
import Lens.Micro.Platform
import Lens.Micro.Platform as Lens
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Control.Concurrent.STM.TVar
import Control.Concurrent.STM
import UnliftIO (MonadUnliftIO)
import Data.Hashable (hash)
import UnliftIO (MonadUnliftIO(..))
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 AnyMessage enc e = AnyMessage !Integer !(Encoded e)
@ -132,8 +142,30 @@ 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)
, _envEncryptionKeys :: TVar (HashMap (PeerData e) (CommonSecret (Encryption e)))
}
setEncryptionKey ::
( Hashable (PubKey 'Sign (Encryption L4Proto))
, Hashable PeerNonce
, Show (PubKey 'Sign (Encryption L4Proto))
, Show PeerNonce
, Show (CommonSecret (Encryption L4Proto))
) => PeerEnv L4Proto -> Peer L4Proto -> PeerData L4Proto -> Maybe (CommonSecret (Encryption L4Proto)) -> IO ()
setEncryptionKey penv peer pd msecret = do
atomically $ modifyTVar' (_envEncryptionKeys penv) $ Lens.at pd .~ msecret
case msecret of
Nothing -> trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow pd
Just k -> trace $ "ENCRYPTION store key" <+> pretty peer <+> viaShow pd <+> viaShow k
getEncryptionKey ::
( Hashable (PubKey 'Sign (Encryption L4Proto))
, Hashable PeerNonce
) => PeerEnv L4Proto -> PeerData L4Proto -> IO (Maybe (CommonSecret (Encryption L4Proto)))
getEncryptionKey penv pd =
readTVarIO (_envEncryptionKeys penv) <&> preview (Lens.ix pd)
newtype PeerM e m a = PeerM { fromPeerM :: ReaderT (PeerEnv e) m a }
deriving newtype ( Functor
, Applicative
@ -264,14 +296,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
@ -280,12 +314,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))
@ -369,6 +408,9 @@ newPeerEnv :: forall e m . ( MonadIO m
, Ord (Peer e)
, Pretty (Peer e)
, HasNonces () m
, Asymm (Encryption e)
, Hashable (PubKey 'Sign (Encryption e))
, Hashable PeerNonce
)
=> AnyStorage
-> Fabriq e
@ -376,18 +418,21 @@ 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)
_envEncryptionKeys <- liftIO (newTVarIO mempty)
pure PeerEnv {..}
runPeerM :: forall e m . ( MonadIO m
, HasPeer e

3
hbs2-core/lib/HBS2/Base58.hs
View File

@ -29,3 +29,6 @@ instance Pretty (AsBase58 ByteString) where
instance Pretty (AsBase58 LBS.ByteString) where
pretty (AsBase58 bs) = pretty $ BS8.unpack $ toBase58 (LBS.toStrict bs)
instance Show (AsBase58 ByteString) where
show (AsBase58 bs) = BS8.unpack $ toBase58 bs

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

@ -9,6 +9,7 @@ import Control.Monad.IO.Class
import Data.Fixed
import Data.Int (Int64)
import Data.Proxy
import Data.Time
import Prettyprinter
import System.Clock
import Data.Time.Clock
@ -34,6 +35,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 ()

28
hbs2-core/lib/HBS2/Crypto.hs Normal file
View File

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

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

@ -1,13 +1,13 @@
module HBS2.Data.Types
( module HBS2.Hash
, module HBS2.Data.Types.Refs
( module X
-- , module HBS2.Data.Types.Crypto
, AsSyntax(..)
)
where
import HBS2.Hash
import HBS2.Data.Types.Refs
import HBS2.Hash as X
import HBS2.Data.Types.Refs as X
import HBS2.Data.Types.Peer as X
-- import HBS2.Data.Types.Crypto
-- import Data.Config.Suckless

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

@ -1,4 +1,29 @@
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

45
hbs2-core/lib/HBS2/Data/Types/Peer.hs Normal file
View File

@ -0,0 +1,45 @@
{-# Language UndecidableInstances #-}
module HBS2.Data.Types.Peer where
import Codec.Serialise
import Data.ByteString qualified as BS
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
type PingSign e = Signature (Encryption e)
type PingNonce = BS.ByteString
data PeerData e =
PeerData
{ _peerSignKey :: PubKey 'Sign (Encryption e)
, _peerOwnNonce :: PeerNonce -- TODO: to use this field to detect if it's own peer to avoid loops
}
deriving stock (Typeable,Generic)
deriving instance
( Eq (PubKey 'Sign (Encryption e))
, Eq PeerNonce
)
=> Eq (PeerData e)
instance
( Hashable (PubKey 'Sign (Encryption e))
, Hashable PeerNonce
)
=> Hashable (PeerData e) where
hashWithSalt s PeerData{..} = hashWithSalt s (_peerOwnNonce)
deriving instance
( Show (PubKey 'Sign (Encryption e))
, Show PeerNonce
)
=> Show (PeerData e)
makeLenses 'PeerData

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

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

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

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

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

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

75
hbs2-core/lib/HBS2/Net/Proto/Definition.hs
View File

@ -7,6 +7,7 @@ module HBS2.Net.Proto.Definition
where
import HBS2.Clock
import HBS2.Data.Types.Crypto
import HBS2.Defaults
import HBS2.Hash
import HBS2.Net.Auth.Credentials
@ -14,6 +15,7 @@ import HBS2.Net.Proto
import HBS2.Net.Proto.BlockAnnounce
import HBS2.Net.Proto.BlockChunks
import HBS2.Net.Proto.BlockInfo
import HBS2.Net.Proto.EncryptionHandshake
import HBS2.Net.Proto.Peer
import HBS2.Net.Proto.PeerAnnounce
import HBS2.Net.Proto.PeerExchange
@ -22,25 +24,21 @@ import HBS2.Net.Proto.RefLog
import HBS2.Net.Proto.RefChan
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
import HBS2.Data.Types.Crypto
type instance Encryption L4Proto = 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
-- FIXME: proper-serialise-for-keys
-- Возможно, нужно написать ручные инстансы Serialise
-- использовать encode/decode для каждого инстанса ниже $(c:end + 4)
@ -48,15 +46,15 @@ type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey
-- но возможно, будет работать и так, ведь ключи
-- это же всего лишь байтстроки внутри.
instance Serialise Sign.PublicKey
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
@ -66,7 +64,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
@ -75,13 +73,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
@ -89,19 +87,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
-- TODO: find-out-optimal-max-safe-frequency
@ -110,13 +108,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
@ -153,6 +151,14 @@ instance HasProtocol L4Proto (RefChanRequest L4Proto) where
-- но poll у нас в минутах, и с минимальным периодом 1 минута
requestPeriodLim = ReqLimPerMessage 1
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 Expires (SessionKey L4Proto (BlockInfo L4Proto)) where
expiresIn _ = Just defCookieTimeoutSec
@ -171,48 +177,57 @@ instance Expires (SessionKey L4Proto (KnownPeer L4Proto)) where
instance Expires (SessionKey L4Proto (PeerHandshake L4Proto)) where
expiresIn _ = Just 60
instance Expires (SessionKey L4Proto (EncryptionHandshake L4Proto)) where
expiresIn _ = Just 60
instance Expires (EventKey L4Proto (PeerAnnounce L4Proto)) where
expiresIn _ = Nothing
instance Expires (EventKey L4Proto (PeerMetaProto L4Proto)) where
expiresIn _ = Just 600
-- instance Expires (EventKey L4Proto (EncryptionHandshake L4Proto)) where
-- expiresIn _ = Just 600
-- 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
instance Signatures HBS2Basic where
type Signature HBS2Basic = Sign.Signature
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)

190
hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs Normal file
View File

@ -0,0 +1,190 @@
{-# 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.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 ()
}
encryptionHandshakeProto :: forall e s m .
( 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 ())
)
=> EncryptionHandshakeAdapter e m s
-> PeerEnv e
-> EncryptionHandshake e
-> m ()
encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \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
let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
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
let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
-- подписать нонс
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 Normal file
View File

@ -0,0 +1,35 @@
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

38
hbs2-core/lib/HBS2/Net/Proto/Peer.hs
View File

@ -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,33 +11,30 @@ 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)
type PingSign e = Signature (Encryption e)
type PingNonce = BS.ByteString
data PeerData e =
PeerData
{ _peerSignKey :: PubKey 'Sign (Encryption e)
, _peerOwnNonce :: PeerNonce -- TODO: to use this field to detect if it's own peer to avoid loops
}
deriving stock (Typeable,Generic)
makeLenses 'PeerData
data PeerHandshake e =
PeerPing PingNonce
| PeerPong PingNonce (Signature (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)
@ -104,14 +102,18 @@ peerHandShakeProto :: forall e s m . ( MonadIO m
, EventEmitter e (PeerHandshake e) m
, EventEmitter e (ConcretePeer 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
@ -176,6 +178,8 @@ data instance Event e (ConcretePeer e) =
ConcretePeerData (Peer e) (PeerData e)
deriving stock (Typeable)
---
data instance EventKey e (PeerHandshake e) =
AnyKnownPeerEventKey
deriving stock (Typeable, Eq,Generic)
@ -209,6 +213,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 +221,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
)

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

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

44
hbs2-core/lib/HBS2/Net/Proto/PeerExchange.hs
View File

@ -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,7 +115,23 @@ peerExchangeProto pexFilt msg = do
case pex of
PEX1 -> do
pa <- take defPexMaxPeers <$> getAllPex1Peers
response (PeerExchangePeers @e n pa)
PEX2 -> do
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
@ -118,22 +139,23 @@ peerExchangeProto pexFilt msg = do
case pa of
(L4Address UDP x) | auth -> pure [x]
_ -> pure mempty
pure $ mconcat pa'
let pa = take defPexMaxPeers $ mconcat pa'
response (PeerExchangePeers @e n pa)
PEX2 -> do
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
let pa = take defPexMaxPeers $ mconcat pa'
response (PeerExchangePeers2 @e n pa)
pure $ mconcat pa'
newtype instance SessionKey e (PeerExchange e) =
PeerExchangeKey (Nonce (PeerExchange e))

10
hbs2-core/lib/HBS2/Net/Proto/RefLog.hs
View File

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

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

@ -111,7 +111,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

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

@ -1,6 +1,7 @@
module HBS2.Prelude
( module Data.String
, module Safe
, module X
, MonadIO(..)
, void, guard, when, unless
, maybe1
@ -17,6 +18,9 @@ module HBS2.Prelude
, Text.Text
) where
import Data.Typeable as X
import GHC.Generics as X (Generic)
import Data.ByteString (ByteString)
import Data.String (IsString(..))
import Safe

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

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

53
hbs2-core/test/TestCrypto.hs Normal file
View File

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

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

@ -1,6 +1,7 @@
{-# Language AllowAmbiguousTypes #-}
module Bootstrap where
import HBS2.Data.Types.Peer
import HBS2.Prelude
import HBS2.Net.Proto.Types
import HBS2.Net.Proto.Peer

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

@ -17,9 +17,11 @@ import HBS2.System.Logger.Simple
import PeerConfig
import Control.Concurrent.STM
import Control.Exception
import Crypto.Saltine.Core.Box qualified as Encrypt
import Data.Maybe
import Control.Monad
import Control.Exception
import Control.Concurrent.STM
import Database.SQLite.Simple
import Database.SQLite.Simple.FromField
import Data.Cache (Cache)
@ -633,6 +635,56 @@ transactional brains action = do
err $ "BRAINS: " <+> viaShow e
execute_ conn [qc|ROLLBACK TO SAVEPOINT {sp}|]
---
insertPeerAsymmKey :: forall e m . (e ~ L4Proto, MonadIO m)
=> BasicBrains e
-> Peer e
-> Encrypt.PublicKey
-> Encrypt.CombinedKey
-> m ()
insertPeerAsymmKey br peer hAsymmKey hSymmKey = do
insertPeerAsymmKey br peer hAsymmKey hSymmKey
insertPeerAsymmKey' br (show $ pretty peer) hAsymmKey hSymmKey
insertPeerAsymmKey' :: forall e m . (e ~ L4Proto, MonadIO m)
=> BasicBrains e
-> String
-> Encrypt.PublicKey
-> Encrypt.CombinedKey
-> m ()
insertPeerAsymmKey' br key hAsymmKey hSymmKey = do
let conn = view brainsDb br
void $ liftIO $ execute conn [qc|
INSERT INTO peer_asymmkey (peer,asymmkey,symmkey)
VALUES (?,?,?)
ON CONFLICT (peer)
DO UPDATE SET
asymmkey = excluded.asymmkey
, symmkey = excluded.symmkey
|] (key, show hAsymmKey, show hSymmKey)
---
deletePeerAsymmKey :: forall e m . (e ~ L4Proto, MonadIO m)
=> BasicBrains e -> Peer e -> m ()
deletePeerAsymmKey br peer =
deletePeerAsymmKey' br (show $ pretty peer)
deletePeerAsymmKey' :: forall e m . (e ~ L4Proto, MonadIO m)
=> BasicBrains e -> String -> m ()
deletePeerAsymmKey' br key =
void $ liftIO $ execute (view brainsDb br) [qc|
DELETE FROM peer_asymmkey
WHERE peer = ?
|] (Only key)
---
-- FIXME: eventually-close-db
newBasicBrains :: forall e m . (Hashable (Peer e), MonadIO m)
=> PeerConfig
@ -731,6 +783,16 @@ newBasicBrains cfg = liftIO do
|]
execute_ conn [qc|
create table if not exists peer_asymmkey
( peer text not null
, asymmkey text not null
, symmkey text not null
, ts DATE DEFAULT (datetime('now','localtime'))
, primary key (peer)
)
|]
BasicBrains <$> newTVarIO mempty
<*> newTVarIO mempty
<*> Cache.newCache (Just (toTimeSpec (30 :: Timeout 'Seconds)))

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

@ -0,0 +1,82 @@
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.System.Logger.Simple
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
-> PeerEnv e
-> PeerCredentials s
-> EncryptionHandshakeAdapter e m s
-> m ()
encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do
-- e :: PeerEnv e <- ask
let ourpubkey = pubKeyFromKeypair @s $ _envAsymmetricKeyPair penv
pl <- getPeerLocator @e
forever do
liftIO $ pause @'Seconds 30
peers <- knownPeers @e pl
forM_ peers \peer -> do
-- Только если ещё не знаем ключ ноды
mpeerData <- find (KnownPeerKey peer) id
mkey <- liftIO do
join <$> forM mpeerData \peerData -> getEncryptionKey penv peerData
case mkey of
Just _ -> pure ()
Nothing -> sendBeginEncryptionExchange @e creds ourpubkey peer

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

@ -4,6 +4,7 @@ import HBS2.Prelude
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.Events
@ -33,9 +34,9 @@ httpWorker :: forall e s m . ( MyPeer e
, s ~ Encryption e
, m ~ PeerM e IO
, e ~ L4Proto
) => 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
@ -90,7 +91,7 @@ httpWorker conf e = do
status status200
get "/metadata" do
raw $ serialise $ mkPeerMeta conf
raw $ serialise $ pmeta
put "/" do
-- FIXME: optional-header-based-authorization

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

@ -4,8 +4,11 @@ module PeerInfo where
import HBS2.Actors.Peer
import HBS2.Clock
import HBS2.Data.Types
import HBS2.Events
import HBS2.Net.Auth.Credentials
import HBS2.Net.PeerLocator
import HBS2.Net.Proto.Event.PeerExpired
import HBS2.Net.Proto.Peer
import HBS2.Net.Proto.PeerExchange
import HBS2.Net.Proto.Sessions
@ -145,8 +148,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
@ -217,9 +220,11 @@ peerPingLoop cfg = do
let l = realToFrac (toNanoSecs $ now - seen) / 1e9
-- FIXME: time-hardcode
when ( l > 300 ) do
mpeerData <- find (KnownPeerKey p) id
delPeers pl [p]
expire (PeerInfoKey p)
expire (KnownPeerKey p)
emit PeerExpiredEventKey (PeerExpiredEvent @e p {-mpeerData-})
liftIO $ mapM_ link [watch, infoLoop]
@ -240,7 +245,6 @@ 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

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

@ -14,13 +14,17 @@ import HBS2.Defaults
import HBS2.Events
import HBS2.Hash
import HBS2.Data.Types.Refs
import HBS2.Data.Types
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.EncryptionHandshake
import HBS2.Net.Proto.Event.PeerExpired
import HBS2.Net.Proto.Peer
import HBS2.Net.Proto.PeerAnnounce
import HBS2.Net.Proto.PeerExchange
@ -45,6 +49,7 @@ import PeerInfo
import PeerConfig
import Bootstrap
import CheckMetrics
import EncryptionKeys
import RefLog qualified
import RefLog (reflogWorker)
import HttpWorker
@ -53,7 +58,7 @@ import PeerMeta
import CLI.RefChan
import RefChan
import Codec.Serialise
import Codec.Serialise as Serialise
-- import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception as Exception
@ -67,6 +72,7 @@ import Data.ByteString qualified as BS
import Data.Cache qualified as Cache
import Data.Function
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
@ -77,7 +83,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
@ -87,6 +93,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
@ -228,6 +235,7 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
<> command "reflog" (info pRefLog (progDesc "reflog commands"))
<> command "refchan" (info pRefChan (progDesc "refchan commands"))
<> command "peers" (info pPeers (progDesc "show known peers"))
<> command "pexinfo" (info pPexInfo (progDesc "show pex"))
<> command "log" (info pLog (progDesc "set logging level"))
)
@ -289,6 +297,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") ) )
@ -479,16 +491,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
@ -548,11 +560,42 @@ runPeer opts = U.handle (\e -> myException e
void $ async $ runMessagingTCP tcpEnv
pure $ Just tcpEnv
proxy <- newProxyMessaging mess tcp
(proxy, penv) <- mdo
proxy <- newProxyMessaging mess tcp >>= \peer -> pure peer
{ _proxy_getEncryptionKey = \peer -> do
mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id
mkey <- join <$> forM mpeerData \peerData -> getEncryptionKey penv peerData
case mkey of
Nothing ->
trace $ "ENCRYPTION empty getEncryptionKey"
<+> pretty peer <+> viaShow mpeerData
Just k ->
trace $ "ENCRYPTION success getEncryptionKey"
<+> pretty peer <+> viaShow mpeerData <+> viaShow k
pure mkey
, _proxy_clearEncryptionKey = \peer -> do
mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id
forM_ mpeerData \peerData -> setEncryptionKey penv peer peerData Nothing
-- deletePeerAsymmKey brains peer
forM_ mpeerData \peerData ->
deletePeerAsymmKey' brains (show peerData)
, _proxy_sendResetEncryptionKeys = \peer -> withPeerM penv do
sendResetEncryptionKeys peer
, _proxy_sendBeginEncryptionExchange = \peer -> withPeerM penv do
sendBeginEncryptionExchange pc
((pubKeyFromKeypair @s . view envAsymmetricKeyPair) penv)
peer
}
penv <- newPeerEnv (AnyStorage s) (Fabriq proxy) (getOwnPeer mess)
pure (proxy, penv)
proxyThread <- async $ runProxyMessaging proxy
penv <- newPeerEnv (AnyStorage s) (Fabriq proxy) (getOwnPeer mess)
let peerMeta = mkPeerMeta conf penv
nbcache <- liftIO $ Cache.newCache (Just $ toTimeSpec ( 600 :: Timeout 'Seconds))
@ -581,8 +624,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 $ \pd -> do
let pk = view peerSignKey pd
when (Set.member pk helpFetchKeys) do
liftIO $ Cache.insert nbcache (p,h) ()
@ -624,6 +667,36 @@ runPeer opts = U.handle (\e -> myException e
let hshakeAdapter = PeerHandshakeAdapter addNewRtt
let encryptionHshakeAdapter ::
( MonadIO m
, EventEmitter e (PeerAsymmInfo e) m
) => EncryptionHandshakeAdapter L4Proto m s
encryptionHshakeAdapter = EncryptionHandshakeAdapter
{ encHandshake_considerPeerAsymmKey = \peer mpubkey -> withPeerM penv do
mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id
case mpubkey of
Nothing -> do
-- trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow mpeerData
-- deletePeerAsymmKey brains peer
forM_ mpeerData \peerData ->
deletePeerAsymmKey' brains (show peerData)
Just pk -> do
-- emit PeerAsymmInfoKey (PeerAsymmPubKey peer pk)
let symmk = genCommonSecret @s
(privKeyFromKeypair @s (view envAsymmetricKeyPair penv))
pk
case mpeerData of
Nothing -> do
-- insertPeerAsymmKey brains peer pk symmk
-- insertPeerAsymmKey' brains (show peer) pk symmk
trace $ "ENCRYPTION can not store key. No peerData"
<+> pretty peer <+> viaShow mpeerData
Just peerData -> do
liftIO $ setEncryptionKey penv peer peerData (Just symmk)
insertPeerAsymmKey' brains (show peerData) pk symmk
}
env <- ask
pnonce <- peerNonce @e
@ -632,29 +705,39 @@ runPeer opts = U.handle (\e -> myException e
addPeers @e pl ps
subscribe @e PeerExpiredEventKey \(PeerExpiredEvent peer {-mpeerData-}) -> liftIO do
mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id
forM_ mpeerData \peerData -> setEncryptionKey penv peer peerData Nothing
-- deletePeerAsymmKey brains peer
forM_ mpeerData \peerData ->
deletePeerAsymmKey' brains (show peerData)
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
mpd :: Maybe (PeerData e) <- find (KnownPeerKey pip) id
banned <- maybe (pure False) (peerBanned pip) mpd
let known = isJust mpd && 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 AnyKnownPeerEventKey $ \(KnownPeerEvent p pd) -> do
let thatNonce = view peerOwnNonce d
let thatNonce = view peerOwnNonce pd
now <- liftIO getTimeCoarse
pinfo' <- find (PeerInfoKey p) id -- (view peerPingFailed)
maybe1 pinfo' none $ \pinfo -> do
-- defPeerInfo <- newPeerInfo
-- fetch True defPeerInfo (PeerInfoKey p) id >>= \pinfo -> do
find (PeerInfoKey p) id >>= mapM_ \pinfo -> do
liftIO $ atomically $ writeTVar (view peerPingFailed pinfo) 0
liftIO $ atomically $ writeTVar (view peerLastWatched pinfo) now
banned <- peerBanned p d
banned <- peerBanned p pd
let doAddPeer p = do
addPeers pl [p]
@ -666,7 +749,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)
@ -682,18 +765,15 @@ runPeer opts = U.handle (\e -> myException e
| otherwise -> do
update d (KnownPeerKey p) id
update pd (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'
pdkv :: Map BS.ByteString (Peer L4Proto) <- fmap (Map.fromList . catMaybes)
$ knownPeers @e pl >>= mapM \pip ->
fmap (, pip) <$> find (KnownPeerKey pip) (view peerOwnNonce)
let proto1 = view sockType p
case Map.lookup thatNonce pd of
case Map.lookup thatNonce pdkv of
-- TODO: prefer-local-peer-with-same-nonce-over-remote-peer
-- remove remote peer
@ -758,11 +838,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)
@ -772,6 +852,9 @@ runPeer opts = U.handle (\e -> myException e
peerThread "blockDownloadLoop" (blockDownloadLoop denv)
peerThread "encryptionHandshakeWorker"
(EncryptionKeys.encryptionHandshakeWorker @e conf penv pc encryptionHshakeAdapter)
let tcpProbeWait :: Timeout 'Seconds
tcpProbeWait = (fromInteger . fromMaybe 300) (cfgValue @PeerTcpProbeWaitKey conf)
@ -798,11 +881,14 @@ 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
@ -832,13 +918,13 @@ 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?
@ -886,11 +972,12 @@ 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 (withCredentials @e pc . encryptionHandshakeProto encryptionHshakeAdapter penv)
, makeResponse (peerExchangeProto pexFilt)
, makeResponse (refLogUpdateProto reflogAdapter)
, makeResponse (refLogRequestProto reflogReqAdapter)
, makeResponse (peerMetaProto (mkPeerMeta conf))
, makeResponse (peerMetaProto peerMeta)
, makeResponse (refChanHeadProto False refChanAdapter)
, makeResponse (refChanUpdateProto False pc refChanAdapter)
, makeResponse (refChanRequestProto False refChanAdapter)
@ -937,11 +1024,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 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

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

@ -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
when ((not . null) ps') $ lift do
debug $ "fillPeerMeta peers:" <+> pretty ps'
for_ ps' $ \p -> do
npi <- newPeerInfo
for_ ps $ \p -> do
pinfo <- fetch True npi (PeerInfoKey p) id
mmApiAddr <- liftIO $ readTVarIO (_peerHttpApiAddress pinfo)

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

@ -8,9 +8,12 @@ module PeerTypes where
import HBS2.Actors.Peer
import HBS2.Actors.Peer.Types
import HBS2.Clock
import HBS2.Data.Types.Peer
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
@ -31,12 +34,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
@ -47,8 +53,9 @@ import Data.Text qualified as Text
import Data.Text.Encoding qualified as TE
import Data.Time.Clock (NominalDiffTime)
import Data.Heap qualified as Heap
import Data.Heap (Entry(..))
-- import Data.Time.Clock
import Data.Heap (Heap,Entry(..))
import Data.Time.Clock
import Data.Word
data PeerInfo e =
PeerInfo
@ -77,23 +84,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
@ -376,8 +385,8 @@ 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
@ -394,18 +403,29 @@ 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 ,)
data Polling =

166
hbs2-peer/app/ProxyMessaging.hs
View File

@ -1,26 +1,43 @@
{-# Language TemplateHaskell #-}
module ProxyMessaging
( ProxyMessaging
( ProxyMessaging(..)
, newProxyMessaging
, runProxyMessaging
, 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 Lens.Micro.Platform
import Data.Map (Map)
import Data.Map qualified as Map
import Lens.Micro.Platform as Lens
import Control.Monad
-- TODO: protocol-encryption-goes-here
@ -29,9 +46,19 @@ data ProxyMessaging =
ProxyMessaging
{ _proxyUDP :: MessagingUDP
, _proxyTCP :: Maybe MessagingTCP
, _proxyAnswers :: TQueue (From L4Proto, ByteString)
, _proxyAnswers :: TQueue (From L4Proto, LBS.ByteString)
, _proxy_getEncryptionKey :: Peer L4Proto -> IO (Maybe (CommonSecret (Encryption L4Proto)))
, _proxy_clearEncryptionKey :: Peer L4Proto -> IO ()
, _proxy_sendResetEncryptionKeys :: Peer L4Proto -> IO ()
, _proxy_sendBeginEncryptionExchange :: Peer L4Proto -> IO ()
}
-- 1 нода X создаёт себе Encrypt.Keypair
-- 2 подписывает из него публичный ключ ключом подписи ноды X и отправляет ноде Y
-- 3 нода Y получила Публичный ключ ноды X, создала симметричный Key,
-- зашифровала его для полученного Публичного ключа ноды X и отравила ей
makeLenses 'ProxyMessaging
newProxyMessaging :: forall m . MonadIO m
@ -40,8 +67,16 @@ newProxyMessaging :: forall m . MonadIO m
-> m ProxyMessaging
newProxyMessaging u t = liftIO do
ProxyMessaging u t
<$> newTQueueIO
let _proxyUDP = u
let _proxyTCP = t
_proxyAnswers <- newTQueueIO
let _proxy_getEncryptionKey = const (pure Nothing)
let _proxy_clearEncryptionKey = const (pure ())
let _proxy_sendResetEncryptionKeys = const (pure ())
let _proxy_sendBeginEncryptionExchange = const (pure ())
pure ProxyMessaging {..}
runProxyMessaging :: forall m . MonadIO m
=> ProxyMessaging
@ -66,23 +101,120 @@ runProxyMessaging env = liftIO do
liftIO $ mapM_ waitCatch [u,t]
instance Messaging ProxyMessaging L4Proto ByteString where
sendTo bus t@(To whom) f m = do
-- sendTo (view proxyUDP bus) t f m
-- trace $ "PROXY: SEND" <+> pretty whom
instance Messaging ProxyMessaging L4Proto LBS.ByteString where
sendTo = sendToProxyMessaging
receive = receiveFromProxyMessaging
-- receive 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)
sendToPlainProxyMessaging :: (MonadIO m)
=> ProxyMessaging
-> To L4Proto
-> From L4Proto
-> LBS.ByteString
-> m ()
sendToPlainProxyMessaging 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
sendToProxyMessaging :: (MonadIO m)
=> ProxyMessaging
-> To L4Proto
-> From L4Proto
-> LBS.ByteString
-> m ()
sendToProxyMessaging bus t@(To whom) proto msg = do
-- sendTo (view proxyUDP bus) t proto msg
-- trace $ "PROXY: SEND" <+> pretty whom
mencKey <- liftIO $ _proxy_getEncryptionKey bus whom
cf <- case mencKey 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
sendToPlainProxyMessaging 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
fmap (w, ) <$> dfm whom msg
-- Здесь:
-- 1. У нас есть ключ сессии и мы не смогли расшифровать -> do
-- удаляем у себя ключ
-- отправляем sendBeginEncryptionExchange
-- 2. У нас (до сих пор, даже если мы давно стартовали) нет ключа сессии -> do
-- sendResetEncryptionKeys
-- просто передаём сообщение как есть
-- В протоколе пингов:
-- 1. Если слишком долго нет ответа на ping, то удаляем у себя ключ, отправляем sendResetEncryptionKeys
-- Выполняется в PeerInfo:
-- emit PeerExpiredEventKey (PeerExpiredEvent @e p mpeerData)
where
dfm :: Peer L4Proto -> LBS.ByteString -> IO (Maybe LBS.ByteString)
dfm = \whom msg -> liftIO $ _proxy_getEncryptionKey bus whom >>= \case
Nothing -> do
trace $ "ENCRYPTION RECEIVE: we do not have a key to decode" <+> pretty whom
liftIO $ _proxy_sendBeginEncryptionExchange bus whom
pure (Just msg)
Just k -> runMaybeT $
-- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать
(<|> (do
liftIO $ _proxy_clearEncryptionKey bus whom
liftIO $ _proxy_sendResetEncryptionKeys bus whom
trace $ "ENCRYPTION RECEIVE: got plain message. clearing key of" <+> pretty whom
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
fail ""
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)
fail ""
-- -- Попытаться десериализовать сообщение как PeerPing или PeerPingCrypted
-- case deserialiseOrFail msg of
-- Right (_ :: PeerHandshake L4Proto) -> do
-- trace $ "ENCRYPTION RECEIVE: plain message decoded as PeerHandshake" <+> pretty whom
-- fail ""
-- Left _ -> do
-- trace $ "ENCRYPTION RECEIVE: failed" <+> pretty whom
-- mzero
)

12
hbs2-peer/app/RPC.hs
View File

@ -57,6 +57,7 @@ data RPCCommand =
| CHECK PeerNonce (PeerAddr L4Proto) (Hash HbSync)
| FETCH (Hash HbSync)
| PEERS
| PEXINFO
| SETLOG SetLogging
| REFLOGUPDATE ByteString
| REFLOGFETCH (PubKey 'Sign (Encryption L4Proto))
@ -79,6 +80,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))
@ -98,6 +101,11 @@ data RPC e =
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
@ -127,6 +135,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 ()
@ -194,6 +204,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

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

@ -49,6 +49,7 @@ common common-deps
, stm
, streaming
, sqlite-simple
, time
, temporary
, text
, time
@ -61,6 +62,7 @@ common common-deps
, filelock
, ekg-core
, scotty
, string-conversions
, warp
, http-conduit
, http-types
@ -107,6 +109,8 @@ common shared-properties
, MultiParamTypeClasses
, OverloadedStrings
, QuasiQuotes
, RecordWildCards
, RecursiveDo
, ScopedTypeVariables
, StandaloneDeriving
, TupleSections
@ -123,6 +127,7 @@ executable hbs2-peer
other-modules: BlockDownload
, BlockHttpDownload
, DownloadQ
, EncryptionKeys
, Bootstrap
, PeerInfo
, PeerMeta

1
hbs2/Main.hs
View File

@ -548,6 +548,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