diff --git a/hbs2-peer/app/MailboxProtoWorker.hs b/hbs2-peer/app/MailboxProtoWorker.hs index e5285914..8cd1e4e5 100644 --- a/hbs2-peer/app/MailboxProtoWorker.hs +++ b/hbs2-peer/app/MailboxProtoWorker.hs @@ -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 diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 666a75c1..6c7634f3 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -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 diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs index 07b75968..c7067a3d 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs @@ -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 - diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs index 5f7f07c2..84987476 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs @@ -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) + + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs index fc9675d3..bb6319ec 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs @@ -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? diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy.hs new file mode 100644 index 00000000..22b0385f --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy.hs @@ -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 + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs index 918db403..331b962b 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs @@ -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 + diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs index 085dda94..514548ca 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs @@ -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