wip

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

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

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
+class ForMailbox s => IsMailboxProtoAdapter s a where
-                   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
 
   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
+  flip runContT pure $ callCC \exit -> do
-    SendMessage msg -> deferred @p 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
+      -- NOTE: CheckMailbox-auth
-    --   поскольку пир не владеет приватными ключами,
+      --   поскольку пир не владеет приватными ключами,
-    --   то и подписать это сообщение он не может.
+      --   то и подписать это сообщение он не может.
-    --
+      --
-    --   В таком случае, и в фоновом режиме нельзя будет
+      --   В таком случае, и в фоновом режиме нельзя будет
-    --   синхронизировать ящики.
+      --   синхронизировать ящики.
-    --
+      --
-    --   Поскольку все сообщения зашифрованы (но не их метаданные!)
+      --   Поскольку все сообщения зашифрованы (но не их метаданные!)
-    --   статус мейлобокса является открытой в принципе информацией.
+      --   статус мейлобокса является открытой в принципе информацией.
-    --
+      --
-    --   Теперь у нас два пути:
+      --   Теперь у нас два пути:
-    --    1. Отдавать только авторизованными пирам (которые имеют майлобоксы)
+      --    1. Отдавать только авторизованными пирам (которые имеют майлобоксы)
-    --       для этого сделаем сообщение CheckMailboxAuth{}
+      --       для этого сделаем сообщение CheckMailboxAuth{}
-    --
+      --
-    --    2. Шифровать дерево с метаданными, так как нам в принципе
+      --    2. Шифровать дерево с метаданными, так как нам в принципе
-    --       может быть известен публичный ключ шифрования автора,
+      --       может быть известен публичный ключ шифрования автора,
-    --       но это сопряжено со сложностями с обновлением ключей.
+      --       но это сопряжено со сложностями с обновлением ключей.
-    --
+      --
-    --    С другой стороны, если нас не очень беспокоит возможное раскрытие
+      --    С другой стороны, если нас не очень беспокоит возможное раскрытие
-    --    метаданных --- то тот, кто скачает мейлобокс для анализа --- будет
+      --    метаданных --- то тот, кто скачает мейлобокс для анализа --- будет
-    --    участвовать в раздаче.
+      --    участвовать в раздаче.
-    --
+      --
-    --    С другой стороны, может он и хочет участвовать в раздаче, что бы каким-то
+      --    С другой стороны, может он и хочет участвовать в раздаче, что бы каким-то
-    --    образом ей вредить или устраивать слежку.
+      --    образом ей вредить или устраивать слежку.
-    --
+      --
-    --    С этим всем можно бороться поведением и policy:
+      --    С этим всем можно бороться поведением и policy:
-    --
+      --
-    --    например:
+      --    например:
-    --      - не отдавать сообщения неизвестным пирам
+      --      - не отдавать сообщения неизвестным пирам
-    --      - требовать авторизацию (CheckMailboxAuth не нужен т.к. пир авторизован
+      --      - требовать авторизацию (CheckMailboxAuth не нужен т.к. пир авторизован
-    --        и так и известен в протоколе)
+      --        и так и известен в протоколе)
-    --
+      --
 
-    CheckMailbox _ k -> deferred @p do
+      CheckMailbox _ k ->  do
-      creds <- mailboxGetCredentials @s adapter
+        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)
+          let box = makeSignedBox @s (view peerSignPk creds) (view peerSignSk creds) s
-               >>= toMPlus
-               >>= toMPlus
 
-        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 -> do
-
-    MailboxStatus box -> deferred @p do
-
-      flip runContT pure $ callCC \exit -> 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
+      DeleteMessages box -> do
-      flip runContT pure do
 
         -- TODO: possible-ddos
         --   посылаем левые сообщения, заставляем считать
@@ -379,4 +321,3 @@ mailboxProto inner adapter mess = deferred @p do
 
         none
 
-

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)
+
+

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?

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
+

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
-
+import Data.ByteString (ByteString)
-data MailboxServiceError =
+import Data.Maybe
-    MailboxCreateFailed String
+import Data.Set
-  | MailboxOperationError String
+import Data.Set qualified as Set
-  | MailboxSetPolicyFailed String
+import Data.Word
-  | MailboxAuthError String
-  deriving stock (Typeable,Show,Generic)
-
-instance Serialise MailboxServiceError
-instance Exception MailboxServiceError
 
 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
+newtype MessageTimestamp =
-  pretty = \case
+  MessageTimestamp Word64
-    MailboxHub -> "hub"
+  deriving newtype (Eq,Ord,Num,Enum,Integral,Real,Pretty,Show,Hashable)
-    MailboxRelay -> "relay"
+  deriving stock Generic
 
-instance FromStringMaybe MailboxType where
-  fromStringMay = \case
-    "hub"   -> Just MailboxHub
-    "relay" -> Just MailboxRelay
-    _       -> Nothing
 
-instance IsString MailboxType where
+newtype MessageTTL = MessageTTL Word32
-  fromString s = fromMaybe (error "invalid MailboxType value") (fromStringMay s)
+  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
+
 

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)
+  , rpcMailboxService      :: AnyMailboxService HBS2Basic
-  , rpcMailboxAdapter      :: AnyMailboxAdapter (Encryption L4Proto)
+  , rpcMailboxAdapter      :: AnyMailboxAdapter HBS2Basic
   }
 
 instance (Monad m, Messaging MessagingUnix UNIX (Encoded UNIX)) => HasFabriq UNIX (ReaderT RPC2Context m) where