mirror of https://github.com/voidlizard/hbs2
344 lines
13 KiB
Haskell
344 lines
13 KiB
Haskell
{-# Language UndecidableInstances #-}
|
||
{-# Language AllowAmbiguousTypes #-}
|
||
module HBS2.Peer.Proto.Mailbox
|
||
( module HBS2.Peer.Proto.Mailbox
|
||
, module HBS2.Peer.Proto.Mailbox.Message
|
||
, module HBS2.Peer.Proto.Mailbox.Types
|
||
, module HBS2.Peer.Proto.Mailbox.Ref
|
||
) where
|
||
|
||
import HBS2.Prelude.Plated
|
||
|
||
import HBS2.Hash
|
||
import HBS2.Base58
|
||
import HBS2.Data.Types.Refs
|
||
import HBS2.Data.Types.SignedBox
|
||
import HBS2.Storage
|
||
import HBS2.Actors.Peer.Types
|
||
import HBS2.Data.Types.Peer
|
||
import HBS2.Net.Auth.Credentials
|
||
|
||
|
||
import HBS2.Net.Proto.Sessions
|
||
import HBS2.Peer.Proto.Peer
|
||
import HBS2.Peer.Proto.Mailbox.Types
|
||
import HBS2.Peer.Proto.Mailbox.Message
|
||
import HBS2.Peer.Proto.Mailbox.Entry
|
||
import HBS2.Peer.Proto.Mailbox.Ref
|
||
|
||
import Codec.Serialise()
|
||
import Control.Monad.Trans.Cont
|
||
import Control.Monad.Trans.Maybe
|
||
import Data.Maybe
|
||
import Data.Word
|
||
import Lens.Micro.Platform
|
||
|
||
data SetPolicyPayload s =
|
||
SetPolicyPayload
|
||
{ sppMailboxKey :: MailboxKey s
|
||
, sppPolicyVersion :: PolicyVersion
|
||
, sppPolicyRef :: HashRef -- ^ merkle tree hash of policy description file
|
||
}
|
||
deriving stock (Generic)
|
||
|
||
-- for Hashable
|
||
deriving instance ForMailbox s => Eq (SetPolicyPayload s)
|
||
|
||
data MailBoxStatusPayload s =
|
||
MailBoxStatusPayload
|
||
{ mbsMailboxPayloadNonce :: Word64
|
||
, mbsMailboxKey :: MailboxKey s
|
||
, mbsMailboxType :: MailboxType
|
||
, mbsMailboxHash :: Maybe HashRef
|
||
, mbsMailboxPolicy :: Maybe (SignedBox (SetPolicyPayload s) s)
|
||
}
|
||
deriving stock (Generic)
|
||
|
||
data DeleteMessagesPayload s =
|
||
DeleteMessagesPayload
|
||
{ dmpMailboxKey :: MailboxKey s
|
||
, dmpPredicate :: MailboxMessagePredicate
|
||
}
|
||
deriving stock (Generic)
|
||
|
||
data MailBoxProtoMessage s e =
|
||
SendMessage (Message s) -- already has signed box
|
||
| CheckMailbox (Maybe Word64) (MailboxKey s)
|
||
| MailboxStatus (SignedBox (MailBoxStatusPayload s) s) -- signed by peer
|
||
| SetPolicy (SignedBox (SetPolicyPayload s) s)
|
||
| DeleteMessages (SignedBox (DeleteMessagesPayload s) s)
|
||
deriving stock (Generic)
|
||
|
||
data MailBoxProto s e =
|
||
MailBoxProtoV1 { mailBoxProtoPayload :: MailBoxProtoMessage s e }
|
||
deriving stock (Generic)
|
||
|
||
instance ForMailbox s => Serialise (MailBoxStatusPayload s)
|
||
instance ForMailbox s => Serialise (SetPolicyPayload s)
|
||
instance ForMailbox s => Serialise (DeleteMessagesPayload s)
|
||
instance ForMailbox s => Serialise (MailBoxProtoMessage s e)
|
||
instance ForMailbox s => Serialise (MailBoxProto s e)
|
||
|
||
class IsMailboxProtoAdapter s a where
|
||
|
||
mailboxGetCredentials :: forall m . MonadIO m => a -> m (PeerCredentials s)
|
||
|
||
mailboxGetStorage :: forall m . MonadIO m => a -> m AnyStorage
|
||
|
||
mailboxAcceptMessage :: forall m . (ForMailbox s, MonadIO m)
|
||
=> a
|
||
-> Message s
|
||
-> MessageContent s
|
||
-> m ()
|
||
|
||
|
||
class ForMailbox s => IsMailboxService s a where
|
||
|
||
mailboxCreate :: forall m . MonadIO m
|
||
=> a
|
||
-> MailboxType
|
||
-> Recipient s
|
||
-> m (Either MailboxServiceError ())
|
||
|
||
mailboxSetPolicy :: forall m . MonadIO m
|
||
=> a
|
||
-> SignedBox (SetPolicyPayload s) s
|
||
-> m (Either MailboxServiceError HashRef)
|
||
|
||
mailboxDelete :: forall m . MonadIO m
|
||
=> a
|
||
-> Recipient s
|
||
-> m (Either MailboxServiceError ())
|
||
|
||
mailboxSendMessage :: forall m . MonadIO m
|
||
=> a
|
||
-> Message s
|
||
-> m (Either MailboxServiceError ())
|
||
|
||
|
||
mailboxSendDelete :: forall m . MonadIO m
|
||
=> a
|
||
-> MailboxRefKey s
|
||
-> MailboxMessagePredicate
|
||
-> m (Either MailboxServiceError ())
|
||
|
||
mailboxListBasic :: forall m . MonadIO m
|
||
=> a
|
||
-> m (Either MailboxServiceError [(MailboxRefKey s, MailboxType)])
|
||
|
||
mailboxGetStatus :: forall m . MonadIO m
|
||
=> a
|
||
-> MailboxRefKey s
|
||
-> m (Either MailboxServiceError (Maybe (MailBoxStatusPayload s)))
|
||
|
||
mailboxAcceptStatus :: forall m . MonadIO m
|
||
=> a
|
||
-> MailboxRefKey s
|
||
-> PubKey 'Sign s -- ^ peer's key
|
||
-> MailBoxStatusPayload s
|
||
-> m (Either MailboxServiceError ())
|
||
|
||
mailboxFetch :: forall m . MonadIO m
|
||
=> a
|
||
-> MailboxRefKey s
|
||
-> m (Either MailboxServiceError ())
|
||
|
||
data AnyMailboxService s =
|
||
forall a . (IsMailboxService s a) => AnyMailboxService { mailboxService :: a }
|
||
|
||
data AnyMailboxAdapter s =
|
||
forall a . (IsMailboxProtoAdapter s a) => AnyMailboxAdapter { mailboxAdapter :: a }
|
||
|
||
instance ForMailbox s => IsMailboxService s (AnyMailboxService s) where
|
||
mailboxCreate (AnyMailboxService a) = mailboxCreate @s a
|
||
mailboxSetPolicy (AnyMailboxService a) = mailboxSetPolicy @s a
|
||
mailboxDelete (AnyMailboxService a) = mailboxDelete @s a
|
||
mailboxSendMessage (AnyMailboxService a) = mailboxSendMessage @s a
|
||
mailboxSendDelete (AnyMailboxService a) = mailboxSendDelete @s a
|
||
mailboxListBasic (AnyMailboxService a) = mailboxListBasic @s a
|
||
mailboxGetStatus (AnyMailboxService a) = mailboxGetStatus @s a
|
||
mailboxAcceptStatus (AnyMailboxService a) = mailboxAcceptStatus @s a
|
||
mailboxFetch (AnyMailboxService a) = mailboxFetch @s a
|
||
|
||
instance IsMailboxProtoAdapter s (AnyMailboxAdapter s) where
|
||
mailboxGetCredentials (AnyMailboxAdapter a) = mailboxGetCredentials @s a
|
||
mailboxGetStorage (AnyMailboxAdapter a) = mailboxGetStorage @s a
|
||
mailboxAcceptMessage (AnyMailboxAdapter a) = mailboxAcceptMessage @s a
|
||
|
||
instance ForMailbox s => Pretty (MailBoxStatusPayload s) where
|
||
pretty MailBoxStatusPayload{..} =
|
||
parens $ "mailbox-status" <> line <> st
|
||
where
|
||
st = indent 2 $
|
||
brackets $
|
||
align $ vcat
|
||
[ parens ("nonce" <+> pretty mbsMailboxPayloadNonce)
|
||
, parens ("key" <+> pretty (AsBase58 mbsMailboxKey))
|
||
, parens ("type" <+> pretty mbsMailboxType)
|
||
, element "mailbox-tree" mbsMailboxHash
|
||
, element "set-policy-payload-hash" (HashRef . hashObject . serialise <$> mbsMailboxPolicy)
|
||
, maybe mempty pretty spp
|
||
]
|
||
|
||
element el = maybe mempty ( \v -> parens (el <+> pretty v) )
|
||
|
||
spp = mbsMailboxPolicy >>= unboxSignedBox0 <&> snd
|
||
|
||
|
||
instance ForMailbox s => Pretty (SetPolicyPayload s) where
|
||
pretty SetPolicyPayload{..} = parens ( "set-policy-payload" <> line <> indent 2 (brackets w) )
|
||
where
|
||
w = align $
|
||
vcat [ parens ( "version" <+> pretty sppPolicyVersion )
|
||
, parens ( "ref" <+> pretty sppPolicyRef )
|
||
]
|
||
|
||
mailboxProto :: forall e s m p a . ( MonadIO m
|
||
, Response e p m
|
||
, HasDeferred p e m
|
||
, HasGossip e p m
|
||
, IsMailboxProtoAdapter s a
|
||
, IsMailboxService s a
|
||
, Sessions e (KnownPeer e) m
|
||
, p ~ MailBoxProto s e
|
||
, s ~ Encryption e
|
||
, ForMailbox s
|
||
)
|
||
=> Bool -- ^ inner, i.e from own peer
|
||
-> a
|
||
-> MailBoxProto (Encryption e) e
|
||
-> m ()
|
||
|
||
mailboxProto inner adapter mess = deferred @p do
|
||
-- common stuff
|
||
|
||
sto <- mailboxGetStorage @s adapter
|
||
now <- liftIO $ getPOSIXTime <&> round
|
||
that <- thatPeer @p
|
||
se <- find (KnownPeerKey that) id
|
||
|
||
case mailBoxProtoPayload mess of
|
||
SendMessage msg -> deferred @p do
|
||
|
||
flip runContT pure $ callCC \exit -> do
|
||
|
||
-- проверить подпись быстрее, чем читать диск
|
||
let unboxed' = unboxSignedBox0 @(MessageContent s) (messageContent msg)
|
||
|
||
-- ок, сообщение нормальное, шлём госсип, пишем, что обработали
|
||
-- TODO: increment-malformed-messages-statistics
|
||
-- $workflow: backlog
|
||
(_, content) <- ContT $ maybe1 unboxed' none
|
||
|
||
let h = hashObject @HbSync (serialise msg) & HashRef
|
||
|
||
let routed = serialise (RoutedEntry h)
|
||
let routedHash = hashObject routed
|
||
|
||
seen <- hasBlock sto routedHash <&> isJust
|
||
|
||
unless seen $ lift do
|
||
gossip mess
|
||
mailboxAcceptMessage adapter msg content
|
||
-- TODO: expire-block-and-collect-garbage
|
||
-- $class: leak
|
||
void $ putBlock sto routed
|
||
|
||
-- NOTE: CheckMailbox-auth
|
||
-- поскольку пир не владеет приватными ключами,
|
||
-- то и подписать это сообщение он не может.
|
||
--
|
||
-- В таком случае, и в фоновом режиме нельзя будет
|
||
-- синхронизировать ящики.
|
||
--
|
||
-- Поскольку все сообщения зашифрованы (но не их метаданные!)
|
||
-- статус мейлобокса является открытой в принципе информацией.
|
||
--
|
||
-- Теперь у нас два пути:
|
||
-- 1. Отдавать только авторизованными пирам (которые имеют майлобоксы)
|
||
-- для этого сделаем сообщение CheckMailboxAuth{}
|
||
--
|
||
-- 2. Шифровать дерево с метаданными, так как нам в принципе
|
||
-- может быть известен публичный ключ шифрования автора,
|
||
-- но это сопряжено со сложностями с обновлением ключей.
|
||
--
|
||
-- С другой стороны, если нас не очень беспокоит возможное раскрытие
|
||
-- метаданных --- то тот, кто скачает мейлобокс для анализа --- будет
|
||
-- участвовать в раздаче.
|
||
--
|
||
-- С другой стороны, может он и хочет участвовать в раздаче, что бы каким-то
|
||
-- образом ей вредить или устраивать слежку.
|
||
--
|
||
-- С этим всем можно бороться поведением и policy:
|
||
--
|
||
-- например:
|
||
-- - не отдавать сообщения неизвестным пирам
|
||
-- - требовать авторизацию (CheckMailboxAuth не нужен т.к. пир авторизован
|
||
-- и так и известен в протоколе)
|
||
--
|
||
|
||
CheckMailbox _ k -> deferred @p do
|
||
creds <- mailboxGetCredentials @s adapter
|
||
|
||
void $ runMaybeT do
|
||
|
||
-- TODO: check-policy
|
||
|
||
s <- mailboxGetStatus adapter (MailboxRefKey @s k)
|
||
>>= toMPlus
|
||
>>= toMPlus
|
||
|
||
let box = makeSignedBox @s (view peerSignPk creds) (view peerSignSk creds) s
|
||
|
||
lift $ response @_ @p (MailBoxProtoV1 (MailboxStatus box))
|
||
|
||
MailboxStatus box -> deferred @p do
|
||
|
||
flip runContT pure $ callCC \exit -> do
|
||
|
||
let r = unboxSignedBox0 @(MailBoxStatusPayload s) box
|
||
|
||
PeerData{..} <- ContT $ maybe1 se none
|
||
|
||
(who, content@MailBoxStatusPayload{..}) <- ContT $ maybe1 r none
|
||
|
||
unless ( who == _peerSignKey ) $ exit ()
|
||
|
||
-- FIXME: timeout-hardcode
|
||
-- может быть вообще не очень хорошо
|
||
-- авторизовываться по времени.
|
||
-- возможно, надо слать нонс в CheckMailbox
|
||
-- и тут его проверять
|
||
unless ( abs (now - mbsMailboxPayloadNonce) < 3 ) $ exit ()
|
||
|
||
-- NOTE: possible-poisoning-attack
|
||
-- левый пир генерирует merkle tree сообщений и посылает его.
|
||
-- чего он может добиться: добавить "валидных" сообщений, которых не было
|
||
-- в ящике изначально. (зашифрованных, подписанных).
|
||
--
|
||
-- можно рассылать спам, ведь каждое спам-сообщение
|
||
-- будет валидно.
|
||
-- мы не можем подписывать что-либо подписью владельца ящика,
|
||
-- ведь мы не владеем его ключом.
|
||
--
|
||
-- как бороться: в policy ограничивать число пиров, которые
|
||
-- могут отдавать статус и игнорировать статусы от прочих пиров.
|
||
--
|
||
-- другой вариант -- каким-то образом публикуется подтверждение
|
||
-- от автора, что пир X владеет почтовым ящиком R.
|
||
--
|
||
-- собственно, это и есть policy.
|
||
--
|
||
-- а вот policy мы как раз можем публиковать с подписью автора,
|
||
-- он участвует в процессе обновления policy.
|
||
|
||
void $ mailboxAcceptStatus adapter (MailboxRefKey mbsMailboxKey) who content
|
||
|
||
SetPolicy{} -> do
|
||
none
|
||
|
||
DeleteMessages{} -> do
|
||
none
|
||
|
||
|