mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
voidlizard
parent
0b9c1f3b4d
commit
599f1e9169
|
|
@ -22,10 +22,13 @@ import HBS2.Storage
|
|||
import HBS2.Storage.Operations.Missed
|
||||
import HBS2.Merkle
|
||||
import HBS2.Hash
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Peer.Proto
|
||||
import HBS2.Peer.Proto.Mailbox
|
||||
import HBS2.Peer.Proto.Mailbox.Entry
|
||||
import HBS2.Peer.Proto.Mailbox.Policy
|
||||
import HBS2.Net.Messaging.Unix
|
||||
import HBS2.Net.Auth.Credentials
|
||||
|
||||
|
|
@ -40,6 +43,8 @@ import BlockDownload()
|
|||
|
||||
import DBPipe.SQLite as Q
|
||||
|
||||
import Data.Config.Suckless.Script
|
||||
|
||||
import Control.Concurrent.STM qualified as STM
|
||||
-- import Control.Concurrent.STM.TBQueue
|
||||
import Control.Monad.Trans.Cont
|
||||
|
|
@ -136,12 +141,84 @@ okay good = pure (Right good)
|
|||
pattern PlainMessageDelete :: forall {s :: CryptoScheme} . HashRef -> DeleteMessagesPayload s
|
||||
pattern PlainMessageDelete x <- DeleteMessagesPayload (MailboxMessagePredicate1 (Op (MessageHashEq x)))
|
||||
|
||||
instance IsAcceptPolicy HBS2Basic () where
|
||||
policyAcceptPeer _ _ = pure True
|
||||
policyAcceptMessage _ _ _ = pure True
|
||||
|
||||
data BasicPolicyAction =
|
||||
Allow | Deny
|
||||
deriving (Eq,Ord,Show,Generic)
|
||||
|
||||
data BasicPolicy s =
|
||||
BasicPolicy
|
||||
{ bpDefaulPeerAction :: BasicPolicyAction
|
||||
, bpDefaultSenderAction :: BasicPolicyAction
|
||||
, bpPeers :: HashMap (PubKey 'Sign s) BasicPolicyAction
|
||||
, bpSenders :: HashMap (Sender s) BasicPolicyAction
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
instance ForMailbox s => IsAcceptPolicy s (BasicPolicy s) where
|
||||
|
||||
policyAcceptPeer BasicPolicy{..} p = do
|
||||
pure False
|
||||
|
||||
policyAcceptMessage BasicPolicy{..} s m = do
|
||||
pure False
|
||||
|
||||
parseBasicPolicy :: forall s m . (s ~ HBS2Basic, ForMailbox s, MonadUnliftIO m)
|
||||
=> [Syntax C]
|
||||
-> m (Maybe (BasicPolicy s))
|
||||
|
||||
parseBasicPolicy syn = do
|
||||
|
||||
tpAction <- newTVarIO Deny
|
||||
tsAction <- newTVarIO Deny
|
||||
tpeers <- newTVarIO mempty
|
||||
tsenders <- newTVarIO mempty
|
||||
|
||||
for_ syn $ \case
|
||||
ListVal [SymbolVal "peer", SymbolVal "allow", SymbolVal "all"] -> do
|
||||
atomically $ writeTVar tpAction Allow
|
||||
|
||||
ListVal [SymbolVal "peer", SymbolVal "deny", SymbolVal "all"] -> do
|
||||
atomically $ writeTVar tpAction Deny
|
||||
|
||||
ListVal [SymbolVal "peer", SymbolVal "allow", SignPubKeyLike who] -> do
|
||||
atomically $ modifyTVar tpeers (HM.insert who Allow)
|
||||
|
||||
ListVal [SymbolVal "peer", SymbolVal "deny", SignPubKeyLike who] -> do
|
||||
atomically $ modifyTVar tpeers (HM.insert who Deny)
|
||||
|
||||
ListVal [SymbolVal "sender", SymbolVal "allow", SymbolVal "all"] -> do
|
||||
atomically $ writeTVar tsAction Allow
|
||||
|
||||
ListVal [SymbolVal "sender", SymbolVal "deny", SymbolVal "all"] -> do
|
||||
atomically $ writeTVar tsAction Deny
|
||||
|
||||
ListVal [SymbolVal "sender", SymbolVal "allow", SignPubKeyLike who] -> do
|
||||
atomically $ modifyTVar tsenders (HM.insert who Allow)
|
||||
|
||||
ListVal [SymbolVal "sender", SymbolVal "deny", SignPubKeyLike who] -> do
|
||||
atomically $ modifyTVar tsenders (HM.insert who Deny)
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
a <- readTVarIO tpAction
|
||||
b <- readTVarIO tsAction
|
||||
c <- readTVarIO tpeers
|
||||
d <- readTVarIO tsenders
|
||||
|
||||
pure $ Just $ BasicPolicy @s a b c d
|
||||
|
||||
instance (s ~ HBS2Basic, e ~ L4Proto, s ~ Encryption e) => IsMailboxProtoAdapter s (MailboxProtoWorker s e) where
|
||||
|
||||
mailboxGetCredentials = pure . mpwCredentials
|
||||
|
||||
mailboxGetStorage = pure . mpwStorage
|
||||
|
||||
mailboxGetPolicy w = pure (AnyPolicy @s ())
|
||||
|
||||
mailboxAcceptMessage MailboxProtoWorker{..} m c = do
|
||||
atomically do
|
||||
full <- isFullTBQueue inMessageQueue
|
||||
|
|
|
|||
|
|
@ -167,6 +167,7 @@ library
|
|||
HBS2.Peer.Proto.Mailbox.Message
|
||||
HBS2.Peer.Proto.Mailbox.Entry
|
||||
HBS2.Peer.Proto.Mailbox.Ref
|
||||
HBS2.Peer.Proto.Mailbox.Policy
|
||||
HBS2.Peer.Proto.BrowserPlugin
|
||||
|
||||
HBS2.Peer.RPC.Client
|
||||
|
|
|
|||
|
|
@ -24,8 +24,12 @@ 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.Policy
|
||||
import HBS2.Peer.Proto.Mailbox.Ref
|
||||
|
||||
import HBS2.Misc.PrettyStuff
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import Codec.Serialise()
|
||||
import Control.Monad.Trans.Cont
|
||||
import Control.Monad.Trans.Maybe
|
||||
|
|
@ -34,61 +38,14 @@ import Data.Word
|
|||
import Lens.Micro.Platform
|
||||
|
||||
|
||||
data MergedEntry s = MergedEntry (MailboxRefKey s) HashRef
|
||||
deriving stock (Generic)
|
||||
|
||||
instance ForMailbox s => Serialise (MergedEntry s)
|
||||
|
||||
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 :: CryptoScheme) =
|
||||
DeleteMessagesPayload
|
||||
{ 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
|
||||
| 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
|
||||
class ForMailbox s => IsMailboxProtoAdapter s a where
|
||||
|
||||
mailboxGetCredentials :: forall m . MonadIO m => a -> m (PeerCredentials s)
|
||||
|
||||
mailboxGetStorage :: forall m . MonadIO m => a -> m AnyStorage
|
||||
|
||||
mailboxGetPolicy :: forall m . MonadIO m => a -> m (AnyPolicy s)
|
||||
|
||||
mailboxAcceptMessage :: forall m . (ForMailbox s, MonadIO m)
|
||||
=> a
|
||||
-> Message s
|
||||
|
|
@ -169,39 +126,13 @@ instance ForMailbox s => IsMailboxService s (AnyMailboxService s) where
|
|||
mailboxAcceptStatus (AnyMailboxService a) = mailboxAcceptStatus @s a
|
||||
mailboxFetch (AnyMailboxService a) = mailboxFetch @s a
|
||||
|
||||
instance IsMailboxProtoAdapter s (AnyMailboxAdapter s) where
|
||||
instance ForMailbox s => IsMailboxProtoAdapter s (AnyMailboxAdapter s) where
|
||||
mailboxGetCredentials (AnyMailboxAdapter a) = mailboxGetCredentials @s a
|
||||
mailboxGetPolicy (AnyMailboxAdapter a) = mailboxGetPolicy @s a
|
||||
mailboxGetStorage (AnyMailboxAdapter a) = mailboxGetStorage @s a
|
||||
mailboxAcceptMessage (AnyMailboxAdapter a) = mailboxAcceptMessage @s a
|
||||
mailboxAcceptDelete (AnyMailboxAdapter a) = mailboxAcceptDelete @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
|
||||
|
|
@ -223,14 +154,30 @@ mailboxProto inner adapter mess = deferred @p do
|
|||
-- common stuff
|
||||
|
||||
sto <- mailboxGetStorage @s adapter
|
||||
policy <- mailboxGetPolicy @s adapter
|
||||
pc <- mailboxGetCredentials @s adapter
|
||||
|
||||
now <- liftIO $ getPOSIXTime <&> round
|
||||
that <- thatPeer @p
|
||||
se <- find (KnownPeerKey that) id
|
||||
se' <- find (KnownPeerKey that) id
|
||||
|
||||
case mailBoxProtoPayload mess of
|
||||
SendMessage msg -> deferred @p do
|
||||
flip runContT pure $ callCC \exit -> do
|
||||
|
||||
flip runContT pure $ callCC \exit -> do
|
||||
se <- ContT $ maybe1 se' none
|
||||
|
||||
pip <- if inner then do
|
||||
pure $ view peerSignPk pc
|
||||
else do
|
||||
pure $ view peerSignKey se
|
||||
|
||||
acceptPeer <- policyAcceptPeer @s policy pip
|
||||
|
||||
unless acceptPeer do
|
||||
debug $ red "Peer rejected by policy" <+> pretty (AsBase58 pip)
|
||||
exit ()
|
||||
|
||||
case mailBoxProtoPayload mess of
|
||||
SendMessage msg -> do
|
||||
|
||||
-- проверить подпись быстрее, чем читать диск
|
||||
let unboxed' = unboxSignedBox0 @(MessageContent s) (messageContent msg)
|
||||
|
|
@ -254,61 +201,57 @@ mailboxProto inner adapter mess = deferred @p do
|
|||
-- $class: leak
|
||||
void $ putBlock sto routed
|
||||
|
||||
-- NOTE: CheckMailbox-auth
|
||||
-- поскольку пир не владеет приватными ключами,
|
||||
-- то и подписать это сообщение он не может.
|
||||
--
|
||||
-- В таком случае, и в фоновом режиме нельзя будет
|
||||
-- синхронизировать ящики.
|
||||
--
|
||||
-- Поскольку все сообщения зашифрованы (но не их метаданные!)
|
||||
-- статус мейлобокса является открытой в принципе информацией.
|
||||
--
|
||||
-- Теперь у нас два пути:
|
||||
-- 1. Отдавать только авторизованными пирам (которые имеют майлобоксы)
|
||||
-- для этого сделаем сообщение CheckMailboxAuth{}
|
||||
--
|
||||
-- 2. Шифровать дерево с метаданными, так как нам в принципе
|
||||
-- может быть известен публичный ключ шифрования автора,
|
||||
-- но это сопряжено со сложностями с обновлением ключей.
|
||||
--
|
||||
-- С другой стороны, если нас не очень беспокоит возможное раскрытие
|
||||
-- метаданных --- то тот, кто скачает мейлобокс для анализа --- будет
|
||||
-- участвовать в раздаче.
|
||||
--
|
||||
-- С другой стороны, может он и хочет участвовать в раздаче, что бы каким-то
|
||||
-- образом ей вредить или устраивать слежку.
|
||||
--
|
||||
-- С этим всем можно бороться поведением и policy:
|
||||
--
|
||||
-- например:
|
||||
-- - не отдавать сообщения неизвестным пирам
|
||||
-- - требовать авторизацию (CheckMailboxAuth не нужен т.к. пир авторизован
|
||||
-- и так и известен в протоколе)
|
||||
--
|
||||
-- NOTE: CheckMailbox-auth
|
||||
-- поскольку пир не владеет приватными ключами,
|
||||
-- то и подписать это сообщение он не может.
|
||||
--
|
||||
-- В таком случае, и в фоновом режиме нельзя будет
|
||||
-- синхронизировать ящики.
|
||||
--
|
||||
-- Поскольку все сообщения зашифрованы (но не их метаданные!)
|
||||
-- статус мейлобокса является открытой в принципе информацией.
|
||||
--
|
||||
-- Теперь у нас два пути:
|
||||
-- 1. Отдавать только авторизованными пирам (которые имеют майлобоксы)
|
||||
-- для этого сделаем сообщение CheckMailboxAuth{}
|
||||
--
|
||||
-- 2. Шифровать дерево с метаданными, так как нам в принципе
|
||||
-- может быть известен публичный ключ шифрования автора,
|
||||
-- но это сопряжено со сложностями с обновлением ключей.
|
||||
--
|
||||
-- С другой стороны, если нас не очень беспокоит возможное раскрытие
|
||||
-- метаданных --- то тот, кто скачает мейлобокс для анализа --- будет
|
||||
-- участвовать в раздаче.
|
||||
--
|
||||
-- С другой стороны, может он и хочет участвовать в раздаче, что бы каким-то
|
||||
-- образом ей вредить или устраивать слежку.
|
||||
--
|
||||
-- С этим всем можно бороться поведением и policy:
|
||||
--
|
||||
-- например:
|
||||
-- - не отдавать сообщения неизвестным пирам
|
||||
-- - требовать авторизацию (CheckMailboxAuth не нужен т.к. пир авторизован
|
||||
-- и так и известен в протоколе)
|
||||
--
|
||||
|
||||
CheckMailbox _ k -> deferred @p do
|
||||
creds <- mailboxGetCredentials @s adapter
|
||||
CheckMailbox _ k -> do
|
||||
creds <- mailboxGetCredentials @s adapter
|
||||
|
||||
void $ runMaybeT do
|
||||
void $ runMaybeT do
|
||||
|
||||
-- TODO: check-policy
|
||||
s <- mailboxGetStatus adapter (MailboxRefKey @s k)
|
||||
>>= toMPlus
|
||||
>>= toMPlus
|
||||
|
||||
s <- mailboxGetStatus adapter (MailboxRefKey @s k)
|
||||
>>= toMPlus
|
||||
>>= toMPlus
|
||||
let box = makeSignedBox @s (view peerSignPk creds) (view peerSignSk creds) s
|
||||
|
||||
let box = makeSignedBox @s (view peerSignPk creds) (view peerSignSk creds) s
|
||||
lift $ lift $ response @_ @p (MailBoxProtoV1 (MailboxStatus box))
|
||||
|
||||
lift $ response @_ @p (MailBoxProtoV1 (MailboxStatus box))
|
||||
|
||||
MailboxStatus box -> deferred @p do
|
||||
|
||||
flip runContT pure $ callCC \exit -> do
|
||||
MailboxStatus box -> do
|
||||
|
||||
let r = unboxSignedBox0 @(MailBoxStatusPayload s) box
|
||||
|
||||
PeerData{..} <- ContT $ maybe1 se none
|
||||
let PeerData{..} = se
|
||||
|
||||
(who, content@MailBoxStatusPayload{..}) <- ContT $ maybe1 r none
|
||||
|
||||
|
|
@ -344,8 +287,7 @@ mailboxProto inner adapter mess = deferred @p do
|
|||
|
||||
void $ mailboxAcceptStatus adapter (MailboxRefKey mbsMailboxKey) who content
|
||||
|
||||
DeleteMessages box -> deferred @p do
|
||||
flip runContT pure do
|
||||
DeleteMessages box -> do
|
||||
|
||||
-- TODO: possible-ddos
|
||||
-- посылаем левые сообщения, заставляем считать
|
||||
|
|
@ -379,4 +321,3 @@ mailboxProto inner adapter mess = deferred @p do
|
|||
|
||||
none
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,12 +1,18 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
|
||||
module HBS2.Peer.Proto.Mailbox.Entry where
|
||||
|
||||
import HBS2.Prelude
|
||||
import HBS2.Peer.Proto.Mailbox.Types
|
||||
import HBS2.Peer.Proto.Mailbox.Ref
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Word
|
||||
import Codec.Serialise
|
||||
import Data.Hashable
|
||||
import Data.Maybe
|
||||
|
||||
data ProofOfDelete =
|
||||
ProofOfDelete
|
||||
|
|
@ -52,3 +58,9 @@ instance Serialise ProofOfDelete
|
|||
instance Serialise ProofOfExist
|
||||
|
||||
|
||||
data MergedEntry s = MergedEntry (MailboxRefKey s) HashRef
|
||||
deriving stock (Generic)
|
||||
|
||||
instance ForMailbox s => Serialise (MergedEntry s)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -28,56 +28,6 @@ import Lens.Micro.Platform
|
|||
import Streaming.Prelude qualified as S
|
||||
import UnliftIO
|
||||
|
||||
|
||||
newtype MessageTimestamp =
|
||||
MessageTimestamp Word64
|
||||
deriving newtype (Eq,Ord,Num,Enum,Integral,Real,Pretty,Show,Hashable)
|
||||
deriving stock Generic
|
||||
|
||||
|
||||
newtype MessageTTL = MessageTTL Word32
|
||||
deriving newtype (Eq,Ord,Num,Enum,Integral,Real,Pretty,Show,Hashable)
|
||||
deriving stock Generic
|
||||
|
||||
|
||||
data MessageCompression = GZip
|
||||
deriving stock (Eq,Ord,Generic,Show)
|
||||
|
||||
data MessageFlags =
|
||||
MessageFlags1
|
||||
{ messageCreated :: MessageTimestamp
|
||||
, messageTTL :: Maybe MessageTTL
|
||||
, messageCompression :: Maybe MessageCompression
|
||||
, messageSchema :: Maybe HashRef -- reserved
|
||||
}
|
||||
deriving stock (Eq,Ord,Generic,Show)
|
||||
|
||||
type MessageRecipient s = PubKey 'Sign s
|
||||
|
||||
data MessageContent s =
|
||||
MessageContent
|
||||
{ messageFlags :: MessageFlags
|
||||
, messageRecipients :: Set (MessageRecipient s)
|
||||
, messageGK0 :: Either HashRef (GroupKey 'Symm s)
|
||||
, messageParts :: Set HashRef
|
||||
, messageData :: SmallEncryptedBlock ByteString
|
||||
}
|
||||
deriving stock Generic
|
||||
|
||||
data Message s =
|
||||
MessageBasic
|
||||
{ messageContent :: SignedBox (MessageContent s) s
|
||||
}
|
||||
deriving stock Generic
|
||||
|
||||
|
||||
instance Serialise MessageTimestamp
|
||||
instance Serialise MessageTTL
|
||||
instance Serialise MessageCompression
|
||||
instance Serialise MessageFlags
|
||||
instance ForMailbox s => Serialise (MessageContent s)
|
||||
instance ForMailbox s => Serialise (Message s)
|
||||
|
||||
-- TODO: mailbox-proto-handler
|
||||
|
||||
-- TODO: mailbox-proto-test?
|
||||
|
|
|
|||
|
|
@ -0,0 +1,31 @@
|
|||
{-# Language AllowAmbiguousTypes #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
module HBS2.Peer.Proto.Mailbox.Policy where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
|
||||
import HBS2.Peer.Proto.Mailbox.Types
|
||||
-- import HBS2.Peer.Proto.Mailbox
|
||||
|
||||
|
||||
class ForMailbox s => IsAcceptPolicy s a where
|
||||
|
||||
policyAcceptPeer :: forall m . MonadIO m
|
||||
=> a
|
||||
-> PubKey 'Sign s -- ^ peer
|
||||
-> m Bool
|
||||
|
||||
policyAcceptMessage :: forall m . MonadIO m
|
||||
=> a
|
||||
-> Sender s
|
||||
-> MessageContent s
|
||||
-> m Bool
|
||||
|
||||
|
||||
|
||||
data AnyPolicy s = forall a . (ForMailbox s, IsAcceptPolicy s a) => AnyPolicy { thePolicy :: a }
|
||||
|
||||
instance ForMailbox s => IsAcceptPolicy s (AnyPolicy s) where
|
||||
policyAcceptPeer (AnyPolicy p) = policyAcceptPeer @s p
|
||||
policyAcceptMessage (AnyPolicy p) = policyAcceptMessage @s p
|
||||
|
||||
|
|
@ -4,13 +4,23 @@ module HBS2.Peer.Proto.Mailbox.Types
|
|||
( ForMailbox
|
||||
, MailboxKey
|
||||
, MailboxType(..)
|
||||
, MailBoxStatusPayload(..)
|
||||
, MailboxServiceError(..)
|
||||
, Recipient
|
||||
, Sender
|
||||
, PolicyVersion
|
||||
, MailboxMessagePredicate(..)
|
||||
, SimplePredicate(..)
|
||||
, SimplePredicateExpr(..)
|
||||
, SimplePredicate(..)
|
||||
, MailBoxProto(..)
|
||||
, MailBoxProtoMessage(..)
|
||||
, Message(..)
|
||||
, MessageContent(..)
|
||||
, MessageCompression(..)
|
||||
, MessageFlags(..)
|
||||
, MessageTTL(..)
|
||||
, DeleteMessagesPayload(..)
|
||||
, SetPolicyPayload(..)
|
||||
, module HBS2.Net.Proto.Types
|
||||
, HashRef
|
||||
) where
|
||||
|
|
@ -18,31 +28,42 @@ module HBS2.Peer.Proto.Mailbox.Types
|
|||
import HBS2.Prelude.Plated
|
||||
|
||||
import HBS2.Base58
|
||||
import HBS2.Hash
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Data.Types.Refs (HashRef)
|
||||
import HBS2.Data.Types.Refs (HashRef(..))
|
||||
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Data.Types.SmallEncryptedBlock(SmallEncryptedBlock(..))
|
||||
import HBS2.Net.Auth.GroupKeySymm
|
||||
|
||||
import Data.Word (Word32)
|
||||
import Codec.Serialise
|
||||
import Data.Maybe
|
||||
import Control.Exception
|
||||
|
||||
data MailboxServiceError =
|
||||
MailboxCreateFailed String
|
||||
| MailboxOperationError String
|
||||
| MailboxSetPolicyFailed String
|
||||
| MailboxAuthError String
|
||||
deriving stock (Typeable,Show,Generic)
|
||||
|
||||
instance Serialise MailboxServiceError
|
||||
instance Exception MailboxServiceError
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Maybe
|
||||
import Data.Set
|
||||
import Data.Set qualified as Set
|
||||
import Data.Word
|
||||
|
||||
data MailboxType =
|
||||
MailboxHub | MailboxRelay
|
||||
deriving stock (Eq,Ord,Show,Generic)
|
||||
|
||||
instance Serialise MailboxType
|
||||
|
||||
instance Pretty MailboxType where
|
||||
pretty = \case
|
||||
MailboxHub -> "hub"
|
||||
MailboxRelay -> "relay"
|
||||
|
||||
instance FromStringMaybe MailboxType where
|
||||
fromStringMay = \case
|
||||
"hub" -> Just MailboxHub
|
||||
"relay" -> Just MailboxRelay
|
||||
_ -> Nothing
|
||||
|
||||
instance IsString MailboxType where
|
||||
fromString s = fromMaybe (error "invalid MailboxType value") (fromStringMay s)
|
||||
|
||||
type MailboxKey s = PubKey 'Sign s
|
||||
|
||||
type Sender s = PubKey 'Sign s
|
||||
|
|
@ -51,6 +72,12 @@ type Recipient s = PubKey 'Sign s
|
|||
|
||||
type PolicyVersion = Word32
|
||||
|
||||
type ForMailbox s = ( ForGroupKeySymm s
|
||||
, Ord (PubKey 'Sign s)
|
||||
, ForSignedBox s
|
||||
, Pretty (AsBase58 (PubKey 'Sign s))
|
||||
)
|
||||
|
||||
data SimplePredicateExpr =
|
||||
And SimplePredicateExpr SimplePredicateExpr
|
||||
| Or SimplePredicateExpr SimplePredicateExpr
|
||||
|
|
@ -68,28 +95,145 @@ data MailboxMessagePredicate =
|
|||
deriving stock (Generic)
|
||||
|
||||
|
||||
type ForMailbox s = ( ForGroupKeySymm s
|
||||
, Ord (PubKey 'Sign s)
|
||||
, ForSignedBox s
|
||||
, Pretty (AsBase58 (PubKey 'Sign s))
|
||||
)
|
||||
|
||||
instance Serialise SimplePredicate
|
||||
instance Serialise SimplePredicateExpr
|
||||
instance Serialise MailboxMessagePredicate
|
||||
instance Serialise MailboxType
|
||||
|
||||
instance Pretty MailboxType where
|
||||
pretty = \case
|
||||
MailboxHub -> "hub"
|
||||
MailboxRelay -> "relay"
|
||||
newtype MessageTimestamp =
|
||||
MessageTimestamp Word64
|
||||
deriving newtype (Eq,Ord,Num,Enum,Integral,Real,Pretty,Show,Hashable)
|
||||
deriving stock Generic
|
||||
|
||||
instance FromStringMaybe MailboxType where
|
||||
fromStringMay = \case
|
||||
"hub" -> Just MailboxHub
|
||||
"relay" -> Just MailboxRelay
|
||||
_ -> Nothing
|
||||
|
||||
instance IsString MailboxType where
|
||||
fromString s = fromMaybe (error "invalid MailboxType value") (fromStringMay s)
|
||||
newtype MessageTTL = MessageTTL Word32
|
||||
deriving newtype (Eq,Ord,Num,Enum,Integral,Real,Pretty,Show,Hashable)
|
||||
deriving stock Generic
|
||||
|
||||
|
||||
data MessageCompression = GZip
|
||||
deriving stock (Eq,Ord,Generic,Show)
|
||||
|
||||
data MessageFlags =
|
||||
MessageFlags1
|
||||
{ messageCreated :: MessageTimestamp
|
||||
, messageTTL :: Maybe MessageTTL
|
||||
, messageCompression :: Maybe MessageCompression
|
||||
, messageSchema :: Maybe HashRef -- reserved
|
||||
}
|
||||
deriving stock (Eq,Ord,Generic,Show)
|
||||
|
||||
type MessageRecipient s = PubKey 'Sign s
|
||||
|
||||
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 :: CryptoScheme) =
|
||||
DeleteMessagesPayload
|
||||
{ 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
|
||||
| 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)
|
||||
|
||||
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 )
|
||||
]
|
||||
|
||||
|
||||
data MessageContent s =
|
||||
MessageContent
|
||||
{ messageFlags :: MessageFlags
|
||||
, messageRecipients :: Set (MessageRecipient s)
|
||||
, messageGK0 :: Either HashRef (GroupKey 'Symm s)
|
||||
, messageParts :: Set HashRef
|
||||
, messageData :: SmallEncryptedBlock ByteString
|
||||
}
|
||||
deriving stock Generic
|
||||
|
||||
data Message s =
|
||||
MessageBasic
|
||||
{ messageContent :: SignedBox (MessageContent s) s
|
||||
}
|
||||
deriving stock Generic
|
||||
|
||||
|
||||
instance Serialise MessageTimestamp
|
||||
instance Serialise MessageTTL
|
||||
instance Serialise MessageCompression
|
||||
instance Serialise MessageFlags
|
||||
instance ForMailbox s => Serialise (MessageContent s)
|
||||
instance ForMailbox s => Serialise (Message s)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
data MailboxServiceError =
|
||||
MailboxCreateFailed String
|
||||
| MailboxOperationError String
|
||||
| MailboxSetPolicyFailed String
|
||||
| MailboxAuthError String
|
||||
deriving stock (Typeable,Show,Generic)
|
||||
|
||||
instance Serialise MailboxServiceError
|
||||
instance Exception MailboxServiceError
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -40,8 +40,8 @@ data RPC2Context =
|
|||
, rpcDoRefChanHeadPost :: HashRef -> IO ()
|
||||
, rpcDoRefChanPropose :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO ()
|
||||
, rpcDoRefChanNotify :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO ()
|
||||
, rpcMailboxService :: AnyMailboxService (Encryption L4Proto)
|
||||
, rpcMailboxAdapter :: AnyMailboxAdapter (Encryption L4Proto)
|
||||
, rpcMailboxService :: AnyMailboxService HBS2Basic
|
||||
, rpcMailboxAdapter :: AnyMailboxAdapter HBS2Basic
|
||||
}
|
||||
|
||||
instance (Monad m, Messaging MessagingUnix UNIX (Encoded UNIX)) => HasFabriq UNIX (ReaderT RPC2Context m) where
|
||||
|
|
|
|||
Loading…
Reference in New Issue