wip

hbs2-peer/app/CLI/Mailbox.hs

@@ -170,10 +170,10 @@ runMailboxCLI rpc s = do
                              >>= toMPlus
 
                     case e of
-                      Deleted mh -> do
+                      Deleted _ mh -> do
                         atomically $ modifyTVar d (HS.insert mh)
 
-                      Existed mh -> do
+                      Existed _ mh -> do
                          atomically $ modifyTVar r (HS.insert mh)
 
               deleted <- readTVarIO d
@@ -184,6 +184,15 @@ runMailboxCLI rpc s = do
 
              _ -> throwIO $ BadFormException @C nil
 
+
+        brief "delete mailbox"
+          $ entry $ bindMatch "delete" $ nil_ $ \case
+            [ SignPubKeyLike mbox ]-> lift do
+              callRpcWaitMay @RpcMailboxDelete t api mbox
+                 >>= orThrowUser "rpc call timeout"
+
+            _ -> throwIO $ BadFormException @C nil
+
         entry $ bindMatch "help" $ nil_ \case
           HelpEntryBound what -> helpEntry what
           [StringLike s]      -> helpList False (Just s)

hbs2-peer/app/MailboxProtoWorker.hs

@@ -111,6 +111,28 @@ instance ( s ~ Encryption e, e ~ L4Proto
         Right{} -> pure $ Right ()
         Left{}  -> pure $ Left (MailboxCreateFailed "database operation")
 
+  mailboxDelete MailboxProtoWorker{..} mbox = do
+
+    flip runContT pure $ callCC \exit -> do
+
+      mdbe <- readTVarIO mailboxDB
+
+      dbe <- ContT $ maybe1 mdbe (pure $ Left (MailboxCreateFailed "database not ready"))
+
+      debug $ red "delete fucking mailbox" <+> pretty (MailboxRefKey @s mbox)
+
+      -- TODO: actually-purge-messages-and-attachments
+      withDB dbe do
+        insert [qc| delete from mailbox where recipient = ? |] (Only (MailboxRefKey @s mbox))
+
+      delRef mpwStorage (MailboxRefKey @s mbox)
+
+      pure $ Right ()
+
+  -- FIXME: refactor
+  mailboxSendDelete w@MailboxProtoWorker{..} ref predicate = do
+    pure $ Right ()
+
   mailboxSendMessage w@MailboxProtoWorker{..} mess = do
     -- we do not check message signature here
     -- because it will be checked in the protocol handler anyway
@@ -136,6 +158,9 @@ instance ( s ~ Encryption e, e ~ L4Proto
 
       pure $ Right r
 
+  mailboxGetStatus MailboxProtoWorker{..} ref = do
+    undefined
+
 getMailboxType_ :: (ForMailbox s, MonadIO m) => DBPipeEnv -> Recipient s -> m (Maybe MailboxType)
 getMailboxType_ d r = do
   let sql = [qc|select type from mailbox where recipient = ? limit 1|]
@@ -179,7 +204,7 @@ mailboxProtoWorker :: forall e s m . ( MonadIO m
 
 mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do
 
-  pause @'Seconds 10
+  pause @'Seconds 1
 
   flip runContT pure do
 
@@ -234,7 +259,9 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do
 
             debug $ yellow "mailbox: message stored" <+> pretty ref <+> pretty ha
 
-            h' <- enqueueBlock sto (serialise (Existed ha))
+            -- TODO: add-policy-reference
+            let proof = ProofOfExist mzero
+            h' <- enqueueBlock sto (serialise (Existed proof ha))
 
             for_ h' $ \h -> do
               atomically do
@@ -325,6 +352,9 @@ mailboxStateEvolve readConf MailboxProtoWorker{..}  = do
   pure dbe
 
 
+instance ForMailbox s => ToField (MailboxRefKey s) where
+  toField (MailboxRefKey a) = toField (show $ pretty (AsBase58 a))
+
 instance ForMailbox s => FromField (MailboxRefKey s) where
   fromField w = fromField @String w <&> fromString @(MailboxRefKey s)
 

hbs2-peer/app/RPC2/Mailbox.hs

@@ -45,6 +45,12 @@ instance (ForMailboxRPC m) => HandleMethod m RpcMailboxCreate where
     void $ mailboxCreate @HBS2Basic mbs t puk
     debug $ "rpc.RpcMailboxCreate" <+> pretty (AsBase58 puk) <+> pretty t
 
+instance (ForMailboxRPC m) => HandleMethod m RpcMailboxDelete where
+
+  handleMethod puk = do
+    AnyMailboxService mbs <- getRpcContext @MailboxAPI @RPC2Context <&> rpcMailboxService
+    void $ mailboxDelete @HBS2Basic mbs puk
+    debug $ "rpc.RpcMailboxDelete" <+> pretty (AsBase58 puk)
 
 instance (ForMailboxRPC m) => HandleMethod m RpcMailboxList where
 

hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs

@@ -22,12 +22,15 @@ import HBS2.Peer.Proto.Mailbox.Ref
 
 import Data.Maybe
 import Control.Monad.Trans.Cont
-import Codec.Serialise
+import Codec.Serialise()
 
 data MailBoxStatusPayload s =
   MailBoxStatusPayload
   { mbsMailboxKey           :: MailboxKey s
-  , mbsMailboxHash  :: HashRef
+  , mbsMailboxType          :: MailboxType
+  , mbsMailboxHash          :: Maybe HashRef
+  , mbsMailboxPolicyVersion :: Maybe PolicyVersion
+  , mbsMailboxPolicyHash    :: Maybe HashRef
   }
   deriving stock (Generic)
 
@@ -39,14 +42,6 @@ data SetPolicyPayload s =
   }
   deriving stock (Generic)
 
-data GetPolicyPayload s =
-  GetPolicyPayload
-  { gppMailboxKey    :: MailboxKey s
-  , gppPolicyVersion :: PolicyVersion
-  , gppPolicyRef     :: HashRef
-  }
-  deriving stock (Generic)
-
 data DeleteMessagesPayload s =
   DeleteMessagesPayload
   { dmpMailboxKey    :: MailboxKey s
@@ -56,11 +51,9 @@ data DeleteMessagesPayload s =
 
 data MailBoxProtoMessage s e =
     SendMessage      (Message s) -- already has signed box
-  | CheckMailbox    (SignedBox (MailboxKey s) s)
+  | CheckMailbox     (MailboxKey s)
-  | MailboxStatus   (SignedBox (MailBoxStatusPayload s) s)
+  | MailboxStatus    (SignedBox (MailBoxStatusPayload s) s) -- signed by peer
   | SetPolicy        (SignedBox (SetPolicyPayload s) s)
-  | GetPolicy       (SignedBox (GetPolicyPayload s) s)
-  | CurrentPolicy   (GetPolicyPayload s)
   | DeleteMessages   (SignedBox (DeleteMessagesPayload s) s)
   deriving stock (Generic)
 
@@ -70,7 +63,6 @@ data MailBoxProto s e =
 
 instance ForMailbox s => Serialise (MailBoxStatusPayload s)
 instance ForMailbox s => Serialise (SetPolicyPayload s)
-instance ForMailbox s => Serialise (GetPolicyPayload s)
 instance ForMailbox s => Serialise (DeleteMessagesPayload s)
 instance ForMailbox s => Serialise (MailBoxProtoMessage s e)
 instance ForMailbox s => Serialise (MailBoxProto s e)
@@ -98,15 +90,33 @@ class ForMailbox s => IsMailboxService s a where
                 -> Recipient s
                 -> m (Either MailboxServiceError ())
 
+  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)))
+
+
 data AnyMailboxService s =
   forall a  . (IsMailboxService s a) => AnyMailboxService { mailboxService :: a }
 
