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
|
## 2023-10-21
|
||||||
|
|
||||||
тестируем substituter
|
тестируем 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.TCP
|
||||||
, HBS2.Net.Messaging.Unix
|
, HBS2.Net.Messaging.Unix
|
||||||
, HBS2.Net.Messaging.Stream
|
, HBS2.Net.Messaging.Stream
|
||||||
|
, HBS2.Net.Messaging.Encrypted.RandomPrefix
|
||||||
|
, HBS2.Net.Messaging.Encrypted.ByPass
|
||||||
, HBS2.Net.PeerLocator
|
, HBS2.Net.PeerLocator
|
||||||
, HBS2.Net.PeerLocator.Static
|
, HBS2.Net.PeerLocator.Static
|
||||||
, HBS2.Net.Proto
|
, HBS2.Net.Proto
|
||||||
|
|
|
||||||
|
|
@ -47,20 +47,6 @@ import Control.Monad.IO.Unlift
|
||||||
import Codec.Serialise (serialise, deserialiseOrFail)
|
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)
|
class ( Eq (SessionKey e a)
|
||||||
, Hashable (SessionKey e a)
|
, Hashable (SessionKey e a)
|
||||||
|
|
@ -379,6 +365,7 @@ newPeerEnv :: forall e m . ( MonadIO m
|
||||||
, Ord (Peer e)
|
, Ord (Peer e)
|
||||||
, Pretty (Peer e)
|
, Pretty (Peer e)
|
||||||
, HasNonces () m
|
, HasNonces () m
|
||||||
|
, PeerMessaging e
|
||||||
, Asymm (Encryption e)
|
, Asymm (Encryption e)
|
||||||
, Hashable (PubKey 'Sign (Encryption e))
|
, Hashable (PubKey 'Sign (Encryption e))
|
||||||
, Hashable PeerNonce
|
, Hashable PeerNonce
|
||||||
|
|
@ -457,7 +444,7 @@ runProto hh = do
|
||||||
|
|
||||||
case Map.lookup n disp of
|
case Map.lookup n disp of
|
||||||
Nothing -> do
|
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
|
pure () -- FIXME: error counting! and statistics counting feature
|
||||||
|
|
||||||
Just (AnyProtocol { protoDecode = decoder
|
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
|
data Fabriq e = forall bus . (Messaging bus e (Encoded e)) => Fabriq bus
|
||||||
|
|
||||||
|
|
||||||
class HasFabriq e m where
|
class HasFabriq e m where
|
||||||
getFabriq :: m (Fabriq e)
|
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!"
|
-- error $ "DECRYPTED SHIT!"
|
||||||
MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict gkBs) & either (const Nothing) Just
|
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 :: Integral a => a
|
||||||
typicalNonceLength = unsafePerformIO SK.newNonce & Saltine.encode & B8.length & fromIntegral
|
typicalNonceLength = unsafePerformIO SK.newNonce & Saltine.encode & B8.length & fromIntegral
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,9 @@
|
||||||
{-# Language FunctionalDependencies #-}
|
|
||||||
{-# Language UndecidableInstances #-}
|
{-# Language UndecidableInstances #-}
|
||||||
{-# Language AllowAmbiguousTypes #-}
|
{-# Language AllowAmbiguousTypes #-}
|
||||||
module HBS2.Net.Messaging where
|
module HBS2.Net.Messaging
|
||||||
|
( module HBS2.Net.Messaging
|
||||||
|
, module HBS2.Net.Proto
|
||||||
|
) where
|
||||||
|
|
||||||
import HBS2.Net.Proto
|
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 ()
|
sendTo :: MonadIO m => bus -> To proto -> From proto -> msg -> m ()
|
||||||
receive :: MonadIO m => bus -> To proto -> m [(From proto, msg)]
|
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)
|
-- e -> Transport (like, UDP or TChan)
|
||||||
-- p -> L4 Protocol (like Ping/Pong)
|
-- p -> L4 Protocol (like Ping/Pong)
|
||||||
|
|
||||||
|
class NonceFrom nonce a where
|
||||||
|
nonceFrom :: a -> nonce
|
||||||
|
|
||||||
data CryptoAction = Sign | Encrypt
|
data CryptoAction = Sign | Encrypt
|
||||||
|
|
||||||
data GroupKeyScheme = Symm | Asymm
|
data GroupKeyScheme = Symm | Asymm
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,3 @@
|
||||||
{-# Language FunctionalDependencies #-}
|
|
||||||
module HBS2.Prelude
|
module HBS2.Prelude
|
||||||
( module Data.String
|
( module Data.String
|
||||||
, module Safe
|
, module Safe
|
||||||
|
|
@ -18,7 +17,7 @@ module HBS2.Prelude
|
||||||
, ToByteString(..)
|
, ToByteString(..)
|
||||||
, FromByteString(..)
|
, FromByteString(..)
|
||||||
, Text.Text
|
, Text.Text
|
||||||
, (&), (<&>)
|
, (&), (<&>), for_, for
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Typeable as X
|
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.Class (lift)
|
||||||
import Control.Monad.Trans.Maybe
|
import Control.Monad.Trans.Maybe
|
||||||
|
|
||||||
|
|
||||||
|
import Data.Foldable(for_)
|
||||||
|
import Data.Traversable(for)
|
||||||
import Data.Kind
|
import Data.Kind
|
||||||
import Data.Function
|
import Data.Function
|
||||||
import Data.Functor
|
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
|
polling (Polling 5 20) refs $ \ref -> do
|
||||||
missed <- findMissedBlocks sto ref
|
missed <- findMissedBlocks sto ref
|
||||||
|
trace $ "DownloadQ. check" <+> pretty ref <+> pretty (length missed)
|
||||||
debug $ "DownloadQ. check" <+> pretty ref <+> pretty (length missed)
|
|
||||||
|
|
||||||
when (null missed) do
|
when (null missed) do
|
||||||
delDownload @e brains ref
|
delDownload @e brains ref
|
||||||
|
|
|
||||||
|
|
@ -21,11 +21,10 @@ import HBS2.Net.IP.Addr
|
||||||
import HBS2.Net.Messaging.UDP
|
import HBS2.Net.Messaging.UDP
|
||||||
import HBS2.Net.Messaging.TCP
|
import HBS2.Net.Messaging.TCP
|
||||||
import HBS2.Net.Messaging.Unix
|
import HBS2.Net.Messaging.Unix
|
||||||
|
import HBS2.Net.Messaging.Encrypted.ByPass
|
||||||
import HBS2.Net.PeerLocator
|
import HBS2.Net.PeerLocator
|
||||||
import HBS2.Net.Proto as Proto
|
import HBS2.Net.Proto as Proto
|
||||||
import HBS2.Net.Proto.Definition
|
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.Event.PeerExpired
|
||||||
import HBS2.Net.Proto.Peer
|
import HBS2.Net.Proto.Peer
|
||||||
import HBS2.Net.Proto.PeerAnnounce
|
import HBS2.Net.Proto.PeerAnnounce
|
||||||
|
|
@ -43,6 +42,7 @@ import HBS2.System.Logger.Simple hiding (info)
|
||||||
|
|
||||||
import Brains
|
import Brains
|
||||||
import BrainyPeerLocator
|
import BrainyPeerLocator
|
||||||
|
import ByPassWorker
|
||||||
import PeerTypes
|
import PeerTypes
|
||||||
import BlockDownload
|
import BlockDownload
|
||||||
import CheckBlockAnnounce (checkBlockAnnounce)
|
import CheckBlockAnnounce (checkBlockAnnounce)
|
||||||
|
|
@ -52,13 +52,10 @@ import PeerInfo
|
||||||
import PeerConfig
|
import PeerConfig
|
||||||
import Bootstrap
|
import Bootstrap
|
||||||
import CheckMetrics
|
import CheckMetrics
|
||||||
import EncryptionKeys
|
|
||||||
import RefLog qualified
|
import RefLog qualified
|
||||||
import RefLog (reflogWorker)
|
import RefLog (reflogWorker)
|
||||||
import HttpWorker
|
import HttpWorker
|
||||||
import ProxyMessaging
|
import DispatchProxy
|
||||||
-- import PeerMain.DialogCliCommand
|
|
||||||
-- import PeerMain.Dialog.Server
|
|
||||||
import PeerMeta
|
import PeerMeta
|
||||||
import CLI.Common
|
import CLI.Common
|
||||||
import CLI.RefChan
|
import CLI.RefChan
|
||||||
|
|
@ -233,6 +230,7 @@ runCLI = do
|
||||||
<> command "download" (info pDownload (progDesc "download management"))
|
<> command "download" (info pDownload (progDesc "download management"))
|
||||||
<> command "poll" (info pPoll (progDesc "polling management"))
|
<> command "poll" (info pPoll (progDesc "polling management"))
|
||||||
<> command "log" (info pLog (progDesc "set logging level"))
|
<> command "log" (info pLog (progDesc "set logging level"))
|
||||||
|
<> command "bypass" (info pByPass (progDesc "bypass"))
|
||||||
-- FIXME: bring-back-dialogue-over-separate-socket
|
-- FIXME: bring-back-dialogue-over-separate-socket
|
||||||
-- <> command "dial" (info pDialog (progDesc "dialog commands"))
|
-- <> command "dial" (info pDialog (progDesc "dialog commands"))
|
||||||
)
|
)
|
||||||
|
|
@ -468,6 +466,16 @@ runCLI = do
|
||||||
delta = now - fromIntegral u
|
delta = now - fromIntegral u
|
||||||
diff = formatTime defaultTimeLocale "%d:%H:%M:%S" delta
|
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 :: ReadM (PubKey 'Sign HBS2Basic)
|
||||||
refP = maybeReader fromStringMay
|
refP = maybeReader fromStringMay
|
||||||
|
|
||||||
|
|
@ -629,6 +637,8 @@ runPeer opts = U.handle (\e -> myException e
|
||||||
|
|
||||||
udp <- async $ runMessagingUDP mess
|
udp <- async $ runMessagingUDP mess
|
||||||
|
|
||||||
|
let udpAddr = getOwnPeer mess
|
||||||
|
|
||||||
mcast <- newMessagingUDPMulticast defLocalMulticast
|
mcast <- newMessagingUDPMulticast defLocalMulticast
|
||||||
`orDie` "Can't start RPC listener"
|
`orDie` "Can't start RPC listener"
|
||||||
|
|
||||||
|
|
@ -652,43 +662,36 @@ runPeer opts = U.handle (\e -> myException e
|
||||||
void $ async $ runMessagingTCP tcpEnv
|
void $ async $ runMessagingTCP tcpEnv
|
||||||
pure $ Just tcpEnv
|
pure $ Just tcpEnv
|
||||||
|
|
||||||
(proxy, penv) <- mdo
|
let mudp = Just $ Dispatched mess
|
||||||
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
|
|
||||||
|
|
||||||
, _proxy_clearEncryptionKey = \peer -> do
|
let tcpaddr = view tcpOwnPeer <$> tcp
|
||||||
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)
|
|
||||||
|
|
||||||
, _proxy_sendResetEncryptionKeys = \peer -> withPeerM penv do
|
let mtcp = Dispatched <$> tcp
|
||||||
sendResetEncryptionKeys peer
|
|
||||||
|
|
||||||
, _proxy_sendBeginEncryptionExchange = \peer -> withPeerM penv do
|
let points = catMaybes [ (udpAddr ,) <$> mudp
|
||||||
sendBeginEncryptionExchange pc
|
, (,) <$> tcpaddr <*> mtcp
|
||||||
((pubKeyFromKeypair @s . _proxy_asymmetricKeyPair) proxy)
|
]
|
||||||
peer
|
|
||||||
|
|
||||||
}
|
proxy <- newDispatchProxy points $ \_ pip -> case view sockType pip of
|
||||||
penv <- newPeerEnv pl (AnyStorage s) (Fabriq proxy) (getOwnPeer mess)
|
TCP -> pure mtcp
|
||||||
pure (proxy, penv)
|
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
|
let peerMeta = mkPeerMeta conf penv
|
||||||
|
|
||||||
|
|
@ -733,8 +736,8 @@ runPeer opts = U.handle (\e -> myException e
|
||||||
if pro then do
|
if pro then do
|
||||||
withPeerM penv $ withDownload denv (addDownload mzero h)
|
withPeerM penv $ withDownload denv (addDownload mzero h)
|
||||||
else do
|
else do
|
||||||
|
-- FIXME: separate-process-to-mark-logs-processed
|
||||||
withPeerM penv $ withDownload denv (processBlock h)
|
withPeerM penv $ withDownload denv (processBlock h)
|
||||||
setReflogProcessed @e brains h
|
|
||||||
|
|
||||||
let doFetchRef puk = do
|
let doFetchRef puk = do
|
||||||
withPeerM penv $ do
|
withPeerM penv $ do
|
||||||
|
|
@ -753,45 +756,6 @@ runPeer opts = U.handle (\e -> myException e
|
||||||
|
|
||||||
let hshakeAdapter = PeerHandshakeAdapter addNewRtt
|
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
|
env <- ask
|
||||||
|
|
||||||
pnonce <- peerNonce @e
|
pnonce <- peerNonce @e
|
||||||
|
|
@ -800,14 +764,6 @@ runPeer opts = U.handle (\e -> myException e
|
||||||
|
|
||||||
addPeers @e pl ps
|
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
|
subscribe @e PeerAnnounceEventKey $ \(PeerAnnounceEvent pip nonce) -> do
|
||||||
unless (nonce == pnonce) $ do
|
unless (nonce == pnonce) $ do
|
||||||
debug $ "Got peer announce!" <+> pretty pip
|
debug $ "Got peer announce!" <+> pretty pip
|
||||||
|
|
@ -936,6 +892,8 @@ runPeer opts = U.handle (\e -> myException e
|
||||||
debug "sending local peer announce"
|
debug "sending local peer announce"
|
||||||
request localMulticast (PeerAnnounce @e pnonce)
|
request localMulticast (PeerAnnounce @e pnonce)
|
||||||
|
|
||||||
|
peerThread "byPassWorker" (byPassWorker byPass penv)
|
||||||
|
|
||||||
peerThread "httpWorker" (httpWorker conf peerMeta denv)
|
peerThread "httpWorker" (httpWorker conf peerMeta denv)
|
||||||
|
|
||||||
peerThread "checkMetrics" (checkMetrics metrics)
|
peerThread "checkMetrics" (checkMetrics metrics)
|
||||||
|
|
@ -952,14 +910,10 @@ runPeer opts = U.handle (\e -> myException e
|
||||||
|
|
||||||
peerThread "blockDownloadQ" (downloadQueue conf (SomeBrains brains) denv)
|
peerThread "blockDownloadQ" (downloadQueue conf (SomeBrains brains) denv)
|
||||||
|
|
||||||
peerThread "encryptionHandshakeWorker"
|
|
||||||
(EncryptionKeys.encryptionHandshakeWorker @e conf pc encryptionHshakeAdapter)
|
|
||||||
|
|
||||||
peerThread "fillPeerMeta" (fillPeerMeta tcp tcpProbeWait)
|
peerThread "fillPeerMeta" (fillPeerMeta tcp tcpProbeWait)
|
||||||
|
|
||||||
peerThread "postponedLoop" (postponedLoop denv)
|
peerThread "postponedLoop" (postponedLoop denv)
|
||||||
|
|
||||||
|
|
||||||
peerThread "reflogWorker" (reflogWorker @e conf (SomeBrains brains) rwa)
|
peerThread "reflogWorker" (reflogWorker @e conf (SomeBrains brains) rwa)
|
||||||
|
|
||||||
peerThread "refChanWorker" (refChanWorker @e rce (SomeBrains brains))
|
peerThread "refChanWorker" (refChanWorker @e rce (SomeBrains brains))
|
||||||
|
|
@ -970,7 +924,7 @@ runPeer opts = U.handle (\e -> myException e
|
||||||
, makeResponse (blockChunksProto adapter)
|
, makeResponse (blockChunksProto adapter)
|
||||||
, makeResponse blockAnnounceProto
|
, makeResponse blockAnnounceProto
|
||||||
, makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter penv)
|
, makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter penv)
|
||||||
, makeResponse (withCredentials @e pc . encryptionHandshakeProto encryptionHshakeAdapter)
|
-- , makeResponse (withCredentials @e pc . encryptionHandshakeProto encryptionHshakeAdapter)
|
||||||
, makeResponse peerExchangeProto
|
, makeResponse peerExchangeProto
|
||||||
, makeResponse refLogUpdateProto
|
, makeResponse refLogUpdateProto
|
||||||
, makeResponse (refLogRequestProto reflogReqAdapter)
|
, makeResponse (refLogRequestProto reflogReqAdapter)
|
||||||
|
|
@ -1067,6 +1021,7 @@ runPeer opts = U.handle (\e -> myException e
|
||||||
, rpcLocalMultiCast = localMulticast
|
, rpcLocalMultiCast = localMulticast
|
||||||
, rpcStorage = AnyStorage s
|
, rpcStorage = AnyStorage s
|
||||||
, rpcBrains = SomeBrains brains
|
, rpcBrains = SomeBrains brains
|
||||||
|
, rpcByPassInfo = liftIO (getStat byPass)
|
||||||
, rpcDoFetch = liftIO . fetchHash penv denv
|
, rpcDoFetch = liftIO . fetchHash penv denv
|
||||||
, rpcDoRefChanHeadPost = refChanHeadPostAction
|
, rpcDoRefChanHeadPost = refChanHeadPostAction
|
||||||
, rpcDoRefChanPropose = refChanProposeAction
|
, rpcDoRefChanPropose = refChanProposeAction
|
||||||
|
|
@ -1084,6 +1039,7 @@ runPeer opts = U.handle (\e -> myException e
|
||||||
, makeResponse (makeServer @StorageAPI)
|
, makeResponse (makeServer @StorageAPI)
|
||||||
]
|
]
|
||||||
|
|
||||||
|
link proxyThread
|
||||||
link rpcProto
|
link rpcProto
|
||||||
link loop
|
link loop
|
||||||
|
|
||||||
|
|
@ -1093,6 +1049,7 @@ runPeer opts = U.handle (\e -> myException e
|
||||||
, rpcProto
|
, rpcProto
|
||||||
, ann
|
, ann
|
||||||
, messMcast
|
, messMcast
|
||||||
|
, proxyThread
|
||||||
, brainsThread
|
, brainsThread
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,10 @@
|
||||||
{-# Language UndecidableInstances #-}
|
{-# Language UndecidableInstances #-}
|
||||||
{-# Language AllowAmbiguousTypes #-}
|
{-# Language AllowAmbiguousTypes #-}
|
||||||
{-# Language MultiWayIf #-}
|
{-# Language MultiWayIf #-}
|
||||||
module PeerTypes where
|
module PeerTypes
|
||||||
|
( module PeerTypes
|
||||||
|
, module HBS2.Net.PeerLocator
|
||||||
|
) where
|
||||||
|
|
||||||
import HBS2.Actors.Peer
|
import HBS2.Actors.Peer
|
||||||
import HBS2.Clock
|
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.LogLevel()
|
||||||
import RPC2.Poll()
|
import RPC2.Poll()
|
||||||
import RPC2.Downloads()
|
import RPC2.Downloads()
|
||||||
|
import RPC2.ByPassStat()
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -155,9 +155,9 @@ executable hbs2-peer
|
||||||
other-modules:
|
other-modules:
|
||||||
BlockDownload
|
BlockDownload
|
||||||
, BrainyPeerLocator
|
, BrainyPeerLocator
|
||||||
|
, ByPassWorker
|
||||||
, DownloadQ
|
, DownloadQ
|
||||||
, DownloadMon
|
, DownloadMon
|
||||||
, EncryptionKeys
|
|
||||||
, Bootstrap
|
, Bootstrap
|
||||||
, PeerInfo
|
, PeerInfo
|
||||||
, PeerMain.Dialog.Server
|
, PeerMain.Dialog.Server
|
||||||
|
|
@ -174,6 +174,7 @@ executable hbs2-peer
|
||||||
, RPC2.Announce
|
, RPC2.Announce
|
||||||
, RPC2.Fetch
|
, RPC2.Fetch
|
||||||
, RPC2.Die
|
, RPC2.Die
|
||||||
|
, RPC2.ByPassStat
|
||||||
, RPC2.LogLevel
|
, RPC2.LogLevel
|
||||||
, RPC2.Peers
|
, RPC2.Peers
|
||||||
, RPC2.PexInfo
|
, RPC2.PexInfo
|
||||||
|
|
@ -189,7 +190,7 @@ executable hbs2-peer
|
||||||
, CheckMetrics
|
, CheckMetrics
|
||||||
, HttpWorker
|
, HttpWorker
|
||||||
, Brains
|
, Brains
|
||||||
, ProxyMessaging
|
, DispatchProxy
|
||||||
, CLI.Common
|
, CLI.Common
|
||||||
, CLI.RefChan
|
, CLI.RefChan
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -6,6 +6,7 @@ import HBS2.Net.Messaging.Unix
|
||||||
import HBS2.Net.Proto.Service
|
import HBS2.Net.Proto.Service
|
||||||
import HBS2.Data.Types.Refs (HashRef(..))
|
import HBS2.Data.Types.Refs (HashRef(..))
|
||||||
import HBS2.Actors.Peer
|
import HBS2.Actors.Peer
|
||||||
|
import HBS2.Net.Messaging.Encrypted.ByPass(ByPassStat)
|
||||||
|
|
||||||
import HBS2.Peer.RPC.Internal.Types
|
import HBS2.Peer.RPC.Internal.Types
|
||||||
|
|
||||||
|
|
@ -30,6 +31,8 @@ data RpcPollDel
|
||||||
data RpcDownloadList
|
data RpcDownloadList
|
||||||
data RpcDownloadDel
|
data RpcDownloadDel
|
||||||
|
|
||||||
|
data RpcByPassInfo
|
||||||
|
|
||||||
type PeerAPI = '[ RpcPoke
|
type PeerAPI = '[ RpcPoke
|
||||||
, RpcPing
|
, RpcPing
|
||||||
, RpcAnnounce
|
, RpcAnnounce
|
||||||
|
|
@ -43,6 +46,7 @@ type PeerAPI = '[ RpcPoke
|
||||||
, RpcPollDel
|
, RpcPollDel
|
||||||
, RpcDownloadList
|
, RpcDownloadList
|
||||||
, RpcDownloadDel
|
, RpcDownloadDel
|
||||||
|
, RpcByPassInfo
|
||||||
]
|
]
|
||||||
|
|
||||||
instance HasProtocol UNIX (ServiceProto PeerAPI UNIX) where
|
instance HasProtocol UNIX (ServiceProto PeerAPI UNIX) where
|
||||||
|
|
@ -95,6 +99,9 @@ type instance Output RpcPollDel = ()
|
||||||
type instance Input RpcLogLevel = SetLogging
|
type instance Input RpcLogLevel = SetLogging
|
||||||
type instance Output RpcLogLevel = ()
|
type instance Output RpcLogLevel = ()
|
||||||
|
|
||||||
|
type instance Input RpcByPassInfo = ()
|
||||||
|
type instance Output RpcByPassInfo = ByPassStat
|
||||||
|
|
||||||
data SetLogging =
|
data SetLogging =
|
||||||
DebugOn Bool
|
DebugOn Bool
|
||||||
| TraceOn Bool
|
| TraceOn Bool
|
||||||
|
|
|
||||||
|
|
@ -6,10 +6,11 @@ module HBS2.Peer.RPC.Internal.Types
|
||||||
|
|
||||||
import HBS2.Actors.Peer
|
import HBS2.Actors.Peer
|
||||||
import HBS2.Net.Proto.Types
|
import HBS2.Net.Proto.Types
|
||||||
import HBS2.Storage
|
import HBS2.Storage()
|
||||||
import HBS2.Data.Types.Refs (HashRef)
|
import HBS2.Data.Types.Refs (HashRef)
|
||||||
import HBS2.Data.Types.SignedBox
|
import HBS2.Data.Types.SignedBox
|
||||||
import HBS2.Net.Messaging.Unix
|
import HBS2.Net.Messaging.Unix
|
||||||
|
import HBS2.Net.Messaging.Encrypted.ByPass (ByPassStat)
|
||||||
import HBS2.Net.Proto.Service
|
import HBS2.Net.Proto.Service
|
||||||
import HBS2.Peer.RPC.Class
|
import HBS2.Peer.RPC.Class
|
||||||
import HBS2.Peer.Brains
|
import HBS2.Peer.Brains
|
||||||
|
|
@ -31,6 +32,7 @@ data RPC2Context =
|
||||||
, rpcLocalMultiCast :: Peer L4Proto
|
, rpcLocalMultiCast :: Peer L4Proto
|
||||||
, rpcStorage :: AnyStorage
|
, rpcStorage :: AnyStorage
|
||||||
, rpcBrains :: SomeBrains L4Proto
|
, rpcBrains :: SomeBrains L4Proto
|
||||||
|
, rpcByPassInfo :: IO ByPassStat
|
||||||
, rpcDoFetch :: HashRef -> IO ()
|
, rpcDoFetch :: HashRef -> IO ()
|
||||||
, rpcDoRefChanHeadPost :: HashRef -> IO ()
|
, rpcDoRefChanHeadPost :: HashRef -> IO ()
|
||||||
, rpcDoRefChanPropose :: (PubKey 'Sign HBS2Basic, SignedBox ByteString L4Proto) -> IO ()
|
, rpcDoRefChanPropose :: (PubKey 'Sign HBS2Basic, SignedBox ByteString L4Proto) -> IO ()
|
||||||
|
|
|
||||||
|
|
@ -751,6 +751,60 @@ executable topsort-commits
|
||||||
-- , vector
|
-- , vector
|
||||||
-- , fast-logger
|
-- , 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
|
executable create-raw-tx
|
||||||
import: shared-properties
|
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
|
pp2 <- async $ runPingPong env2 do
|
||||||
-- request (view tcpOwnPeer env1) (Ping @L4Proto 1)
|
request (view tcpOwnPeer env1) (Ping @L4Proto 1)
|
||||||
runProto @L4Proto
|
runProto @L4Proto
|
||||||
[ makeResponse (pingPongHandler 3)
|
[ makeResponse (pingPongHandler 3)
|
||||||
]
|
]
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue