mirror of https://github.com/voidlizard/hbs2
230 lines
8.0 KiB
Haskell
230 lines
8.0 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||
{-# Language UndecidableInstances #-}
|
||
module HBS2.Peer.Proto
|
||
( module HBS2.Peer.Proto.PeerMeta
|
||
, module HBS2.Peer.Proto.BlockAnnounce
|
||
, module HBS2.Peer.Proto.BlockChunks
|
||
, module HBS2.Peer.Proto.BlockInfo
|
||
, module HBS2.Peer.Proto.Peer
|
||
, module HBS2.Peer.Proto.PeerAnnounce
|
||
, module HBS2.Peer.Proto.PeerExchange
|
||
, module HBS2.Peer.Proto.RefLog
|
||
, module HBS2.Peer.Proto.RefChan
|
||
, module HBS2.Peer.Proto.AnyRef
|
||
, module HBS2.Net.Proto.Types
|
||
, module HBS2.Net.Proto.Sessions
|
||
, module HBS2.Net.Proto.Service
|
||
) where
|
||
|
||
import HBS2.Peer.Prelude
|
||
import HBS2.Net.Proto.Types
|
||
import HBS2.Peer.Proto.PeerMeta
|
||
import HBS2.Peer.Proto.BlockAnnounce
|
||
import HBS2.Peer.Proto.BlockChunks
|
||
import HBS2.Peer.Proto.BlockInfo
|
||
import HBS2.Peer.Proto.Peer
|
||
import HBS2.Peer.Proto.PeerAnnounce
|
||
import HBS2.Peer.Proto.PeerExchange
|
||
import HBS2.Peer.Proto.RefLog
|
||
import HBS2.Peer.Proto.RefChan hiding (Notify)
|
||
import HBS2.Peer.Proto.AnyRef
|
||
import HBS2.Peer.Proto.LWWRef
|
||
|
||
import HBS2.Actors.Peer.Types
|
||
import HBS2.Net.Messaging.Unix (UNIX)
|
||
import HBS2.Net.Proto.Sessions
|
||
import HBS2.Net.Proto.Service
|
||
|
||
import Data.ByteString.Lazy (ByteString)
|
||
import Data.ByteString qualified as BS
|
||
import Codec.Serialise
|
||
import Crypto.Saltine.Core.Box qualified as Crypto
|
||
import Crypto.Saltine.Class qualified as Crypto
|
||
|
||
instance HasProtocol L4Proto (BlockInfo L4Proto) where
|
||
type instance ProtocolId (BlockInfo L4Proto) = 1
|
||
type instance Encoded L4Proto = ByteString
|
||
decode = deserialiseCustom
|
||
encode = serialise
|
||
|
||
-- FIXME: requestMinPeriod-breaks-fast-block-download
|
||
--
|
||
requestPeriodLim = ReqLimPerMessage 1
|
||
|
||
instance HasProtocol L4Proto (BlockChunks L4Proto) where
|
||
type instance ProtocolId (BlockChunks L4Proto) = 2
|
||
type instance Encoded L4Proto = ByteString
|
||
decode = deserialiseCustom
|
||
encode = serialise
|
||
|
||
instance Expires (SessionKey L4Proto (BlockChunks L4Proto)) where
|
||
expiresIn _ = Just defCookieTimeoutSec
|
||
|
||
instance HasProtocol L4Proto (BlockAnnounce L4Proto) where
|
||
type instance ProtocolId (BlockAnnounce L4Proto) = 3
|
||
type instance Encoded L4Proto = ByteString
|
||
decode = deserialiseCustom
|
||
encode = serialise
|
||
|
||
instance HasProtocol L4Proto (PeerHandshake L4Proto) where
|
||
type instance ProtocolId (PeerHandshake L4Proto) = 4
|
||
type instance Encoded L4Proto = ByteString
|
||
decode = deserialiseCustom
|
||
encode = serialise
|
||
|
||
requestPeriodLim = ReqLimPerProto 0.5
|
||
|
||
instance HasProtocol L4Proto (PeerAnnounce L4Proto) where
|
||
type instance ProtocolId (PeerAnnounce L4Proto) = 5
|
||
type instance Encoded L4Proto = ByteString
|
||
decode = deserialiseCustom
|
||
encode = serialise
|
||
|
||
instance HasProtocol L4Proto (PeerExchange L4Proto) where
|
||
type instance ProtocolId (PeerExchange L4Proto) = 6
|
||
type instance Encoded L4Proto = ByteString
|
||
decode = deserialiseCustom
|
||
encode = serialise
|
||
|
||
instance HasProtocol L4Proto (RefLogUpdate L4Proto) where
|
||
type instance ProtocolId (RefLogUpdate L4Proto) = 7
|
||
type instance Encoded L4Proto = ByteString
|
||
decode = deserialiseCustom
|
||
encode = serialise
|
||
|
||
-- TODO: find-out-optimal-max-safe-frequency
|
||
requestPeriodLim = ReqLimPerMessage 600
|
||
|
||
instance HasProtocol L4Proto (RefLogRequest L4Proto) where
|
||
type instance ProtocolId (RefLogRequest L4Proto) = 8
|
||
type instance Encoded L4Proto = ByteString
|
||
decode = deserialiseCustom
|
||
encode = serialise
|
||
|
||
|
||
instance HasProtocol L4Proto (RefChanHead L4Proto) where
|
||
type instance ProtocolId (RefChanHead L4Proto) = 11001
|
||
type instance Encoded L4Proto = ByteString
|
||
decode = either (const Nothing) Just . deserialiseOrFail
|
||
encode = serialise
|
||
|
||
-- TODO: find-out-optimal-max-frequency
|
||
requestPeriodLim = ReqLimPerMessage 60
|
||
|
||
|
||
instance HasProtocol L4Proto (RefChanUpdate L4Proto) where
|
||
type instance ProtocolId (RefChanUpdate L4Proto) = 11002
|
||
type instance Encoded L4Proto = ByteString
|
||
decode = either (const Nothing) Just . deserialiseOrFail
|
||
encode = serialise
|
||
|
||
-- мы не можем рассылать одинаковые сообщения никогда,
|
||
-- ну или хотя бы не чаще, чем раз в 10 минут.
|
||
-- но poll у нас в минутах, и с минимальным периодом 1 минута
|
||
requestPeriodLim = ReqLimPerMessage 60
|
||
|
||
instance HasProtocol L4Proto (RefChanRequest L4Proto) where
|
||
type instance ProtocolId (RefChanRequest L4Proto) = 11003
|
||
type instance Encoded L4Proto = ByteString
|
||
decode = either (const Nothing) Just . deserialiseOrFail
|
||
encode = serialise
|
||
|
||
-- мы не можем рассылать одинаковые сообщения никогда,
|
||
-- ну или хотя бы не чаще, чем раз в 10 минут.
|
||
-- но poll у нас в минутах, и с минимальным периодом 1 минута
|
||
requestPeriodLim = ReqLimPerMessage 1
|
||
|
||
|
||
instance HasProtocol L4Proto (RefChanNotify L4Proto) where
|
||
type instance ProtocolId (RefChanNotify L4Proto) = 11004
|
||
type instance Encoded L4Proto = ByteString
|
||
decode = either (const Nothing) Just . deserialiseOrFail
|
||
encode = serialise
|
||
|
||
-- не чаще раза в секуду, хотя бы.
|
||
-- или сколько? минуту? минуты мало.
|
||
-- но сообщения должны быть разные,
|
||
-- тогда и минута нормально.
|
||
-- возьмем пока 10 секунд
|
||
requestPeriodLim = NoLimit
|
||
|
||
instance ForLWWRefProto L4Proto => HasProtocol L4Proto (LWWRefProto L4Proto) where
|
||
type instance ProtocolId (LWWRefProto L4Proto) = 12001
|
||
type instance Encoded L4Proto = ByteString
|
||
decode = either (const Nothing) Just . deserialiseOrFail
|
||
encode = serialise
|
||
requestPeriodLim = ReqLimPerMessage 1
|
||
|
||
instance Serialise (RefChanValidate UNIX) => HasProtocol UNIX (RefChanValidate UNIX) where
|
||
type instance ProtocolId (RefChanValidate UNIX) = 0xFFFA0001
|
||
type instance Encoded UNIX = ByteString
|
||
decode = either (const Nothing) Just . deserialiseOrFail
|
||
encode = serialise
|
||
|
||
|
||
instance Serialise (RefChanNotify UNIX) => HasProtocol UNIX (RefChanNotify UNIX) where
|
||
type instance ProtocolId (RefChanNotify UNIX) = 0xFFFB0001
|
||
type instance Encoded UNIX = ByteString
|
||
decode = either (const Nothing) Just . deserialiseOrFail
|
||
encode = serialise
|
||
requestPeriodLim = NoLimit
|
||
|
||
instance MonadIO m => HasNonces (RefChanValidate UNIX) m where
|
||
type instance Nonce (RefChanValidate UNIX) = BS.ByteString
|
||
newNonce = do
|
||
n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
|
||
pure $ BS.take 8 n
|
||
|
||
|
||
instance HasTimeLimits UNIX (RefChanValidate UNIX) IO where
|
||
tryLockForPeriod _ _ = pure True
|
||
|
||
instance HasTimeLimits UNIX (RefChanNotify UNIX) IO where
|
||
tryLockForPeriod _ _ = pure True
|
||
|
||
instance Expires (SessionKey L4Proto (BlockInfo L4Proto)) where
|
||
expiresIn _ = Just defCookieTimeoutSec
|
||
|
||
instance Expires (EventKey L4Proto (BlockInfo L4Proto)) where
|
||
expiresIn _ = Just 600
|
||
|
||
instance Expires (EventKey L4Proto (BlockChunks L4Proto)) where
|
||
expiresIn _ = Just 600
|
||
|
||
instance Expires (EventKey L4Proto (BlockAnnounce L4Proto)) where
|
||
expiresIn _ = Nothing
|
||
|
||
instance Expires (SessionKey L4Proto (KnownPeer L4Proto)) where
|
||
expiresIn _ = Just 3600
|
||
|
||
instance Expires (SessionKey L4Proto (PeerHandshake L4Proto)) where
|
||
expiresIn _ = Just 60
|
||
|
||
instance Expires (EventKey L4Proto (PeerAnnounce L4Proto)) where
|
||
expiresIn _ = Nothing
|
||
|
||
instance MonadIO m => HasNonces (PeerHandshake L4Proto) m where
|
||
type instance Nonce (PeerHandshake L4Proto) = BS.ByteString
|
||
newNonce = do
|
||
n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
|
||
pure $ BS.take 32 n
|
||
|
||
instance MonadIO m => HasNonces (PeerExchange L4Proto) m where
|
||
type instance Nonce (PeerExchange L4Proto) = BS.ByteString
|
||
newNonce = do
|
||
n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
|
||
pure $ BS.take 32 n
|
||
|
||
instance MonadIO m => HasNonces (RefLogUpdate L4Proto) m where
|
||
type instance Nonce (RefLogUpdate L4Proto) = BS.ByteString
|
||
newNonce = do
|
||
n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
|
||
pure $ BS.take 32 n
|
||
|
||
instance MonadIO m => HasNonces () m where
|
||
type instance Nonce () = BS.ByteString
|
||
newNonce = do
|
||
n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
|
||
pure $ BS.take 32 n
|
||
|