@@ -115,8 +125,11 @@ data AnyMailboxAdapter s =
 
 instance ForMailbox s => IsMailboxService s (AnyMailboxService s) where
   mailboxCreate (AnyMailboxService a) = mailboxCreate @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
 
 instance IsMailboxProtoAdapter s (AnyMailboxAdapter s) where
   mailboxGetStorage (AnyMailboxAdapter a) = mailboxGetStorage @s a
@@ -127,6 +140,7 @@ mailboxProto :: forall e s m p a . ( MonadIO m
                                    , HasDeferred p e m
                                    , HasGossip e p m
                                    , IsMailboxProtoAdapter s a
+                                   , IsMailboxService s a
                                    , p ~ MailBoxProto s e
                                    , s ~ Encryption e
                                    , ForMailbox s
@@ -136,7 +150,7 @@ mailboxProto :: forall e s m p a . ( MonadIO m
              -> MailBoxProto (Encryption e) e
              ->  m ()
 
-mailboxProto inner adapter mess = do
+mailboxProto inner adapter mess = deferred @p do
   -- common stuff
 
   sto <- mailboxGetStorage @s adapter
@@ -181,13 +195,42 @@ mailboxProto inner adapter mess = do
           --   $class: leak
           void $ putBlock sto routed
 
-    CheckMailbox{} -> do
+    -- NOTE: CheckMailbox-auth
-      -- TODO: implement-CheckMailbox
+    --   поскольку пир не владеет приватными ключами,
-      --  [ ]  check-signed-box-or-drop
+    --   то и подписать это сообщение он не может.
-      --  [ ]  if-client-has-mailbox-then
+    --
-      --  [ ]     get-mailbox-status
+    --   В таком случае, и в фоновом режиме нельзя будет
-      --  [ ]     answer-MailboxStatus
+    --   синхронизировать ящики.
-      --  [ ]  gossip-message?
+    --
+    --   Поскольку все сообщения зашифрованы (но не их метаданные!)
+    --   статус мейлобокса является открытой в принципе информацией.
+    --
+    --   Теперь у нас два пути:
+    --    1. Отдавать только авторизованными пирам (которые имеют майлобоксы)
+    --       для этого сделаем сообщение CheckMailboxAuth{}
+    --
+    --    2. Шифровать дерево с метаданными, так как нам в принципе
+    --       может быть известен публичный ключ шифрования автора,
+    --       но это сопряжено со сложностями с обновлением ключей.
+    --
+    --    С другой стороны, если нас не очень беспокоит возможное раскрытие
+    --    метаданных --- то тот, кто скачает мейлобокс для анализа --- будет
+    --    участвовать в раздаче.
+    --
+    --    С другой стороны, может он и хочет участвовать в раздаче, что бы каким-то
+    --    образом ей вредить или устраивать слежку.
+    --
+    --    С этим всем можно бороться поведением и policy:
+    --
+    --    например:
+    --      - не отдавать сообщения неизвестным пирам
+    --      - требовать авторизацию (CheckMailboxAuth не нужен т.к. пир авторизован
+    --        и так и известен в протоколе)
+    --
+
+    CheckMailbox k -> do
+      -- TODO: check-policy
+
       none
 
     MailboxStatus{} -> do
@@ -206,12 +249,6 @@ mailboxProto inner adapter mess = do
     SetPolicy{} -> do
       none
 
-    GetPolicy{} -> do
-      none
-
-    CurrentPolicy{} -> do
-      none
-
     DeleteMessages{} -> do
       none
 

hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs

@@ -3,23 +3,52 @@ module HBS2.Peer.Proto.Mailbox.Entry where
 import HBS2.Prelude
 import HBS2.Peer.Proto.Mailbox.Types
 
+import Control.Applicative
 import Data.Word
 import Codec.Serialise
 import Data.Hashable
 
+data ProofOfDelete =
+  ProofOfDelete
+  { deletePolicy  :: Maybe HashRef
+  , deleteMessage :: Maybe HashRef
+  }
+  deriving stock (Generic,Eq,Ord,Show)
+
+data ProofOfExist =
+  ProofOfExist
+  { existedPolicy  :: Maybe HashRef
+  }
+  deriving stock (Generic,Eq,Ord,Show)
+
+instance Monoid ProofOfDelete where
+  mempty = ProofOfDelete mzero mzero
+
+instance Semigroup ProofOfDelete where
+  (<>) (ProofOfDelete a1 b1) (ProofOfDelete a2 b2) = ProofOfDelete (a1 <|> a2) (b1 <|> b2)
+
+instance Monoid ProofOfExist where
+  mempty = ProofOfExist mzero
+
+instance Semigroup ProofOfExist where
+  (<>) (ProofOfExist a1) (ProofOfExist a2) = ProofOfExist (a1 <|> a2)
+
 data MailboxEntry =
-  Existed HashRef | Deleted HashRef
+    Existed ProofOfExist  HashRef
+  | Deleted ProofOfDelete HashRef  -- ^ proof-of-message-to-validate
   deriving stock (Eq,Ord,Show,Generic)
 
 instance Hashable MailboxEntry where
   hashWithSalt salt = \case
-    Existed r -> hashWithSalt salt (0x177c1a3ad45b678e :: Word64, r)
+    Existed p r -> hashWithSalt salt (0x177c1a3ad45b678e :: Word64, serialise (p,r))
-    Deleted r -> hashWithSalt salt (0xac3196b4809ea027 :: Word64, r)
+    Deleted p r -> hashWithSalt salt (0xac3196b4809ea027 :: Word64, serialise (p,r))
 
 data RoutedEntry = RoutedEntry HashRef
                    deriving stock (Eq,Ord,Show,Generic)
 
 instance Serialise MailboxEntry
 instance Serialise RoutedEntry
+instance Serialise ProofOfDelete
+instance Serialise ProofOfExist
 
 

hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs

@@ -16,12 +16,14 @@ import Codec.Serialise
 
 data RpcMailboxPoke
 data RpcMailboxCreate
+data RpcMailboxDelete
 data RpcMailboxList
 data RpcMailboxSend
 data RpcMailboxGet
 
 type MailboxAPI = '[ RpcMailboxPoke
                    , RpcMailboxCreate
+                   , RpcMailboxDelete
                    , RpcMailboxList
                    , RpcMailboxSend
                    , RpcMailboxGet
@@ -42,6 +44,9 @@ type instance Output RpcMailboxPoke  = ()
 type instance Input RpcMailboxCreate   = (PubKey 'Sign HBS2Basic, MailboxType)
 type instance Output RpcMailboxCreate  = ()
 
+type instance Input RpcMailboxDelete   = (PubKey 'Sign HBS2Basic)
+type instance Output RpcMailboxDelete  = ()
+
 type instance Input RpcMailboxList   = ()
 type instance Output RpcMailboxList  = [(MailboxRefKey 'HBS2Basic, MailboxType)]