mirror of https://github.com/voidlizard/hbs2
new protocol encryption + minor tuning
This commit is contained in:
Dmitry Zuikov
parent
9edbe5f7c9
commit
c44a6b997b
|
|
@ -1,3 +1,7 @@
|
|||
## 2023-10-22
|
||||
|
||||
тестируем шифрование на уровне протокола
|
||||
|
||||
## 2023-10-21
|
||||
|
||||
тестируем substituter
|
||||
|
|
|
|||
|
|
@ -0,0 +1,349 @@
|
|||
\input texinfo
|
||||
|
||||
@documentencoding UTF-8
|
||||
@node Top
|
||||
@top Дизайн шифрования протокола
|
||||
|
||||
@chapter Предпосылки
|
||||
|
||||
@section Борьба с DPI
|
||||
|
||||
С высокой вероятностью, на текущем нашем уровне понимания
|
||||
проблемы, DPI будут распознавать протокол всё равно.
|
||||
|
||||
Соответственно, нет большой разницы, один - два или ноль
|
||||
незашифрованных пакетов пройдёт.
|
||||
|
||||
Само наличие шифрования --- уже признак для DPI, могут
|
||||
блокировать просто на основании принадлежности неизвестному
|
||||
протоколу.
|
||||
|
||||
Размеры пакетов и характер обмена --- тоже признаки.
|
||||
|
||||
Saltine, возможно, оставляет сигнатуры в зашифрованных пакетах
|
||||
(проверить).
|
||||
|
||||
Таким образом, борьба с DPI совершенно точно должна
|
||||
осуществляться отдельным Messaging, может быть даже внешним.
|
||||
|
||||
Нашего текущего уровня понимания проблемы просто-таки
|
||||
недостаточно для эффективной борьбы без радикального усложнения
|
||||
себе жизни.
|
||||
|
||||
В дальнейшем, для протокола борьбы с DPI можно выделить даже
|
||||
отдельные порты, где будут ожидаться другие протоколы.
|
||||
|
||||
Скорее всего, нужно будет просто написать транспорт поверх
|
||||
WS/WSS, а внутренние датаграммы шифровать как обычно.
|
||||
|
||||
Таким образом, наверху будет TLS, а внизу --- наше шифрование
|
||||
пакетов, при этом протокол будет принадлежать к "хорошо
|
||||
известным протоколам". Можно даже палёные сертификаты
|
||||
использовать, что бы успокоить службы (на верхнем уровне).
|
||||
|
||||
|
||||
@section Различение шифрованных и нешифрованных пакетов
|
||||
|
||||
Возможны следующие способы:
|
||||
|
||||
@itemize @bullet
|
||||
@item Номера портов
|
||||
@item Сам протокол
|
||||
@end itemize
|
||||
|
||||
@subsection Номера портов
|
||||
|
||||
Запускаем Messaging на отдельном порту, там воркер,
|
||||
который занимается шифрованием и хэндшейком,
|
||||
по мере расшифровки --- передает данные в указанный Messaging
|
||||
(Proxy).
|
||||
|
||||
|
||||
Плюсы:
|
||||
|
||||
@itemize @bullet
|
||||
@item Не нужно заглядывать в пакеты: будет быстрее.
|
||||
@item Не нужны префиксы в протоколе
|
||||
@item Не будет интерференции с остальными протоколами
|
||||
@item Обратная совместимость
|
||||
@end itemize
|
||||
|
||||
|
||||
Минусы:
|
||||
|
||||
@itemize @bullet
|
||||
@item Доработка PEX
|
||||
@item Доработка бутстрапа
|
||||
@item Различение шифрованных и нешифрованных протоколов либо
|
||||
хардкода портов
|
||||
@item Устойчивые порты => легко блокировать
|
||||
@end itemize
|
||||
|
||||
@subsection Сам протокол
|
||||
|
||||
Поскольку Messaing работает @strong{ДО}, мы можем в нём
|
||||
распаковывать пакет, доставать сообщение и передавать в Peer уже
|
||||
расшифрованное.
|
||||
|
||||
У нас есть два варианта:
|
||||
|
||||
Сообщение зашифрованное и незашифрованное.
|
||||
|
||||
Допустим, сообщение зашифрованное --- тогда это просто пакет в
|
||||
формате, который создает libsodium.
|
||||
|
||||
Незашифрованное --- содержит префикс, например 0xdeadf1od и
|
||||
дальше --- уже сам пакет.
|
||||
|
||||
При приеме сообщения мы отправляем этот префикс в начале пакета.
|
||||
|
||||
Если префикс есть --- то смотрим, что это за пакет.
|
||||
|
||||
Допустим, это хэндшейк. Тогда производим согласование ключей, и
|
||||
дальше шлём зашифрованные пакеты.
|
||||
|
||||
Допустим, префикс будет только у пакетов хэндшейка, тогда
|
||||
мы даже сохраним обратную совместимость --- неразобранные пакеты
|
||||
будем отправлять по стеку дальше.
|
||||
|
||||
Минус устойчивой сигнатуры в определенном месте --- легко
|
||||
блокировать простейшим фильтром.
|
||||
|
||||
Несмотря на то, что наши возможности бороться с DPI ограничены
|
||||
слабым погружением в вопрос, настолько облегчать работу им мы не
|
||||
хотим.
|
||||
|
||||
Можно в префикс встроить некий байткод, выполнение которого
|
||||
приведёт к вычислению публичного ключа пира, которым можно,
|
||||
в частности, идентифицировать самого пира.
|
||||
|
||||
Тогда это не будет создавать значительных проблем самому
|
||||
пиру, но будет создавать проблемы при массовом анализе
|
||||
протоколов. Можно еще и загадку встроить.
|
||||
|
||||
Тогда сам пакет будет выглядеть более или менее как мусор,
|
||||
для анализа придётся построить интерпретатор, а так же встроить
|
||||
интерпретацию в DPI, успехов им в борьбе.
|
||||
|
||||
Можно так же использовать какой-то вид вывода ключей из хорошо
|
||||
известной, но динамически меняющейся информации.
|
||||
|
||||
А можно использовать всё вместе, расширяя этот байткод по мере
|
||||
необходимости.
|
||||
|
||||
Всё это приведёт к большому усложнению и сторонних реализаций
|
||||
протокола тоже, так что, для начала --- можно выбрать самый
|
||||
простой способ распознать пакет хэндшейка.
|
||||
|
||||
Но пожалуй, я настою на том, что бы это был какой-то
|
||||
динамический способ, что бы не зависеть от статических
|
||||
сигнатур.
|
||||
|
||||
Вычисляться должно быстро, желательно
|
||||
в один проход вперёд.
|
||||
|
||||
|
||||
Плюсы:
|
||||
|
||||
@itemize @bullet
|
||||
@item Меньше кода
|
||||
@item Не меняется PEX
|
||||
@item Нет устойчивых номеров портов
|
||||
@item Можно навесить сверху любого протокола,
|
||||
например, RPC
|
||||
@end itemize
|
||||
|
||||
Минусы:
|
||||
|
||||
@itemize @bullet
|
||||
@item Потенциально медленнее
|
||||
@end itemize
|
||||
|
||||
@subsection Дизайн
|
||||
|
||||
Отдельный Proxy на каждый Messaging, с общим KeyStore.
|
||||
|
||||
@itemize @bullet
|
||||
@item Пир сразу идентифицируется для всех протоколов
|
||||
@item Можно надстроить над любым Messaing, в частности, над RPC,
|
||||
который у нас пока без средств шифрования и аутентификации.
|
||||
@end itemize
|
||||
|
||||
@verbatim
|
||||
keys <- newKeyStore
|
||||
proxy1 <- newProxyEnc keys (newMessaingUDP ...)
|
||||
proxy2 <- newProxyEnc keys (newMessaingTCP ...)
|
||||
proxy3 <- newProxyMessaging proxy1 (Just proxy2)
|
||||
peer <- newPeer ... (Fabriq proxy3)
|
||||
@end verbatim
|
||||
|
||||
Далее. Предусмотрим два режима: bypass и drop.
|
||||
|
||||
@subsection Режим bypass
|
||||
|
||||
Пробует провести handshake, если не удаётся ---
|
||||
то оставляет эти попытки и просто пересылвает сообщения,
|
||||
как есть на следующий уровень.
|
||||
|
||||
Хэндшейк делает сам. <<Чужие>> пакеты при этом пропускает
|
||||
и наверх, и вниз.
|
||||
|
||||
Таким образом, остаётся обратная совместимость --- ведь
|
||||
пакеты этой прокси просто будут дропнуты.
|
||||
|
||||
Так же можно пакеты слать культурно, в виде AnyMessage
|
||||
с каким-то несуществующим типом протокола, который
|
||||
отсутствует в каких-либо обработчиках --- тогда их
|
||||
будет видно в логах. Возможно, это излишнее.
|
||||
|
||||
@subsection Режим drop
|
||||
|
||||
Пробует провести handshake, если не удаётся ---
|
||||
то не делает ничего, либо повторяет их заданное число раз,
|
||||
а потом не делает ничего.
|
||||
|
||||
Этот режим выбирают пиры, которые настаивают на защищенном
|
||||
обмене.
|
||||
|
||||
@subsection Сообщения и FSM
|
||||
|
||||
Незашифрованное:
|
||||
|
||||
1. HEY(PREFIX,PKs,PKe,SIGN(PKs, PKe))
|
||||
|
||||
@table @asis
|
||||
|
||||
@item PKs:
|
||||
ключ подписи пира
|
||||
|
||||
@item PKe:
|
||||
публичный ключ шифрования сессии
|
||||
|
||||
@end table
|
||||
|
||||
Зашифрованное:
|
||||
|
||||
2. HEYOURSELF(PKe,BOX(PKe,Sid,SECRET))
|
||||
|
||||
@table @asis
|
||||
|
||||
@item PKe:
|
||||
публичный ключ шифрования сессии
|
||||
|
||||
@item Sid:
|
||||
Идентификатор ключа на нашей стороне,
|
||||
должен быть в открытом виде в зашифрованном пакете
|
||||
|
||||
@end table
|
||||
|
||||
Пересылаем ключ шифрования, теперь пир может слать нам
|
||||
зашифрованные сообщения.
|
||||
|
||||
Просто пытаемся расшифровать их своим секретом. Неудача ---
|
||||
просто дропаем или пропускаем, в зависимости от политики.
|
||||
|
||||
Теперь, если пир продолжает слать незашифрованные
|
||||
сообщения --- можем их или дропать, или продолжать
|
||||
пропускать.
|
||||
|
||||
После получения HEYOURSELF мы должны пиру послать
|
||||
наш секрет ключ тоже, так что должны видимо, в свою
|
||||
очередь ответить HEY.
|
||||
|
||||
|
||||
@verbatim
|
||||
|
||||
Peer1 Peer2
|
||||
***** ****
|
||||
| HEY |
|
||||
|------------------>|
|
||||
| HEYOURSELF |
|
||||
|<------------------| Теперь Peer1 может слать Peer2
|
||||
| | зашифрованные сообщения
|
||||
| |
|
||||
| HEY |
|
||||
|<------------------| Теперь Peer2 может слать Peer1
|
||||
| HEYOURSELF | зашифрованные сообщения
|
||||
|------------------>|
|
||||
| |
|
||||
| |
|
||||
|
||||
@end verbatim
|
||||
|
||||
Заметим, что это хорошо ложится на систему обработки
|
||||
подпротоколов в Peer: пары HEY/YOUSELF являются
|
||||
независимыми, и, кажется, stateless, в том плане,
|
||||
что нонсом тут явлется сам PKe.
|
||||
|
||||
Но! Если это вынести на уровень Peer, то потеряется
|
||||
возможность навесить аутентификацию/шифрование на любой
|
||||
Messaging.
|
||||
|
||||
Поэтому делаем на уровне Messaging.
|
||||
|
||||
Грубо говоря: получили HEYOURSELF --- обновили ключ.
|
||||
|
||||
Исключительная ситуация:
|
||||
|
||||
Пир потерял наш SECRET и об этом не знает.
|
||||
|
||||
Это может случиться только при рестарте, если мы не сохраняем
|
||||
ключ.
|
||||
|
||||
Но это не может случиться, так как, если у ProxyEnc нет ключа
|
||||
--- то она посылает HEY.
|
||||
|
||||
|
||||
Замечание: ProxyEnc является пассивной, она ничего не знает про
|
||||
пиров, PEX и сама не инициирует общение, так как не знает, с кем
|
||||
общаться.
|
||||
|
||||
Поэтому, в режиме Bypass --- просто пропускает сообщения, как
|
||||
есть, в обе стороны, не препятствуя. Как только удалось
|
||||
согласовать ключ --- то есть, получить HEYOURSELF --- то
|
||||
включаем шифрование.
|
||||
|
||||
Если пинг прислал нам HEYOURSELF, а сам незашифрованные
|
||||
сообщения шлёт -- ну дурак, чо. Надо проинформировать об этом
|
||||
в лог, может забанить его.
|
||||
|
||||
В режиме Drop -- ставит сообщения в очередь, пока не появился
|
||||
ключ.
|
||||
|
||||
Как только ключ появился --- шифрует и отправляет.
|
||||
|
||||
Пиры авторизуются друг у друга при помощи протокола Ping.
|
||||
|
||||
Никаких других ходить не должно до этого, это в принципе ошибка.
|
||||
|
||||
Соответственно, пока пиры не авторизовались --- никакого обмена
|
||||
нет.
|
||||
|
||||
Даже если мы этот пинг дропнем --- пир нас пинганёт еще раз.
|
||||
|
||||
@strong{Про Sid} Так как один и тот же пир может быть под разными
|
||||
адресами одновременно, а PeerNonce и прочее --- на этом уровне протокола
|
||||
недоступно --- будем генерировать уникальный ключ для каждого пира по
|
||||
адресу, и в HEYOURSELF пересылать Sid ключа. Пир будет сохранять пару
|
||||
(Sid, SECRET) --- и в ответе будет брать нужный ключ.
|
||||
|
||||
Проблема, если мы пишем пиру на один адрес (каким нам ключом шифровать?),
|
||||
а он отвечает нам с другого адреса.
|
||||
|
||||
PeerNonce недоступен, что делать?
|
||||
|
||||
Кейс:
|
||||
|
||||
Peer1: Peer2:
|
||||
tcp:1.1.1.1:8957 -> tcp:1.1.10.5:8001
|
||||
<- tcp:1.1.10.5:62511
|
||||
|
||||
|
||||
В HEYO(SELF) посылаем ему ID ключа, он где-то (где?) запоминает,
|
||||
что нам надо слать c таким ID ключа.
|
||||
|
||||
|
||||
|
||||
@bye
|
||||
|
||||
|
||||
|
|
@ -101,6 +101,8 @@ library
|
|||
, HBS2.Net.Messaging.TCP
|
||||
, HBS2.Net.Messaging.Unix
|
||||
, HBS2.Net.Messaging.Stream
|
||||
, HBS2.Net.Messaging.Encrypted.RandomPrefix
|
||||
, HBS2.Net.Messaging.Encrypted.ByPass
|
||||
, HBS2.Net.PeerLocator
|
||||
, HBS2.Net.PeerLocator.Static
|
||||
, HBS2.Net.Proto
|
||||
|
|
|
|||
|
|
@ -47,20 +47,6 @@ import Control.Monad.IO.Unlift
|
|||
import Codec.Serialise (serialise, deserialiseOrFail)
|
||||
|
||||
|
||||
data AnyMessage enc e = AnyMessage !Integer !(Encoded e)
|
||||
deriving stock (Generic)
|
||||
|
||||
|
||||
class ( Messaging (Fabriq e) e (AnyMessage (Encoded e) e)
|
||||
, Eq (Encoded e)
|
||||
, Hashable (Encoded e)
|
||||
) => PeerMessaging e
|
||||
|
||||
instance ( Messaging (Fabriq e) e (AnyMessage (Encoded e) e)
|
||||
, Eq (Encoded e)
|
||||
, Hashable (Encoded e)
|
||||
)
|
||||
=> PeerMessaging e
|
||||
|
||||
class ( Eq (SessionKey e a)
|
||||
, Hashable (SessionKey e a)
|
||||
|
|
@ -379,6 +365,7 @@ newPeerEnv :: forall e m . ( MonadIO m
|
|||
, Ord (Peer e)
|
||||
, Pretty (Peer e)
|
||||
, HasNonces () m
|
||||
, PeerMessaging e
|
||||
, Asymm (Encryption e)
|
||||
, Hashable (PubKey 'Sign (Encryption e))
|
||||
, Hashable PeerNonce
|
||||
|
|
@ -457,7 +444,7 @@ runProto hh = do
|
|||
|
||||
case Map.lookup n disp of
|
||||
Nothing -> do
|
||||
err $ "PROTO not found" <+> pretty n <+> pretty (fmap fst resp)
|
||||
-- err $ "PROTO not found" <+> pretty n <+> pretty (fmap fst resp)
|
||||
pure () -- FIXME: error counting! and statistics counting feature
|
||||
|
||||
Just (AnyProtocol { protoDecode = decoder
|
||||
|
|
|
|||
|
|
@ -36,7 +36,15 @@ class Monad m => HasOwnPeer e m where
|
|||
|
||||
data Fabriq e = forall bus . (Messaging bus e (Encoded e)) => Fabriq bus
|
||||
|
||||
|
||||
class HasFabriq e m where
|
||||
getFabriq :: m (Fabriq e)
|
||||
|
||||
data AnyMessage enc e = AnyMessage !Integer !(Encoded e)
|
||||
deriving stock (Generic)
|
||||
|
||||
type PeerMessaging e = ( Messaging (Fabriq e) e (AnyMessage (Encoded e) e)
|
||||
, Eq (Encoded e)
|
||||
, Hashable (Encoded e)
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -162,9 +162,6 @@ lookupGroupKey sk pk gk = runIdentity $ runMaybeT do
|
|||
-- error $ "DECRYPTED SHIT!"
|
||||
MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict gkBs) & either (const Nothing) Just
|
||||
|
||||
-- FIXME: move-to-appropriate-place
|
||||
class NonceFrom nonce a where
|
||||
nonceFrom :: a -> nonce
|
||||
|
||||
typicalNonceLength :: Integral a => a
|
||||
typicalNonceLength = unsafePerformIO SK.newNonce & Saltine.encode & B8.length & fromIntegral
|
||||
|
|
|
|||
|
|
@ -1,7 +1,9 @@
|
|||
{-# Language FunctionalDependencies #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
module HBS2.Net.Messaging where
|
||||
module HBS2.Net.Messaging
|
||||
( module HBS2.Net.Messaging
|
||||
, module HBS2.Net.Proto
|
||||
) where
|
||||
|
||||
import HBS2.Net.Proto
|
||||
|
||||
|
|
@ -20,3 +22,4 @@ class HasPeer proto => Messaging bus proto msg where
|
|||
sendTo :: MonadIO m => bus -> To proto -> From proto -> msg -> m ()
|
||||
receive :: MonadIO m => bus -> To proto -> m [(From proto, msg)]
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,517 @@
|
|||
{-# Language UndecidableInstances #-}
|
||||
{-# Language RecordWildCards #-}
|
||||
module HBS2.Net.Messaging.Encrypted.ByPass
|
||||
( ForByPass
|
||||
, ByPass
|
||||
, ByPassOpts(..)
|
||||
, ByPassStat(..)
|
||||
, byPassDef
|
||||
, newByPassMessaging
|
||||
, cleanupByPassMessaging
|
||||
, getStat
|
||||
) where
|
||||
|
||||
import HBS2.Prelude
|
||||
import HBS2.Hash
|
||||
import HBS2.Clock hiding (sec)
|
||||
import HBS2.Net.Messaging
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Net.Proto.Definition()
|
||||
import HBS2.Net.Auth.Credentials()
|
||||
|
||||
import HBS2.Net.Messaging.Encrypted.RandomPrefix
|
||||
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import Codec.Serialise
|
||||
import Control.Concurrent.STM (flushTQueue)
|
||||
import Control.Monad.Identity
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Network.ByteOrder qualified as N
|
||||
import Crypto.Saltine.Core.Box (Keypair(..),CombinedKey)
|
||||
import Crypto.Saltine.Class qualified as SA
|
||||
import Crypto.Saltine.Core.Box qualified as PKE
|
||||
import Data.Bits
|
||||
import Data.ByteArray.Hash qualified as BA
|
||||
import Data.ByteArray.Hash (SipHash(..), SipKey(..))
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HashMap
|
||||
import Data.HashSet qualified as HashSet
|
||||
import Data.Maybe
|
||||
import Data.Time.Clock.POSIX
|
||||
import Data.Word
|
||||
import System.Random
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import UnliftIO
|
||||
|
||||
heySeed :: Word8
|
||||
heySeed = 117
|
||||
|
||||
newtype NonceA = NonceA { fromNonceA :: Word16 }
|
||||
deriving newtype (Eq,Ord,Show,Pretty,Real,Num,Enum,Integral,Hashable)
|
||||
deriving stock Generic
|
||||
|
||||
type FlowKey = Word32
|
||||
|
||||
instance Serialise NonceA
|
||||
|
||||
mySipHash :: Integral a => BS.ByteString -> a
|
||||
mySipHash s = BA.sipHash (SipKey a b) s
|
||||
& \(SipHash w) -> fromIntegral w
|
||||
where
|
||||
a = 3857206264
|
||||
b = 1307114574
|
||||
|
||||
|
||||
-- NOTE: key-update-on-fly
|
||||
-- мы можем на ходу менять ключи:
|
||||
-- меняем nonceA, перегенеряем ключ, больше ничего не трогаем:
|
||||
-- тогда пакеты посланные для старого nonceA можно будет расшифровать,
|
||||
-- а шифровать уже для нового.
|
||||
--
|
||||
-- Таким образом, хост может иметь много flow с разными
|
||||
-- нонсами одновременно
|
||||
--
|
||||
|
||||
|
||||
data ByPassOpts e =
|
||||
ByPassOpts
|
||||
{ byPassEnabled :: Bool
|
||||
, byPassKeyAllowed :: PubKey 'Sign (Encryption e) -> IO Bool
|
||||
, byPassTimeRange :: Maybe (Int, Int)
|
||||
}
|
||||
|
||||
data ByPassStat =
|
||||
ByPassStat
|
||||
{ statBypassed :: Int
|
||||
, statEncrypted :: Int
|
||||
, statDecrypted :: Int
|
||||
, statDecryptFails :: Int
|
||||
, statSent :: Int
|
||||
, statReceived :: Int
|
||||
, statFlowNum :: Int
|
||||
, statPeers :: Int
|
||||
, statAuthFail :: Int
|
||||
}
|
||||
deriving stock (Show,Generic)
|
||||
|
||||
instance Serialise ByPassStat
|
||||
|
||||
data ByPass e them =
|
||||
ByPass
|
||||
{ opts :: ByPassOpts e
|
||||
, self :: Peer e
|
||||
, pks :: PubKey 'Sign (Encryption e)
|
||||
, sks :: PrivKey 'Sign (Encryption e)
|
||||
, pke :: PubKey 'Encrypt (Encryption e)
|
||||
, ske :: PrivKey 'Encrypt (Encryption e)
|
||||
, proxied :: them
|
||||
, nonceA :: NonceA
|
||||
, delayed :: TQueue (To e, ByteString)
|
||||
, heySent :: TVar (HashMap (Peer e) TimeSpec)
|
||||
, noncesByPeer :: TVar (HashMap (Peer e) NonceA)
|
||||
, flowKeys :: TVar (HashMap FlowKey CombinedKey)
|
||||
, bypassed :: TVar Int
|
||||
, encrypted :: TVar Int
|
||||
, decrypted :: TVar Int
|
||||
, decryptFails :: TVar Int
|
||||
, sentNum :: TVar Int
|
||||
, recvNum :: TVar Int
|
||||
, authFail :: TVar Int
|
||||
}
|
||||
|
||||
type ForByPass e = ( Hashable (Peer e)
|
||||
, Pretty (Peer e)
|
||||
, Eq (PubKey 'Sign (Encryption e))
|
||||
, Serialise (PubKey 'Sign (Encryption e))
|
||||
, PrivKey 'Encrypt (Encryption e) ~ PKE.SecretKey
|
||||
, PubKey 'Encrypt (Encryption e) ~ PKE.PublicKey
|
||||
, ForSignedBox e
|
||||
)
|
||||
|
||||
|
||||
data HEYBox e =
|
||||
HEYBox Int (PubKey 'Encrypt (Encryption e))
|
||||
deriving stock Generic
|
||||
|
||||
instance ForByPass e => Serialise (HEYBox e)
|
||||
|
||||
data EncryptHandshake e =
|
||||
HEY
|
||||
{ heyNonceA :: NonceA
|
||||
, heyBox :: SignedBox (HEYBox e) e
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
instance ForByPass e => Serialise (EncryptHandshake e)
|
||||
|
||||
getStat :: forall e w m . ( ForByPass e
|
||||
, MonadIO m
|
||||
)
|
||||
=> ByPass e w
|
||||
-> m ByPassStat
|
||||
getStat bus = liftIO $
|
||||
ByPassStat <$> readTVarIO (bypassed bus)
|
||||
<*> readTVarIO (encrypted bus)
|
||||
<*> readTVarIO (decrypted bus)
|
||||
<*> readTVarIO (decryptFails bus)
|
||||
<*> readTVarIO (sentNum bus)
|
||||
<*> readTVarIO (recvNum bus)
|
||||
<*> (readTVarIO (flowKeys bus) <&> HashMap.size)
|
||||
<*> (readTVarIO (noncesByPeer bus) <&> HashMap.size)
|
||||
<*> readTVarIO (authFail bus)
|
||||
|
||||
cleanupByPassMessaging :: forall e w m . ( ForByPass e
|
||||
, MonadIO m
|
||||
)
|
||||
=> ByPass e w
|
||||
-> [Peer e]
|
||||
-> m ()
|
||||
|
||||
cleanupByPassMessaging bus pips = do
|
||||
debug "cleanupByPassMessaging"
|
||||
|
||||
let alive = HashSet.fromList pips
|
||||
|
||||
atomically do
|
||||
sent <- readTVar (heySent bus)
|
||||
nonces <- readTVar (noncesByPeer bus)
|
||||
flows <- readTVar (flowKeys bus)
|
||||
|
||||
let livePeers = [ (k,v)
|
||||
| (k,v) <- HashMap.toList nonces
|
||||
, k `HashSet.member` alive
|
||||
] & HashMap.fromList
|
||||
|
||||
let liveSent = HashMap.filterWithKey (\k _ -> k `HashMap.member` livePeers) sent
|
||||
|
||||
let liveFk = [ makeKey (nonceA bus) nonce
|
||||
| nonce <- HashMap.elems livePeers
|
||||
] & HashSet.fromList
|
||||
|
||||
let liveFlows = HashMap.filterWithKey (\k _ -> k `HashSet.member` liveFk) flows
|
||||
|
||||
writeTVar (heySent bus) liveSent
|
||||
writeTVar (noncesByPeer bus) livePeers
|
||||
writeTVar (flowKeys bus) liveFlows
|
||||
|
||||
|
||||
byPassDef :: ByPassOpts e
|
||||
byPassDef =
|
||||
ByPassOpts
|
||||
{ byPassEnabled = True
|
||||
, byPassKeyAllowed = const $ pure True
|
||||
, byPassTimeRange = Nothing
|
||||
}
|
||||
|
||||
newByPassMessaging :: forall e w m . ( ForByPass e
|
||||
, MonadIO m
|
||||
, Messaging w e ByteString
|
||||
)
|
||||
=> ByPassOpts e
|
||||
-> w
|
||||
-> Peer e
|
||||
-> PubKey 'Sign (Encryption e)
|
||||
-> PrivKey 'Sign (Encryption e)
|
||||
-> m (ByPass e w)
|
||||
|
||||
newByPassMessaging o w self ps sk = do
|
||||
(Keypair s p) <- liftIO PKE.newKeypair
|
||||
let n = mySipHash (LBS.toStrict (serialise s))
|
||||
ByPass @e o self ps sk p s w n <$> newTQueueIO
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO 0
|
||||
|
||||
instance (ForByPass e, Messaging w e ByteString)
|
||||
=> Messaging (ByPass e w) e ByteString where
|
||||
|
||||
sendTo bus t@(To whom) f m = do
|
||||
|
||||
mkey <- lookupEncKey bus whom
|
||||
|
||||
atomically $ modifyTVar (sentNum bus) succ
|
||||
|
||||
case mkey of
|
||||
Just fck -> do
|
||||
sendTo (proxied bus) t f =<< encryptMessage bus fck m
|
||||
|
||||
Nothing -> do
|
||||
-- let ByPassOpts{..} = opts bus
|
||||
|
||||
if False then do
|
||||
atomically $ writeTQueue (delayed bus) (t,m)
|
||||
else do
|
||||
trace $ "bypassed message to" <+> pretty whom
|
||||
atomically $ modifyTVar (bypassed bus) succ
|
||||
sendTo (proxied bus) t f m
|
||||
|
||||
-- TODO: fix-timeout-hardcode
|
||||
withHeySent bus 30 whom do
|
||||
sendHey bus whom
|
||||
|
||||
receive bus f = do
|
||||
msgs <- receive (proxied bus) f
|
||||
|
||||
q <- newTQueueIO
|
||||
|
||||
-- TODO: run-concurrently
|
||||
for_ msgs $ \(From who, mess) -> runMaybeT do
|
||||
|
||||
atomically $ modifyTVar (recvNum bus) succ
|
||||
|
||||
hshake <- processHey who mess
|
||||
|
||||
guard (not hshake)
|
||||
|
||||
msg <- tryDecryptMessage bus mess
|
||||
|
||||
case msg of
|
||||
Just demsg -> do
|
||||
atomically $ writeTQueue q (From who, demsg)
|
||||
|
||||
Nothing -> do
|
||||
withHeySent bus 60 who do
|
||||
sendHey bus who
|
||||
|
||||
atomically $ writeTQueue q (From who, mess)
|
||||
|
||||
liftIO $ atomically $ flushTQueue q
|
||||
|
||||
where
|
||||
processHey orig bs = isJust <$> runMaybeT do
|
||||
|
||||
let o = opts bus
|
||||
|
||||
let (code, hbs) = runCodeLazy bs
|
||||
|
||||
-- FIXME: check-code
|
||||
guard ( code == Just heySeed )
|
||||
|
||||
debug $ "HEY CODE:" <+> pretty code
|
||||
|
||||
guard (not (LBS.null hbs))
|
||||
|
||||
hshake <- toMPlus (deserialiseOrFail @(EncryptHandshake e) hbs)
|
||||
|
||||
case hshake of
|
||||
HEY{..} -> do-- void $ runMaybeT do
|
||||
debug $ "GOT HEY MESSAGE" <+> parens (pretty code) <+> pretty heyNonceA
|
||||
|
||||
-- FIXME: check-if-key-authorized
|
||||
|
||||
let mbx = unboxSignedBox0 heyBox
|
||||
|
||||
when (isNothing mbx) do
|
||||
debug $ "HEY: failed to unbox" <+> pretty heyNonceA <+> pretty orig
|
||||
|
||||
n <- toMPlus mbx
|
||||
|
||||
-- FIXME: authorize-pk-right-here
|
||||
(pks, HEYBox t puk) <- toMPlus mbx
|
||||
|
||||
let dt = byPassTimeRange o
|
||||
|
||||
allowed <- liftIO $ byPassKeyAllowed o pks
|
||||
now <- liftIO getPOSIXTime <&> round
|
||||
let actual = maybe1 dt True (\(ta, tb) -> t >= now - ta && t <= now + tb)
|
||||
|
||||
let authorized = allowed && actual
|
||||
|
||||
unless authorized do
|
||||
atomically $ modifyTVar (authFail bus) succ
|
||||
warn $ "ByPass:" <+> "NOT AUTHORIZED" <+> pretty orig
|
||||
|
||||
when authorized do
|
||||
debug $ "ByPass:" <+> "AUTHORIZED" <+> pretty now <+> pretty orig
|
||||
|
||||
guard authorized
|
||||
|
||||
let fk = makeKey (nonceA bus) heyNonceA
|
||||
|
||||
here <- readTVarIO (flowKeys bus) <&> HashMap.member fk
|
||||
|
||||
updatePeerNonce bus orig heyNonceA
|
||||
|
||||
unless here do
|
||||
|
||||
let ck = PKE.beforeNM (ske bus) puk
|
||||
|
||||
debug $ "HEY: CK" <+> pretty (nonceA bus)
|
||||
<+> pretty fk
|
||||
<+> pretty (hashObject @HbSync (SA.encode ck))
|
||||
|
||||
atomically $ do
|
||||
modifyTVar (flowKeys bus) (HashMap.insert fk ck)
|
||||
|
||||
withHeySent bus 30 orig do
|
||||
sendHey bus orig
|
||||
|
||||
pure hshake
|
||||
|
||||
makeKey :: NonceA -> NonceA -> FlowKey
|
||||
makeKey a b = runIdentity do
|
||||
let aa = fromIntegral a :: FlowKey
|
||||
let bb = fromIntegral b :: FlowKey
|
||||
|
||||
let (f0,f1) = if aa < bb then (aa,bb) else (bb,aa)
|
||||
|
||||
pure $ (f0 `shiftL` 16) .|. f1
|
||||
|
||||
|
||||
sendHey :: forall e w m . ( ForByPass e
|
||||
, Messaging w e ByteString
|
||||
, MonadIO m
|
||||
)
|
||||
=> ByPass e w
|
||||
-> Peer e
|
||||
-> m ()
|
||||
|
||||
sendHey bus whom = do
|
||||
|
||||
pref <- randomPrefix (PrefixMethod1 4 11 heySeed) <&> toLazyByteString
|
||||
|
||||
let (code, _) = runCodeLazy pref
|
||||
|
||||
ts <- liftIO getPOSIXTime <&> round
|
||||
|
||||
let hbox = HEYBox @e ts (pke bus)
|
||||
let box = makeSignedBox @e (pks bus) (sks bus) hbox
|
||||
let hey = HEY @e (nonceA bus) box
|
||||
let msg = pref <> serialise hey
|
||||
|
||||
debug $ "SEND HEY" <+> pretty (heyNonceA hey)
|
||||
<+> parens ("seed" <+> pretty code)
|
||||
<+> pretty whom
|
||||
<+> pretty (LBS.length msg)
|
||||
|
||||
sendTo (proxied bus) (To whom) (From (self bus)) msg
|
||||
|
||||
withHeySent :: forall e w m . (MonadIO m, ForByPass e)
|
||||
=> ByPass e w
|
||||
-> Timeout 'Seconds
|
||||
-> Peer e
|
||||
-> m ()
|
||||
-> m ()
|
||||
|
||||
withHeySent w ts pip m = do
|
||||
now <- getTimeCoarse
|
||||
|
||||
t0 <- readTVarIO (heySent w) <&> HashMap.lookup pip
|
||||
<&> fromMaybe 0
|
||||
|
||||
let elapsed = toNanoSeconds $ TimeoutTS (now - t0)
|
||||
|
||||
when ( elapsed >= toNanoSeconds ts ) do
|
||||
atomically $ modifyTVar (heySent w) (HashMap.insert pip now)
|
||||
m
|
||||
|
||||
|
||||
updatePeerNonce :: forall e w m . ( ForByPass e
|
||||
, MonadIO m
|
||||
)
|
||||
=> ByPass e w
|
||||
-> Peer e
|
||||
-> NonceA
|
||||
-> m ()
|
||||
|
||||
updatePeerNonce bus pip nonce = do
|
||||
atomically $ modifyTVar (noncesByPeer bus) (HashMap.insert pip nonce)
|
||||
|
||||
lookupEncKey :: (ForByPass e, MonadIO m) => ByPass e w -> Peer e -> m (Maybe (FlowKey, CombinedKey))
|
||||
lookupEncKey bus whom = runMaybeT do
|
||||
nonce <- MaybeT $ readTVarIO (noncesByPeer bus) <&> HashMap.lookup whom
|
||||
let fk = makeKey nonce (nonceA bus)
|
||||
ck <- MaybeT $ readTVarIO (flowKeys bus) <&> HashMap.lookup fk
|
||||
pure (fk, ck)
|
||||
|
||||
|
||||
typicalNonceLength :: Integral a => a
|
||||
typicalNonceLength = unsafePerformIO PKE.newNonce & SA.encode & BS.length & fromIntegral
|
||||
{-# NOINLINE typicalNonceLength #-}
|
||||
|
||||
newtype ByPassNonce = ByPassNonce { unByPassNonce :: PKE.Nonce }
|
||||
|
||||
instance NonceFrom ByPassNonce Word32 where
|
||||
nonceFrom a = ByPassNonce nonce
|
||||
where
|
||||
n = typicalNonceLength
|
||||
nonce = fromJust (SA.decode s)
|
||||
s = BS.take n (N.bytestring32 a <> BS.replicate n 0)
|
||||
|
||||
|
||||
tryDecryptMessage :: (MonadIO m, ForByPass e)
|
||||
=> ByPass e w
|
||||
-> ByteString
|
||||
-> m (Maybe ByteString)
|
||||
|
||||
tryDecryptMessage bus bs = runMaybeT do
|
||||
|
||||
let (hdr, body) = LBS.splitAt 8 bs
|
||||
|
||||
guard (LBS.length hdr == 8)
|
||||
|
||||
(fk, wnonce) <- liftIO $ N.withReadBuffer (LBS.toStrict hdr) $ \buf -> do
|
||||
(,) <$> N.read32 buf <*> N.read32 buf
|
||||
|
||||
let bnonce = nonceFrom @ByPassNonce wnonce
|
||||
|
||||
ck <- MaybeT $ readTVarIO (flowKeys bus) <&> HashMap.lookup fk
|
||||
|
||||
let dmess = PKE.boxOpenAfterNM ck (unByPassNonce bnonce) (LBS.toStrict body) <&> LBS.fromStrict
|
||||
|
||||
atomically do
|
||||
maybe1 dmess
|
||||
(modifyTVar (decryptFails bus) succ)
|
||||
(const $ modifyTVar (decrypted bus) succ)
|
||||
|
||||
toMPlus dmess
|
||||
|
||||
|
||||
encryptMessage :: (MonadIO m, ForByPass e)
|
||||
=> ByPass e w
|
||||
-> (FlowKey, CombinedKey)
|
||||
-> ByteString
|
||||
-> m ByteString
|
||||
|
||||
encryptMessage bus (fk, ck) bs = do
|
||||
|
||||
atomically $ modifyTVar (encrypted bus) succ
|
||||
|
||||
wnonce <- liftIO (randomIO @Word32)
|
||||
let bnonce = nonceFrom @ByPassNonce wnonce
|
||||
|
||||
let ebs = PKE.boxAfterNM ck (unByPassNonce bnonce) (LBS.toStrict bs)
|
||||
|
||||
let pkt = mconcat [ word32BE fk
|
||||
, word32BE wnonce
|
||||
, byteString ebs
|
||||
] & toLazyByteString
|
||||
|
||||
pure pkt
|
||||
|
||||
instance Pretty ByPassStat where
|
||||
pretty (ByPassStat{..}) =
|
||||
vcat [ prettyField "bypassed" statBypassed
|
||||
, prettyField "encrypted" statEncrypted
|
||||
, prettyField "decrypted" statDecrypted
|
||||
, prettyField "decryptFails" statDecryptFails
|
||||
, prettyField "sent" statSent
|
||||
, prettyField "received" statReceived
|
||||
, prettyField "flowNum" statFlowNum
|
||||
, prettyField "peers" statPeers
|
||||
, prettyField "authFail" statAuthFail
|
||||
]
|
||||
where
|
||||
prettyField x e = fill 15 (x <> colon) <+> pretty e
|
||||
|
||||
|
|
@ -0,0 +1,244 @@
|
|||
{-# Language AllowAmbiguousTypes #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
{-# Language TypeFamilyDependencies #-}
|
||||
module HBS2.Net.Messaging.Encrypted.RandomPrefix
|
||||
( module Data.ByteString.Builder
|
||||
, runCodeLazy
|
||||
, RandomPrefix(..)
|
||||
, PrefixMethod1(..)
|
||||
) where
|
||||
|
||||
import Data.Word
|
||||
import Data.Bits
|
||||
-- import Data.ByteString (ByteString)
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.ByteString.Builder
|
||||
import Data.Maybe
|
||||
import Lens.Micro.Platform
|
||||
import Data.Kind
|
||||
import GHC.TypeLits
|
||||
import Data.Proxy
|
||||
import Safe
|
||||
import Data.List.Split (chunksOf)
|
||||
import System.Random hiding (next)
|
||||
|
||||
data NOP
|
||||
data LOADB
|
||||
data SKIPBI
|
||||
data ANDBI
|
||||
data ORBI
|
||||
data XORBI
|
||||
data ADDBI
|
||||
data SUBBI
|
||||
data MULTBI
|
||||
data REPEAT
|
||||
data RET
|
||||
|
||||
class Emittable a where
|
||||
emit :: a -> Builder
|
||||
|
||||
class (Emittable (Arg a), KnownNat (Opcode a)) => Instruction a where
|
||||
type family Opcode a = (code :: Nat) | code -> a
|
||||
type family Arg a :: Type
|
||||
|
||||
data OP = forall a . (Instruction a, Emittable (Proxy a)) =>
|
||||
OP (Proxy a) (Arg a) | BYTE Word8
|
||||
|
||||
instance Instruction a => Emittable (Proxy a) where
|
||||
emit _ = word8 . fromIntegral $ natVal (Proxy @(Opcode a))
|
||||
|
||||
instance Emittable OP where
|
||||
emit (OP op arg) = emit op <> emit arg
|
||||
emit (BYTE w) = word8 w
|
||||
|
||||
instance Emittable () where
|
||||
emit = mempty
|
||||
|
||||
instance Emittable Word8 where
|
||||
emit = word8
|
||||
|
||||
instance Emittable b => Emittable [b] where
|
||||
emit xs= mconcat (fmap emit xs)
|
||||
|
||||
instance Instruction NOP where
|
||||
type instance Opcode NOP = 0xFE
|
||||
type instance Arg NOP = ()
|
||||
|
||||
instance Instruction LOADB where
|
||||
type instance Opcode LOADB = 0x01
|
||||
type instance Arg LOADB = Word8
|
||||
|
||||
instance Instruction SKIPBI where
|
||||
type instance Opcode SKIPBI = 0x02
|
||||
type instance Arg SKIPBI = Word8
|
||||
|
||||
instance Instruction ORBI where
|
||||
type instance Opcode ORBI= 0x03
|
||||
type instance Arg ORBI = Word8
|
||||
|
||||
instance Instruction ANDBI where
|
||||
type instance Opcode ANDBI= 0x04
|
||||
type instance Arg ANDBI = Word8
|
||||
|
||||
instance Instruction XORBI where
|
||||
type instance Opcode XORBI= 0x05
|
||||
type instance Arg XORBI = Word8
|
||||
|
||||
instance Instruction ADDBI where
|
||||
type instance Opcode ADDBI = 0x06
|
||||
type instance Arg ADDBI = Word8
|
||||
|
||||
instance Instruction SUBBI where
|
||||
type instance Opcode SUBBI = 0x07
|
||||
type instance Arg SUBBI = Word8
|
||||
|
||||
instance Instruction MULTBI where
|
||||
type instance Opcode MULTBI = 0x08
|
||||
type instance Arg MULTBI = Word8
|
||||
|
||||
instance Instruction REPEAT where
|
||||
type instance Opcode REPEAT = 0xC0
|
||||
type instance Arg REPEAT = Word8
|
||||
|
||||
instance Instruction RET where
|
||||
type instance Opcode RET = 0x00
|
||||
type instance Arg RET = ()
|
||||
|
||||
op :: forall a . Instruction a
|
||||
=> Arg a
|
||||
-> OP
|
||||
|
||||
op = OP (Proxy @a)
|
||||
|
||||
byte :: Word8 -> OP
|
||||
byte = BYTE
|
||||
|
||||
runCodeLazy :: ByteString -> (Maybe Word8, ByteString)
|
||||
runCodeLazy s = runState (execStateT (runMaybeT (go s)) Nothing) s
|
||||
where
|
||||
|
||||
next = MaybeT . pure . LBS.uncons
|
||||
|
||||
update rest = do
|
||||
lift $ lift $ put rest
|
||||
pure rest
|
||||
|
||||
go bs = do
|
||||
r <- next bs
|
||||
void $ update (snd r)
|
||||
exec r >>= update
|
||||
>>= go
|
||||
|
||||
exec (b, rest)
|
||||
| b == code @NOP = nop rest
|
||||
| b == code @LOADB = loadb rest
|
||||
| b == code @SKIPBI = skipbi rest
|
||||
| b == code @ORBI = orbi rest
|
||||
| b == code @ANDBI = andbi rest
|
||||
| b == code @XORBI = xorbi rest
|
||||
| b == code @ADDBI = addbi rest
|
||||
| b == code @SUBBI = subbi rest
|
||||
| b == code @MULTBI = multi rest
|
||||
| b == code @RET = ret rest
|
||||
-- | b == code @REPEAT = repeatN rest -- dangerous
|
||||
| otherwise = nop rest
|
||||
|
||||
ret _ = mzero -- pure
|
||||
|
||||
nop = pure
|
||||
|
||||
multi bs = do
|
||||
(n, rest) <- next bs
|
||||
apply (*) n
|
||||
pure rest
|
||||
|
||||
addbi bs = do
|
||||
(n, rest) <- next bs
|
||||
apply (+) n
|
||||
pure rest
|
||||
|
||||
subbi bs = do
|
||||
(n, rest) <- next bs
|
||||
apply (-) n
|
||||
pure rest
|
||||
|
||||
orbi bs = do
|
||||
(n, rest) <- next bs
|
||||
apply (.|.) n
|
||||
pure rest
|
||||
|
||||
andbi bs = do
|
||||
(n, rest) <- next bs
|
||||
apply (.&.) n
|
||||
pure rest
|
||||
|
||||
xorbi bs = do
|
||||
(n, rest) <- next bs
|
||||
apply xor n
|
||||
pure rest
|
||||
|
||||
skipbi bs = do
|
||||
(n, rest) <- next bs
|
||||
let r2 = LBS.drop (fromIntegral n) rest
|
||||
update r2
|
||||
pure r2
|
||||
|
||||
loadb bs = do
|
||||
(n, rest) <- next bs
|
||||
put (Just n)
|
||||
pure rest
|
||||
|
||||
repeatN bs = do
|
||||
(n, rest) <- next bs
|
||||
|
||||
rest' <- replicateM (min 16 (fromIntegral n)) $ do
|
||||
next rest >>= exec
|
||||
|
||||
pure (headDef "" rest')
|
||||
|
||||
apply fn n = do
|
||||
st <- get
|
||||
put $ Just $ fromMaybe 0 st `fn` fromIntegral n
|
||||
|
||||
code :: forall a b . (Integral b, Instruction a) => b
|
||||
code = fromIntegral (natVal (Proxy @(Opcode a)))
|
||||
|
||||
|
||||
class (Monad m) => RandomPrefix a m where
|
||||
randomPrefix :: a -> m Builder
|
||||
|
||||
data PrefixMethod1 = PrefixMethod1 Int Word8 Word8
|
||||
|
||||
partsMethod1 :: Int -> Word8 -> Word8 -> [Word8]
|
||||
partsMethod1 k b n = nums
|
||||
where
|
||||
(d, r) = n `divMod` b
|
||||
nums = r : replicate (fromIntegral d) b & chunksOf k & fmap sum
|
||||
|
||||
instance MonadIO m => RandomPrefix PrefixMethod1 m where
|
||||
|
||||
randomPrefix (PrefixMethod1 k a x) = liftIO do
|
||||
let nums = partsMethod1 k a x
|
||||
me <- liftIO $ replicateM (length nums) $ randomRIO (0,2)
|
||||
opcodes <- forM (zip me nums) $ \z@(_, n) ->
|
||||
case fst z of
|
||||
1 -> do
|
||||
let (w,p) = n `divMod` 2
|
||||
pure $ op @ADDBI p : replicate 2 (op @ADDBI w)
|
||||
|
||||
2 -> do
|
||||
j <- randomIO @Word8
|
||||
pure [ op @SUBBI j, op @ADDBI (n+j) ]
|
||||
|
||||
_ -> pure [ op @ADDBI n ]
|
||||
|
||||
sn <- randomRIO (1,6)
|
||||
bytes <- replicateM sn (randomIO @Word8) <&> fmap byte
|
||||
let fin = op @SKIPBI (fromIntegral sn) : bytes
|
||||
|
||||
pure $ emit $ mconcat opcodes <> fin <> [ op @RET () ]
|
||||
|
||||
|
|
@ -29,6 +29,9 @@ import Data.ByteString (ByteString)
|
|||
-- e -> Transport (like, UDP or TChan)
|
||||
-- p -> L4 Protocol (like Ping/Pong)
|
||||
|
||||
class NonceFrom nonce a where
|
||||
nonceFrom :: a -> nonce
|
||||
|
||||
data CryptoAction = Sign | Encrypt
|
||||
|
||||
data GroupKeyScheme = Symm | Asymm
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
{-# Language FunctionalDependencies #-}
|
||||
module HBS2.Prelude
|
||||
( module Data.String
|
||||
, module Safe
|
||||
|
|
@ -18,7 +17,7 @@ module HBS2.Prelude
|
|||
, ToByteString(..)
|
||||
, FromByteString(..)
|
||||
, Text.Text
|
||||
, (&), (<&>)
|
||||
, (&), (<&>), for_, for
|
||||
) where
|
||||
|
||||
import Data.Typeable as X
|
||||
|
|
@ -32,6 +31,9 @@ import Control.Monad (guard,when,unless,MonadPlus(..))
|
|||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.Maybe
|
||||
|
||||
|
||||
import Data.Foldable(for_)
|
||||
import Data.Traversable(for)
|
||||
import Data.Kind
|
||||
import Data.Function
|
||||
import Data.Functor
|
||||
|
|
|
|||
|
|
@ -0,0 +1,57 @@
|
|||
module ByPassWorker where
|
||||
|
||||
import HBS2.Prelude
|
||||
import HBS2.Clock
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.Net.Messaging.Encrypted.ByPass
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
|
||||
import HBS2.Net.Proto.Peer
|
||||
import HBS2.Net.Proto.PeerExchange
|
||||
import HBS2.Net.Proto.Sessions
|
||||
import HBS2.Net.Proto.Types
|
||||
|
||||
import PeerTypes
|
||||
|
||||
import Control.Monad
|
||||
import UnliftIO
|
||||
|
||||
|
||||
byPassWorker :: ( ForByPass e
|
||||
, MonadUnliftIO m
|
||||
, MonadIO m
|
||||
, HasPeer e
|
||||
, HasPeerLocator e m
|
||||
, Sessions e (KnownPeer e) m
|
||||
, Expires (SessionKey e (KnownPeer e))
|
||||
)
|
||||
=> ByPass e w
|
||||
-> PeerEnv e
|
||||
-> m ()
|
||||
|
||||
byPassWorker bp penv = do
|
||||
|
||||
tstat <- async $ forever do
|
||||
stats <- getStat bp
|
||||
info $ "ByPass stats"
|
||||
<> line
|
||||
<> indent 2 (pretty stats)
|
||||
<> line
|
||||
|
||||
pause @'Seconds 60
|
||||
|
||||
link tstat
|
||||
|
||||
gc <- async $ withPeerM penv $ forever do
|
||||
pips <- getKnownPeers
|
||||
cleanupByPassMessaging bp pips
|
||||
pause @'Seconds 600
|
||||
|
||||
link gc
|
||||
|
||||
void $ waitAnyCatchCancel [tstat, gc]
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,70 @@
|
|||
{-# Language UndecidableInstances #-}
|
||||
module DispatchProxy
|
||||
( RouteFun
|
||||
, newDispatchProxy
|
||||
, runDispatchProxy
|
||||
, Dispatched(..)
|
||||
) where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Net.Messaging
|
||||
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import Control.Concurrent.STM.TQueue qualified as TQ
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Control.Monad
|
||||
|
||||
import UnliftIO
|
||||
|
||||
data Dispatched = forall bus . Messaging bus L4Proto ByteString => Dispatched bus
|
||||
|
||||
type RouteFun e = forall m . (MonadIO m)
|
||||
=> ByteString
|
||||
-> Peer e
|
||||
-> m (Maybe Dispatched)
|
||||
|
||||
|
||||
data DispatchProxy =
|
||||
DispatchProxy
|
||||
{ points :: [ (Peer L4Proto, Dispatched) ]
|
||||
, route :: RouteFun L4Proto
|
||||
, inbox :: TQueue (From L4Proto, ByteString)
|
||||
}
|
||||
|
||||
newDispatchProxy :: (MonadIO m)
|
||||
=> [ (Peer L4Proto, Dispatched) ]
|
||||
-> RouteFun L4Proto
|
||||
-> m DispatchProxy
|
||||
|
||||
newDispatchProxy p r = DispatchProxy p r <$> newTQueueIO
|
||||
|
||||
|
||||
runDispatchProxy :: forall m . ( MonadUnliftIO m
|
||||
)
|
||||
=> DispatchProxy
|
||||
-> m ()
|
||||
|
||||
runDispatchProxy d = do
|
||||
debug "runDispatchProxy"
|
||||
|
||||
ps <- for (points d) $ \(pip, Dispatched mess) -> async do
|
||||
forever do
|
||||
receive mess (To pip)
|
||||
>>= mapM_ (atomically . writeTQueue (inbox d))
|
||||
|
||||
mapM_ link ps
|
||||
void $ waitAnyCatchCancel ps
|
||||
|
||||
|
||||
instance Messaging DispatchProxy L4Proto ByteString where
|
||||
|
||||
sendTo bus t@(To whom) f m = do
|
||||
route bus m whom >>= maybe none sendRouted
|
||||
where
|
||||
sendRouted (Dispatched target) = sendTo target t f m
|
||||
|
||||
receive bus _ = do
|
||||
void $ atomically $ peekTQueue (inbox bus)
|
||||
liftIO $ atomically $ TQ.flushTQueue (inbox bus)
|
||||
|
||||
|
|
@ -46,8 +46,7 @@ downloadQueue _ brains denv = do
|
|||
|
||||
polling (Polling 5 20) refs $ \ref -> do
|
||||
missed <- findMissedBlocks sto ref
|
||||
|
||||
debug $ "DownloadQ. check" <+> pretty ref <+> pretty (length missed)
|
||||
trace $ "DownloadQ. check" <+> pretty ref <+> pretty (length missed)
|
||||
|
||||
when (null missed) do
|
||||
delDownload @e brains ref
|
||||
|
|
|
|||
|
|
@ -21,11 +21,10 @@ import HBS2.Net.IP.Addr
|
|||
import HBS2.Net.Messaging.UDP
|
||||
import HBS2.Net.Messaging.TCP
|
||||
import HBS2.Net.Messaging.Unix
|
||||
import HBS2.Net.Messaging.Encrypted.ByPass
|
||||
import HBS2.Net.PeerLocator
|
||||
import HBS2.Net.Proto as Proto
|
||||
import HBS2.Net.Proto.Definition
|
||||
-- import HBS2.Net.Proto.Dialog
|
||||
import HBS2.Net.Proto.EncryptionHandshake
|
||||
import HBS2.Net.Proto.Event.PeerExpired
|
||||
import HBS2.Net.Proto.Peer
|
||||
import HBS2.Net.Proto.PeerAnnounce
|
||||
|
|
@ -43,6 +42,7 @@ import HBS2.System.Logger.Simple hiding (info)
|
|||
|
||||
import Brains
|
||||
import BrainyPeerLocator
|
||||
import ByPassWorker
|
||||
import PeerTypes
|
||||
import BlockDownload
|
||||
import CheckBlockAnnounce (checkBlockAnnounce)
|
||||
|
|
@ -52,13 +52,10 @@ import PeerInfo
|
|||
import PeerConfig
|
||||
import Bootstrap
|
||||
import CheckMetrics
|
||||
import EncryptionKeys
|
||||
import RefLog qualified
|
||||
import RefLog (reflogWorker)
|
||||
import HttpWorker
|
||||
import ProxyMessaging
|
||||
-- import PeerMain.DialogCliCommand
|
||||
-- import PeerMain.Dialog.Server
|
||||
import DispatchProxy
|
||||
import PeerMeta
|
||||
import CLI.Common
|
||||
import CLI.RefChan
|
||||
|
|
@ -233,6 +230,7 @@ runCLI = do
|
|||
<> command "download" (info pDownload (progDesc "download management"))
|
||||
<> command "poll" (info pPoll (progDesc "polling management"))
|
||||
<> command "log" (info pLog (progDesc "set logging level"))
|
||||
<> command "bypass" (info pByPass (progDesc "bypass"))
|
||||
-- FIXME: bring-back-dialogue-over-separate-socket
|
||||
-- <> command "dial" (info pDialog (progDesc "dialog commands"))
|
||||
)
|
||||
|
|
@ -468,6 +466,16 @@ runCLI = do
|
|||
delta = now - fromIntegral u
|
||||
diff = formatTime defaultTimeLocale "%d:%H:%M:%S" delta
|
||||
|
||||
pByPass = hsubparser ( command "show" (info pByPassShow (progDesc "show bypass info" ))
|
||||
)
|
||||
|
||||
pByPassShow = do
|
||||
rpc <- pRpcCommon
|
||||
pure $ withMyRPC @PeerAPI rpc $ \caller -> do
|
||||
void $ runMaybeT do
|
||||
d <- toMPlus =<< callService @RpcByPassInfo caller ()
|
||||
liftIO $ print $ pretty d
|
||||
|
||||
refP :: ReadM (PubKey 'Sign HBS2Basic)
|
||||
refP = maybeReader fromStringMay
|
||||
|
||||
|
|
@ -629,6 +637,8 @@ runPeer opts = U.handle (\e -> myException e
|
|||
|
||||
udp <- async $ runMessagingUDP mess
|
||||
|
||||
let udpAddr = getOwnPeer mess
|
||||
|
||||
mcast <- newMessagingUDPMulticast defLocalMulticast
|
||||
`orDie` "Can't start RPC listener"
|
||||
|
||||
|
|
@ -652,43 +662,36 @@ runPeer opts = U.handle (\e -> myException e
|
|||
void $ async $ runMessagingTCP tcpEnv
|
||||
pure $ Just tcpEnv
|
||||
|
||||
(proxy, penv) <- mdo
|
||||
proxy <- newProxyMessaging mess tcp >>= \proxy' -> pure proxy'
|
||||
{ _proxy_getEncryptionKey = \peer -> do
|
||||
mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $
|
||||
withPeerM penv $ find (KnownPeerKey peer) id
|
||||
mkey <- join <$> forM mencKeyID \encKeyID ->
|
||||
getEncryptionKey proxy encKeyID
|
||||
case mkey of
|
||||
Nothing ->
|
||||
trace1 $ "ENCRYPTION empty getEncryptionKey"
|
||||
<+> pretty peer <+> viaShow mencKeyID
|
||||
Just k ->
|
||||
trace1 $ "ENCRYPTION success getEncryptionKey"
|
||||
<+> pretty peer <+> viaShow mencKeyID <+> viaShow k
|
||||
pure mkey
|
||||
let mudp = Just $ Dispatched mess
|
||||
|
||||
, _proxy_clearEncryptionKey = \peer -> do
|
||||
mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $
|
||||
withPeerM penv $ find (KnownPeerKey peer) id
|
||||
forM_ mencKeyID \encKeyID -> setEncryptionKey proxy peer encKeyID Nothing
|
||||
-- deletePeerAsymmKey brains peer
|
||||
forM_ mencKeyID \encKeyID ->
|
||||
deletePeerAsymmKey' brains (show encKeyID)
|
||||
let tcpaddr = view tcpOwnPeer <$> tcp
|
||||
|
||||
, _proxy_sendResetEncryptionKeys = \peer -> withPeerM penv do
|
||||
sendResetEncryptionKeys peer
|
||||
let mtcp = Dispatched <$> tcp
|
||||
|
||||
, _proxy_sendBeginEncryptionExchange = \peer -> withPeerM penv do
|
||||
sendBeginEncryptionExchange pc
|
||||
((pubKeyFromKeypair @s . _proxy_asymmetricKeyPair) proxy)
|
||||
peer
|
||||
let points = catMaybes [ (udpAddr ,) <$> mudp
|
||||
, (,) <$> tcpaddr <*> mtcp
|
||||
]
|
||||
|
||||
}
|
||||
penv <- newPeerEnv pl (AnyStorage s) (Fabriq proxy) (getOwnPeer mess)
|
||||
pure (proxy, penv)
|
||||
proxy <- newDispatchProxy points $ \_ pip -> case view sockType pip of
|
||||
TCP -> pure mtcp
|
||||
UDP -> pure mudp
|
||||
|
||||
proxyThread <- async $ runProxyMessaging proxy
|
||||
-- TODO: get-rid-of-from-addr
|
||||
-- From addres в Messaging -- пережиток,
|
||||
-- ни на что не влияет, ни для чего не нужен.
|
||||
-- Таскается везде со времени, когда Messaging был
|
||||
-- через TQueue. Нужно его удалить повсеместно
|
||||
-- Или сделать некий AnyAddr/DefaultAddr
|
||||
byPass <- newByPassMessaging @L4Proto
|
||||
byPassDef
|
||||
proxy
|
||||
(getOwnPeer mess)
|
||||
(view peerSignPk pc)
|
||||
(view peerSignSk pc)
|
||||
|
||||
penv <- newPeerEnv pl (AnyStorage s) (Fabriq byPass) (getOwnPeer mess)
|
||||
|
||||
proxyThread <- async $ runDispatchProxy proxy
|
||||
|
||||
let peerMeta = mkPeerMeta conf penv
|
||||
|
||||
|
|
@ -733,8 +736,8 @@ runPeer opts = U.handle (\e -> myException e
|
|||
if pro then do
|
||||
withPeerM penv $ withDownload denv (addDownload mzero h)
|
||||
else do
|
||||
-- FIXME: separate-process-to-mark-logs-processed
|
||||
withPeerM penv $ withDownload denv (processBlock h)
|
||||
setReflogProcessed @e brains h
|
||||
|
||||
let doFetchRef puk = do
|
||||
withPeerM penv $ do
|
||||
|
|
@ -753,45 +756,6 @@ 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
|
||||
mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $
|
||||
withPeerM penv $ find (KnownPeerKey peer) id
|
||||
case mpubkey of
|
||||
Nothing -> do
|
||||
-- trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow mencKeyID
|
||||
-- deletePeerAsymmKey brains peer
|
||||
forM_ mencKeyID \encKeyID ->
|
||||
deletePeerAsymmKey' brains (show encKeyID)
|
||||
Just pk -> do
|
||||
-- emit PeerAsymmInfoKey (PeerAsymmPubKey peer pk)
|
||||
let symmk = genCommonSecret @s
|
||||
(privKeyFromKeypair @s (_proxy_asymmetricKeyPair proxy))
|
||||
pk
|
||||
case mencKeyID of
|
||||
Nothing -> do
|
||||
-- insertPeerAsymmKey brains peer pk symmk
|
||||
-- insertPeerAsymmKey' brains (show peer) pk symmk
|
||||
trace $ "ENCRYPTION can not store key. No encKeyID"
|
||||
<+> pretty peer <+> viaShow mencKeyID
|
||||
Just encKeyID -> do
|
||||
liftIO $ setEncryptionKey proxy peer encKeyID (Just symmk)
|
||||
insertPeerAsymmKey' brains (show encKeyID) pk symmk
|
||||
|
||||
, encAsymmetricKeyPair = _proxy_asymmetricKeyPair proxy
|
||||
|
||||
, encGetEncryptionKey = liftIO . getEncryptionKey proxy
|
||||
|
||||
}
|
||||
|
||||
-- dialReqProtoAdapter <- do
|
||||
-- dialReqProtoAdapterDApp <- pure dialogRoutes
|
||||
-- pure DialReqProtoAdapter {..}
|
||||
|
||||
env <- ask
|
||||
|
||||
pnonce <- peerNonce @e
|
||||
|
|
@ -800,14 +764,6 @@ runPeer opts = U.handle (\e -> myException e
|
|||
|
||||
addPeers @e pl ps
|
||||
|
||||
subscribe @e PeerExpiredEventKey \(PeerExpiredEvent peer {-mpeerData-}) -> liftIO do
|
||||
mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $
|
||||
withPeerM penv $ find (KnownPeerKey peer) id
|
||||
forM_ mencKeyID \encKeyID -> setEncryptionKey proxy peer encKeyID Nothing
|
||||
-- deletePeerAsymmKey brains peer
|
||||
forM_ mencKeyID \encKeyID ->
|
||||
deletePeerAsymmKey' brains (show encKeyID)
|
||||
|
||||
subscribe @e PeerAnnounceEventKey $ \(PeerAnnounceEvent pip nonce) -> do
|
||||
unless (nonce == pnonce) $ do
|
||||
debug $ "Got peer announce!" <+> pretty pip
|
||||
|
|
@ -936,6 +892,8 @@ runPeer opts = U.handle (\e -> myException e
|
|||
debug "sending local peer announce"
|
||||
request localMulticast (PeerAnnounce @e pnonce)
|
||||
|
||||
peerThread "byPassWorker" (byPassWorker byPass penv)
|
||||
|
||||
peerThread "httpWorker" (httpWorker conf peerMeta denv)
|
||||
|
||||
peerThread "checkMetrics" (checkMetrics metrics)
|
||||
|
|
@ -952,14 +910,10 @@ runPeer opts = U.handle (\e -> myException e
|
|||
|
||||
peerThread "blockDownloadQ" (downloadQueue conf (SomeBrains brains) denv)
|
||||
|
||||
peerThread "encryptionHandshakeWorker"
|
||||
(EncryptionKeys.encryptionHandshakeWorker @e conf pc encryptionHshakeAdapter)
|
||||
|
||||
peerThread "fillPeerMeta" (fillPeerMeta tcp tcpProbeWait)
|
||||
|
||||
peerThread "postponedLoop" (postponedLoop denv)
|
||||
|
||||
|
||||
peerThread "reflogWorker" (reflogWorker @e conf (SomeBrains brains) rwa)
|
||||
|
||||
peerThread "refChanWorker" (refChanWorker @e rce (SomeBrains brains))
|
||||
|
|
@ -970,7 +924,7 @@ runPeer opts = U.handle (\e -> myException e
|
|||
, makeResponse (blockChunksProto adapter)
|
||||
, makeResponse blockAnnounceProto
|
||||
, makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter penv)
|
||||
, makeResponse (withCredentials @e pc . encryptionHandshakeProto encryptionHshakeAdapter)
|
||||
-- , makeResponse (withCredentials @e pc . encryptionHandshakeProto encryptionHshakeAdapter)
|
||||
, makeResponse peerExchangeProto
|
||||
, makeResponse refLogUpdateProto
|
||||
, makeResponse (refLogRequestProto reflogReqAdapter)
|
||||
|
|
@ -1067,6 +1021,7 @@ runPeer opts = U.handle (\e -> myException e
|
|||
, rpcLocalMultiCast = localMulticast
|
||||
, rpcStorage = AnyStorage s
|
||||
, rpcBrains = SomeBrains brains
|
||||
, rpcByPassInfo = liftIO (getStat byPass)
|
||||
, rpcDoFetch = liftIO . fetchHash penv denv
|
||||
, rpcDoRefChanHeadPost = refChanHeadPostAction
|
||||
, rpcDoRefChanPropose = refChanProposeAction
|
||||
|
|
@ -1084,6 +1039,7 @@ runPeer opts = U.handle (\e -> myException e
|
|||
, makeResponse (makeServer @StorageAPI)
|
||||
]
|
||||
|
||||
link proxyThread
|
||||
link rpcProto
|
||||
link loop
|
||||
|
||||
|
|
@ -1093,6 +1049,7 @@ runPeer opts = U.handle (\e -> myException e
|
|||
, rpcProto
|
||||
, ann
|
||||
, messMcast
|
||||
, proxyThread
|
||||
, brainsThread
|
||||
]
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,10 @@
|
|||
{-# Language UndecidableInstances #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
{-# Language MultiWayIf #-}
|
||||
module PeerTypes where
|
||||
module PeerTypes
|
||||
( module PeerTypes
|
||||
, module HBS2.Net.PeerLocator
|
||||
) where
|
||||
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.Clock
|
||||
|
|
|
|||
|
|
@ -1,260 +0,0 @@
|
|||
{-# Language TemplateHaskell #-}
|
||||
module ProxyMessaging
|
||||
( ProxyMessaging(..)
|
||||
, newProxyMessaging
|
||||
, runProxyMessaging
|
||||
, sendToPlainProxyMessaging
|
||||
, getEncryptionKey
|
||||
, setEncryptionKey
|
||||
, encryptionKeyIDKeyFromPeerData
|
||||
) 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 PeerTypes
|
||||
|
||||
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 Control.Monad.Trans.Maybe
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Hashable hiding (Hashed)
|
||||
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 as Lens
|
||||
import Control.Monad
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HashMap
|
||||
|
||||
import HBS2.Data.Types.Peer
|
||||
|
||||
-- TODO: protocol-encryption-goes-here
|
||||
|
||||
data ProxyMessaging =
|
||||
ProxyMessaging
|
||||
{ _proxyUDP :: MessagingUDP
|
||||
, _proxyTCP :: Maybe MessagingTCP
|
||||
, _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 ()
|
||||
|
||||
, _proxy_asymmetricKeyPair :: AsymmKeypair (Encryption L4Proto)
|
||||
, _proxy_encryptionKeys :: TVar (HashMap (EncryptionKeyIDKey L4Proto) (CommonSecret (Encryption L4Proto)))
|
||||
}
|
||||
|
||||
-- 1 нода X создаёт себе Encrypt.Keypair
|
||||
-- 2 подписывает из него публичный ключ ключом подписи ноды X и отправляет ноде Y
|
||||
-- 3 нода Y получила Публичный ключ ноды X, создала симметричный Key,
|
||||
-- зашифровала его для полученного Публичного ключа ноды X и отравила ей
|
||||
|
||||
makeLenses 'ProxyMessaging
|
||||
|
||||
newProxyMessaging :: forall m . MonadIO m
|
||||
=> MessagingUDP
|
||||
-> Maybe MessagingTCP
|
||||
-> m ProxyMessaging
|
||||
|
||||
newProxyMessaging u t = liftIO do
|
||||
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 ())
|
||||
|
||||
_proxy_asymmetricKeyPair <- asymmNewKeypair @(Encryption L4Proto)
|
||||
_proxy_encryptionKeys <- liftIO (newTVarIO mempty)
|
||||
|
||||
pure ProxyMessaging {..}
|
||||
|
||||
---
|
||||
|
||||
setEncryptionKey ::
|
||||
( Hashable (PubKey 'Sign (Encryption L4Proto))
|
||||
, Hashable PeerNonce
|
||||
, Show (PubKey 'Sign (Encryption L4Proto))
|
||||
, Show PeerNonce
|
||||
, Show (CommonSecret (Encryption L4Proto))
|
||||
, Show (EncryptionKeyIDKey L4Proto)
|
||||
) => ProxyMessaging -> Peer L4Proto -> EncryptionKeyIDKey L4Proto -> Maybe (CommonSecret (Encryption L4Proto)) -> IO ()
|
||||
setEncryptionKey proxy peer pd msecret = do
|
||||
atomically $ modifyTVar' (_proxy_encryptionKeys proxy) $ 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
|
||||
) => ProxyMessaging -> EncryptionKeyIDKey L4Proto -> IO (Maybe (CommonSecret (Encryption L4Proto)))
|
||||
getEncryptionKey proxy pd =
|
||||
readTVarIO (_proxy_encryptionKeys proxy) <&> preview (Lens.ix pd)
|
||||
|
||||
---
|
||||
|
||||
runProxyMessaging :: forall m . MonadIO m
|
||||
=> ProxyMessaging
|
||||
-> m ()
|
||||
|
||||
runProxyMessaging env = liftIO do
|
||||
|
||||
let udp = view proxyUDP env
|
||||
let answ = view proxyAnswers env
|
||||
let udpPeer = getOwnPeer udp
|
||||
|
||||
u <- async $ forever do
|
||||
msgs <- receive udp (To udpPeer)
|
||||
atomically $ do
|
||||
forM_ msgs $ writeTQueue answ
|
||||
|
||||
t <- async $ maybe1 (view proxyTCP env) none $ \tcp -> do
|
||||
forever do
|
||||
msgs <- receive tcp (To $ view tcpOwnPeer tcp)
|
||||
atomically $ do
|
||||
forM_ msgs $ writeTQueue answ
|
||||
|
||||
liftIO $ mapM_ waitCatch [u,t]
|
||||
|
||||
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 proto msg
|
||||
TCP -> maybe1 (view proxyTCP bus) none $ \tcp -> do
|
||||
sendTo tcp t proto msg
|
||||
|
||||
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
|
||||
trace1 $ "ENCRYPTION SEND: sending plain message to" <+> pretty whom
|
||||
pure id
|
||||
Just k -> do
|
||||
trace1 $ "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
|
||||
rs <- atomically $ liftM2 (:) (readTQueue answ) (flushTQueue answ)
|
||||
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
|
||||
trace1 $ "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
|
||||
|
||||
trace1 $ "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
|
||||
trace1 $ "ENCRYPTION RECEIVE: can not extract nonce from" <+> pretty whom <+> "message" <+> viaShow msg
|
||||
fail ""
|
||||
|
||||
Just (nonce, msg') ->
|
||||
((MaybeT . pure) (boxOpenAfterNMLazy k nonce msg')
|
||||
<* (trace1 $ "ENCRYPTION RECEIVE: message successfully decoded from" <+> pretty whom)
|
||||
)
|
||||
<|>
|
||||
(do
|
||||
(trace1 $ "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
|
||||
|
||||
)
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module RPC2.ByPassStat where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Net.Proto.Service
|
||||
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import HBS2.Peer.RPC.API.Peer
|
||||
import HBS2.Peer.RPC.Internal.Types
|
||||
|
||||
instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcByPassInfo where
|
||||
|
||||
handleMethod _ = do
|
||||
co <- getRpcContext @PeerAPI
|
||||
debug $ "rpc.byPassInfo"
|
||||
liftIO $ rpcByPassInfo co
|
||||
|
||||
|
||||
|
||||
|
|
@ -17,4 +17,6 @@ import RPC2.Die()
|
|||
import RPC2.LogLevel()
|
||||
import RPC2.Poll()
|
||||
import RPC2.Downloads()
|
||||
import RPC2.ByPassStat()
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -155,9 +155,9 @@ executable hbs2-peer
|
|||
other-modules:
|
||||
BlockDownload
|
||||
, BrainyPeerLocator
|
||||
, ByPassWorker
|
||||
, DownloadQ
|
||||
, DownloadMon
|
||||
, EncryptionKeys
|
||||
, Bootstrap
|
||||
, PeerInfo
|
||||
, PeerMain.Dialog.Server
|
||||
|
|
@ -174,6 +174,7 @@ executable hbs2-peer
|
|||
, RPC2.Announce
|
||||
, RPC2.Fetch
|
||||
, RPC2.Die
|
||||
, RPC2.ByPassStat
|
||||
, RPC2.LogLevel
|
||||
, RPC2.Peers
|
||||
, RPC2.PexInfo
|
||||
|
|
@ -189,7 +190,7 @@ executable hbs2-peer
|
|||
, CheckMetrics
|
||||
, HttpWorker
|
||||
, Brains
|
||||
, ProxyMessaging
|
||||
, DispatchProxy
|
||||
, CLI.Common
|
||||
, CLI.RefChan
|
||||
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ import HBS2.Net.Messaging.Unix
|
|||
import HBS2.Net.Proto.Service
|
||||
import HBS2.Data.Types.Refs (HashRef(..))
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.Net.Messaging.Encrypted.ByPass(ByPassStat)
|
||||
|
||||
import HBS2.Peer.RPC.Internal.Types
|
||||
|
||||
|
|
@ -30,6 +31,8 @@ data RpcPollDel
|
|||
data RpcDownloadList
|
||||
data RpcDownloadDel
|
||||
|
||||
data RpcByPassInfo
|
||||
|
||||
type PeerAPI = '[ RpcPoke
|
||||
, RpcPing
|
||||
, RpcAnnounce
|
||||
|
|
@ -43,6 +46,7 @@ type PeerAPI = '[ RpcPoke
|
|||
, RpcPollDel
|
||||
, RpcDownloadList
|
||||
, RpcDownloadDel
|
||||
, RpcByPassInfo
|
||||
]
|
||||
|
||||
instance HasProtocol UNIX (ServiceProto PeerAPI UNIX) where
|
||||
|
|
@ -95,6 +99,9 @@ type instance Output RpcPollDel = ()
|
|||
type instance Input RpcLogLevel = SetLogging
|
||||
type instance Output RpcLogLevel = ()
|
||||
|
||||
type instance Input RpcByPassInfo = ()
|
||||
type instance Output RpcByPassInfo = ByPassStat
|
||||
|
||||
data SetLogging =
|
||||
DebugOn Bool
|
||||
| TraceOn Bool
|
||||
|
|
|
|||
|
|
@ -6,10 +6,11 @@ module HBS2.Peer.RPC.Internal.Types
|
|||
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Storage
|
||||
import HBS2.Storage()
|
||||
import HBS2.Data.Types.Refs (HashRef)
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Net.Messaging.Unix
|
||||
import HBS2.Net.Messaging.Encrypted.ByPass (ByPassStat)
|
||||
import HBS2.Net.Proto.Service
|
||||
import HBS2.Peer.RPC.Class
|
||||
import HBS2.Peer.Brains
|
||||
|
|
@ -31,6 +32,7 @@ data RPC2Context =
|
|||
, rpcLocalMultiCast :: Peer L4Proto
|
||||
, rpcStorage :: AnyStorage
|
||||
, rpcBrains :: SomeBrains L4Proto
|
||||
, rpcByPassInfo :: IO ByPassStat
|
||||
, rpcDoFetch :: HashRef -> IO ()
|
||||
, rpcDoRefChanHeadPost :: HashRef -> IO ()
|
||||
, rpcDoRefChanPropose :: (PubKey 'Sign HBS2Basic, SignedBox ByteString L4Proto) -> IO ()
|
||||
|
|
|
|||
|
|
@ -751,6 +751,60 @@ executable topsort-commits
|
|||
-- , vector
|
||||
-- , fast-logger
|
||||
|
||||
executable test-enc-1
|
||||
import: shared-properties
|
||||
import: common-deps
|
||||
default-language: Haskell2010
|
||||
|
||||
ghc-options:
|
||||
-- -prof
|
||||
-- -fprof-auto
|
||||
|
||||
other-modules:
|
||||
|
||||
-- other-extensions:
|
||||
|
||||
-- type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
main-is: TestEnc.hs
|
||||
|
||||
build-depends:
|
||||
base, hbs2-core
|
||||
-- , async
|
||||
-- , attoparsec
|
||||
, bytestring
|
||||
-- , cache
|
||||
-- , clock
|
||||
, containers
|
||||
, interpolatedstring-perl6
|
||||
-- , data-default
|
||||
-- , data-textual
|
||||
-- , directory
|
||||
-- , hashable
|
||||
-- , microlens-platform
|
||||
-- , mtl
|
||||
-- , mwc-random
|
||||
, memory
|
||||
, network-byte-order
|
||||
-- , network
|
||||
-- , network-ip
|
||||
, prettyprinter
|
||||
-- , random
|
||||
, safe
|
||||
, serialise
|
||||
-- , stm
|
||||
-- , streaming
|
||||
, saltine
|
||||
, text
|
||||
, time
|
||||
-- , typed-process
|
||||
-- , transformers
|
||||
, uniplate
|
||||
, unliftio
|
||||
-- , vector
|
||||
-- , fast-logger
|
||||
|
||||
|
||||
|
||||
executable create-raw-tx
|
||||
import: shared-properties
|
||||
|
|
|
|||
|
|
@ -0,0 +1,238 @@
|
|||
{-# Language TemplateHaskell #-}
|
||||
module Main where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Clock
|
||||
import HBS2.Net.Proto
|
||||
import HBS2.Net.Messaging.UDP
|
||||
import HBS2.Net.Messaging.TCP
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.OrDie
|
||||
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import HBS2.Net.Messaging.Encrypted.ByPass
|
||||
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Prettyprinter
|
||||
import System.IO
|
||||
import Lens.Micro.Platform
|
||||
import Crypto.Saltine.Core.Sign
|
||||
|
||||
import Data.Int
|
||||
import Codec.Serialise
|
||||
-- import Control.Concurrent.Async
|
||||
import System.Random
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
|
||||
import Control.Monad.Trans.Resource
|
||||
import UnliftIO.Async
|
||||
|
||||
type UDP = L4Proto
|
||||
|
||||
data PingPong e = Ping Int
|
||||
| Pong Int
|
||||
| Poke
|
||||
deriving stock (Eq,Generic,Show,Read)
|
||||
|
||||
|
||||
instance Serialise (PingPong e)
|
||||
|
||||
instance HasProtocol UDP (PingPong UDP) where
|
||||
type instance ProtocolId (PingPong UDP) = 1307114574
|
||||
type instance Encoded UDP = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
encode = serialise
|
||||
|
||||
pingPongHandler :: forall e m . ( MonadIO m
|
||||
, Response e (PingPong e) m
|
||||
, HasProtocol e (PingPong e)
|
||||
, HasOwnPeer e m
|
||||
, Pretty (Peer e)
|
||||
)
|
||||
=> Int
|
||||
-> PingPong e
|
||||
-> m ()
|
||||
|
||||
pingPongHandler n = \case
|
||||
|
||||
Poke -> pure ()
|
||||
|
||||
Ping c -> do
|
||||
self <- ownPeer @e
|
||||
debug ("Ping" <+> pretty self <+> pretty c) >> response (Pong @e c)
|
||||
|
||||
Pong c | c < n -> do
|
||||
self <- ownPeer @e
|
||||
debug ("Pong" <+> pretty self <+> pretty c) >> response (Ping @e (succ c))
|
||||
|
||||
| otherwise -> pure ()
|
||||
|
||||
data PPEnv =
|
||||
PPEnv
|
||||
{ _ppSelf :: Peer UDP
|
||||
, _ppFab :: Fabriq UDP
|
||||
}
|
||||
|
||||
makeLenses 'PPEnv
|
||||
|
||||
newtype PingPongM m a = PingPongM { fromPingPong :: ReaderT PPEnv m a }
|
||||
deriving newtype ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadIO
|
||||
, MonadUnliftIO
|
||||
, MonadReader PPEnv
|
||||
, MonadTrans
|
||||
)
|
||||
|
||||
runPingPong :: (MonadIO m) => Peer UDP -> Fabriq UDP -> PingPongM m a -> m a
|
||||
runPingPong pip udp m = runReaderT (fromPingPong m) (PPEnv pip udp)
|
||||
|
||||
instance Monad m => HasFabriq UDP (PingPongM m) where
|
||||
getFabriq = asks (view ppFab)
|
||||
|
||||
instance Monad m => HasOwnPeer UDP (PingPongM m) where
|
||||
ownPeer = asks (view ppSelf)
|
||||
|
||||
instance HasTimeLimits UDP (PingPong UDP) IO where
|
||||
tryLockForPeriod _ _ = pure True
|
||||
|
||||
tracePrefix :: SetLoggerEntry
|
||||
tracePrefix = logPrefix "[trace] "
|
||||
|
||||
debugPrefix :: SetLoggerEntry
|
||||
debugPrefix = logPrefix "[debug] "
|
||||
|
||||
errorPrefix :: SetLoggerEntry
|
||||
errorPrefix = logPrefix "[error] "
|
||||
|
||||
warnPrefix :: SetLoggerEntry
|
||||
warnPrefix = logPrefix "[warn] "
|
||||
|
||||
noticePrefix :: SetLoggerEntry
|
||||
noticePrefix = logPrefix "[RT] "
|
||||
|
||||
|
||||
testUDP :: IO ()
|
||||
testUDP = runResourceT do
|
||||
|
||||
let o = byPassDef
|
||||
|
||||
udp1 <- newMessagingUDP False (Just "127.0.0.1:10001") `orDie` "Can't start listener on 10001"
|
||||
udp2 <- newMessagingUDP False (Just "127.0.0.1:10002") `orDie` "Can't start listener on 10002"
|
||||
|
||||
Keypair s1 p1 <- liftIO newKeypair
|
||||
pass1 <- newByPassMessaging @UDP o udp1 (getOwnPeer udp1) p1 s1
|
||||
|
||||
Keypair s2 p2 <- liftIO newKeypair
|
||||
pass2 <- newByPassMessaging @UDP o udp2 (getOwnPeer udp2) p2 s2
|
||||
|
||||
m1 <- async $ runMessagingUDP udp1
|
||||
m2 <- async $ runMessagingUDP udp2
|
||||
|
||||
let own1 = getOwnPeer udp1
|
||||
let own2 = getOwnPeer udp2
|
||||
|
||||
peer1 <- async $ runPingPong own1 (Fabriq pass1) do
|
||||
proto <- async $ runProto @UDP
|
||||
[ makeResponse (pingPongHandler 10)
|
||||
]
|
||||
link proto
|
||||
forever (pause @'Seconds 10)
|
||||
|
||||
|
||||
peer2 <- async $ runPingPong own2 (Fabriq pass2) do
|
||||
proto <- async $ runProto @UDP
|
||||
[ makeResponse (pingPongHandler 10)
|
||||
]
|
||||
link proto
|
||||
request (getOwnPeer udp1) (Ping @UDP 0)
|
||||
forever (pause @'Seconds 10)
|
||||
|
||||
mapM_ wait [peer1,peer2,m1,m2]
|
||||
|
||||
|
||||
testTCP :: IO ()
|
||||
testTCP = runResourceT do
|
||||
|
||||
let o = byPassDef
|
||||
|
||||
pn1 <- liftIO $ randomIO @Int8 <&> ((11000 +) . fromIntegral)
|
||||
pn2 <- liftIO $ randomIO @Int8 <&> ((11000 +). fromIntegral)
|
||||
|
||||
let addr1 = fromString [qc|tcp://127.0.0.1:{pn1}|]
|
||||
let addr2 = fromString [qc|tcp://127.0.0.1:{pn2}|]
|
||||
|
||||
debug $ "ADDR1" <+> pretty addr1
|
||||
debug $ "ADDR2" <+> pretty addr2
|
||||
|
||||
me1 <- newMessagingTCP addr1
|
||||
me2 <- newMessagingTCP addr2
|
||||
|
||||
m1 <- async $ runMessagingTCP me1
|
||||
m2 <- async $ runMessagingTCP me2
|
||||
|
||||
let peer1 = view tcpOwnPeer me1
|
||||
let peer2 = view tcpOwnPeer me2
|
||||
|
||||
|
||||
Keypair s1 p1 <- liftIO newKeypair
|
||||
pass1 <- newByPassMessaging o me1 peer1 p1 s1
|
||||
|
||||
Keypair s2 p2 <- liftIO newKeypair
|
||||
pass2 <- newByPassMessaging o me2 peer2 p2 s2
|
||||
|
||||
peerThread1 <- async $ runPingPong peer1 (Fabriq pass1) do
|
||||
proto <- async $ runProto @L4Proto
|
||||
[ makeResponse (pingPongHandler 10)
|
||||
]
|
||||
link proto
|
||||
|
||||
request peer2 (Poke @L4Proto)
|
||||
|
||||
pause @'Seconds 1
|
||||
|
||||
request peer2 (Ping @L4Proto 0)
|
||||
|
||||
forever (pause @Seconds 10)
|
||||
|
||||
|
||||
peerThread2 <- async $ runPingPong peer2 (Fabriq pass2) do
|
||||
proto <- async $ runProto @L4Proto
|
||||
[ makeResponse (pingPongHandler 10)
|
||||
]
|
||||
link proto
|
||||
forever (pause @Seconds 10)
|
||||
|
||||
waiter <- async $ do
|
||||
pause @'Seconds 3
|
||||
|
||||
void $ waitAnyCatchCancel [peerThread1,peerThread2,m1,m2,waiter]
|
||||
|
||||
stat1 <- getStat pass1
|
||||
stat2 <- getStat pass2
|
||||
|
||||
debug "testUDP done"
|
||||
|
||||
liftIO $ print $ "peer1 stats" <> line <> indent 4 (pretty stat1) <> line
|
||||
liftIO $ print $ "peer2 stats" <> line <> indent 4 (pretty stat2) <> line
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
||||
liftIO $ hSetBuffering stdout LineBuffering
|
||||
liftIO $ hSetBuffering stderr LineBuffering
|
||||
|
||||
setLogging @DEBUG debugPrefix
|
||||
setLogging @INFO defLog
|
||||
setLogging @ERROR errorPrefix
|
||||
setLogging @WARN warnPrefix
|
||||
setLogging @NOTICE noticePrefix
|
||||
setLogging @TRACE tracePrefix
|
||||
|
||||
testTCP
|
||||
|
||||
|
||||
|
|
@ -210,7 +210,7 @@ main = do
|
|||
]
|
||||
|
||||
pp2 <- async $ runPingPong env2 do
|
||||
-- request (view tcpOwnPeer env1) (Ping @L4Proto 1)
|
||||
request (view tcpOwnPeer env1) (Ping @L4Proto 1)
|
||||
runProto @L4Proto
|
||||
[ makeResponse (pingPongHandler 3)
|
||||
]
|
||||
|
|
|
|||
Loading…
Reference in New Issue