wip, delete messages

hbs2-peer/app/CLI/Mailbox.hs

@@ -31,6 +31,7 @@ import Control.Monad.Trans.Cont
 import Control.Monad.Trans.Maybe
 import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.ByteString qualified as BS
 import Data.Either
 import Data.Coerce
 import Data.Config.Suckless.Script
@@ -227,6 +228,46 @@ runMailboxCLI rpc s = do
 
               liftIO $ print $ vcat (fmap fmtMbox v)
 
+        brief "read message"
+         $ desc [qc|;; reads message
+  read HASH
+|]
+         $ entry $ bindMatch "read" $ nil_ $ \case
+            [ HashLike mhash ] -> do
+
+              let rms = ReadMessageServices ( liftIO . runKeymanClientRO . extractGroupKeySecret)
+
+              (s,_,bs) <- getBlock sto (coerce mhash)
+                            >>= orThrowUser "message not found"
+                              <&> deserialiseOrFail @(Message HBS2Basic)
+                              >>= orThrowUser "invalid message format"
+                              >>= readMessage rms
+
+              liftIO $ BS.putStr bs
+
+              none
+
+            _ -> throwIO $ BadFormException @C nil
+
+        brief "delete message"
+          $ desc deleteMessageDesc
+          $ entry $ bindMatch "delete:message" $ nil_ $ \case
+            [ SignPubKeyLike ref, HashLike mess ] -> do
+
+               creds <- runKeymanClientRO (loadCredentials ref)
+                         >>= orThrowUser ("can't load credentials for" <+> pretty (AsBase58 ref))
+
+               let expr  = MailboxMessagePredicate1 (Op (MessageHashEq mess))
+               let messP = DeleteMessagesPayload @HBS2Basic expr
+
+               let box = makeSignedBox @HBS2Basic (view peerSignPk creds) (view peerSignSk creds) messP
+
+               callRpcWaitMay @RpcMailboxDeleteMessages t api box
+                  >>= orThrowUser "rpc call timeout"
+                  >>= orThrowPassIO
+
+            _ -> throwIO $ BadFormException @C nil
+
         brief "list messages"
           $ entry $ bindMatch "list:messages" $ nil_ $ \case
              [ SignPubKeyLike m ] -> void $ runMaybeT do
@@ -359,3 +400,12 @@ setPolicyDesc = [qc|
 setPolicyExamples :: ManExamples
 setPolicyExamples = mempty
 
+deleteMessageDesc :: Doc a
+deleteMessageDesc = [qc|
+
+;; deletes message from mailbox
+  delete:message MAILBOX-KEY MESSAGE-HASH
+
+|]
+
+

hbs2-peer/app/MailboxProtoWorker.hs

@@ -2,6 +2,7 @@
 {-# Language MultiWayIf #-}
 {-# Language AllowAmbiguousTypes #-}
 {-# Language UndecidableInstances #-}
+{-# Language PatternSynonyms #-}
 module MailboxProtoWorker ( mailboxProtoWorker
                           , createMailboxProtoWorker
                           , MailboxProtoWorker
@@ -57,6 +58,7 @@ import Data.Hashable
 import Codec.Serialise
 import Lens.Micro.Platform
 import Text.InterpolatedString.Perl6 (qc)
+import Streaming.Prelude qualified as S
 import UnliftIO
 
 newtype PolicyHash = PolicyHash HashRef
@@ -131,6 +133,9 @@ data MailboxProtoWorker (s :: CryptoScheme) e =
 okay :: Monad m => good -> m (Either bad good)
 okay good = pure (Right good)
 
+pattern PlainMessageDelete :: forall {s :: CryptoScheme} . HashRef -> DeleteMessagesPayload s
+pattern PlainMessageDelete x <- DeleteMessagesPayload (MailboxMessagePredicate1 (Op (MessageHashEq x)))
+
 instance (s ~ HBS2Basic, e ~ L4Proto, s ~ Encryption e) => IsMailboxProtoAdapter s (MailboxProtoWorker s e) where
 
   mailboxGetCredentials = pure . mpwCredentials
@@ -146,6 +151,39 @@ instance (s ~ HBS2Basic, e ~ L4Proto, s ~ Encryption e) => IsMailboxProtoAdapter
         writeTBQueue inMessageQueue (m,c)
         modifyTVar   inMessageQueueInNum succ
 
+  mailboxAcceptDelete MailboxProtoWorker{..} mbox dmp box = do
+    debug $ red "<<>> mailbox: mailboxAcceptDelete" <+> pretty mbox
+
+    let sto = mpwStorage
+    -- TODO: add-policy-reference
+
+    flip runContT pure do
+
+      h' <- putBlock sto (serialise box)
+
+      h <- ContT $ maybe1 h' storageFail
+
+      let proof = ProofOfDelete (Just (HashRef h))
+
+      let what' = case dmp of
+                   PlainMessageDelete x -> Just x
+                   _ -> Nothing
+
+      what <- ContT $ maybe1 what' unsupportedPredicate
+
+      let de = Deleted proof what
+
+      deh' <- enqueueBlock sto (serialise (Deleted proof what))
+               <&> fmap HashRef
+
+      deh <- ContT $ maybe1 deh' storageFail
+
+      atomically $ modifyTVar inMessageMergeQueue (HM.insert mbox (HS.singleton deh))
+
+    where
+      storageFail = err $ red "mailbox (storage:critical)" <+> "block writing failure"
+      unsupportedPredicate = err $ red "mailbox (unsuported-predicate)"
+
 instance ( s ~ Encryption e, e ~ L4Proto
          ) => IsMailboxService s (MailboxProtoWorker s e) where
   mailboxCreate MailboxProtoWorker{..} t p = do
@@ -231,7 +269,7 @@ instance ( s ~ Encryption e, e ~ L4Proto
 
       mdbe <- readTVarIO mailboxDB
 
-      dbe <- ContT $ maybe1 mdbe (pure $ Left (MailboxCreateFailed "database not ready"))
+      dbe <- ContT $ maybe1 mdbe (pure $ Left (MailboxOperationError "database not ready"))
 
       debug $ red "delete fucking mailbox" <+> pretty (MailboxRefKey @s mbox)
 
@@ -243,9 +281,40 @@ instance ( s ~ Encryption e, e ~ L4Proto
 
       pure $ Right ()
 
-  -- FIXME: refactor
+  mailboxSendDelete w@MailboxProtoWorker{..} box = do
-  mailboxSendDelete w@MailboxProtoWorker{..} ref predicate = do
+    debug $ red "mailboxSendDelete"
-    pure $ Right ()
+
+    flip runContT pure do
+
+      -- 1. unpack-and-check
+      let r = unboxSignedBox0 box
+
+      (k, _) <- ContT $ maybe1 r authFailed
+
+      mdbe <- readTVarIO mailboxDB
+
+      dbe <- ContT $ maybe1 mdbe dbNotReady
+
+      t <- getMailboxType_ dbe (MailboxRefKey @s k)
+
+      void $ ContT $ maybe1 t (noMailbox k)
+
+      -- 2. what?
+      -- gossip and shit
+
+      liftIO $ withPeerM mpwPeerEnv do
+        me <- ownPeer @e
+        runResponseM me $ do
+          mailboxProto @e True w (MailBoxProtoV1 (DeleteMessages box))
+
+      okay ()
+
+    where
+      dbNotReady = pure $ Left (MailboxOperationError "database not ready")
+      authFailed = pure $ Left (MailboxAuthError "inconsistent signature")
+      noMailbox k = pure $
+        Left (MailboxOperationError (show $ "no mailox" <+> pretty (AsBase58 k)))
+
 
   mailboxSendMessage w@MailboxProtoWorker{..} mess = do
     -- we do not check message signature here
@@ -566,10 +635,42 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do
                    modifyTVar inMessageMergeQueue  (HM.delete r)
                    pure n
 
+        newTxProvenL <- S.toList_ $
+          for_ newTx $ \th -> void $ runMaybeT do
+
+            tx <- getBlock sto (coerce th)
+                    >>= toMPlus
+                    <&> deserialiseOrFail @MailboxEntry
+                    >>= toMPlus
+
+            case tx of
+              -- maybe to something more sophisticated
+              Exists{} -> lift $ S.yield th
+
+              Deleted (ProofOfDelete{..}) _ -> do
+                h   <- toMPlus deleteMessage
+
+                box <- getBlock sto (coerce h)
+                         >>= toMPlus
+                         <&> deserialiseOrFail @(SignedBox (DeleteMessagesPayload s) s)
+                         >>= toMPlus
+
+                debug $ red "<<***>> mailbox:" <+> "found proof of message deleting" <+> pretty h
+
+                (pk,_) <- unboxSignedBox0 box & toMPlus
+
+                guard (MailboxRefKey pk == r)
+
+                debug $ red "<<***>> mailbox:" <+> "PROVEN message deleting" <+> pretty h
+
+                lift $ S.yield th
+
+        let newTxProven = HS.fromList newTxProvenL
+
         v <- getRef sto r <&> fmap HashRef
         txs <- maybe1 v (pure mempty) (readLog (liftIO . getBlock sto) )
 
-        let mergedTx = HS.fromList txs <> newTx & HS.toList
+        let mergedTx = HS.fromList txs <> newTxProven & HS.toList
 
         -- FIXME: size-hardcode-again
         let pt = toPTree (MaxSize 6000) (MaxNum 1024) mergedTx

hbs2-peer/app/RPC2/Mailbox.hs

@@ -91,6 +91,14 @@ instance (ForMailboxRPC m) => HandleMethod m RpcMailboxSend where
     debug $ "rpc.RpcMailboxSend"
     void $ mailboxSendMessage w mess
 
+instance (ForMailboxRPC m) => HandleMethod m RpcMailboxDeleteMessages where
+
+  handleMethod sbox = do
+    co <- getRpcContext @MailboxAPI @RPC2Context
+    let w = rpcMailboxService co
+    debug $ "rpc.RpcMailboxDeleteMessages"
+    mailboxSendDelete w sbox
+
 instance (ForMailboxRPC m) => HandleMethod m RpcMailboxGet where
 
   handleMethod mbox = do

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

@@ -60,10 +60,9 @@ data MailBoxStatusPayload s =
   }
   deriving stock (Generic)
 
-data DeleteMessagesPayload s =
+data DeleteMessagesPayload (s :: CryptoScheme) =
   DeleteMessagesPayload
-  { dmpMailboxKey    :: MailboxKey s
+  { dmpPredicate     :: MailboxMessagePredicate
-  , dmpPredicate     :: MailboxMessagePredicate
   }
   deriving stock (Generic)
 
@@ -71,7 +70,7 @@ 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)
+  | DeleteMessages   (SignedBox (DeleteMessagesPayload s ) s)
   deriving stock (Generic)
 
 data MailBoxProto s e =
@@ -96,6 +95,12 @@ class IsMailboxProtoAdapter s a where
                         -> MessageContent s
                         -> m ()
 
+  mailboxAcceptDelete   :: forall m . (ForMailbox s, MonadIO m)
+                        => a
+                        -> MailboxRefKey s
+                        -> DeleteMessagesPayload s
+                        -> SignedBox (DeleteMessagesPayload s) s -- ^ we need this for proof
+                        -> m ()
 
 class ForMailbox s => IsMailboxService s a where
 
@@ -123,8 +128,7 @@ class ForMailbox s => IsMailboxService s a where
 
   mailboxSendDelete :: forall m . MonadIO m
                     => a
-                    -> MailboxRefKey s
+                    -> SignedBox (DeleteMessagesPayload s) s
-                    -> MailboxMessagePredicate
                     -> m (Either MailboxServiceError ())
 
   mailboxListBasic :: forall m . MonadIO m
@@ -169,6 +173,7 @@ instance IsMailboxProtoAdapter s (AnyMailboxAdapter s) where
   mailboxGetCredentials (AnyMailboxAdapter a) = mailboxGetCredentials @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{..} =
@@ -235,7 +240,7 @@ mailboxProto inner adapter mess = deferred @p do
         --   $workflow: backlog
         (_, content) <- ContT $ maybe1 unboxed' none
 
-        let h = hashObject @HbSync (serialise msg) & HashRef
+        let h = hashObject @HbSync (serialise mess) & HashRef
 
         let routed = serialise (RoutedEntry h)
         let routedHash = hashObject routed
@@ -339,7 +344,39 @@ mailboxProto inner adapter mess = deferred @p do
 
         void $ mailboxAcceptStatus adapter (MailboxRefKey mbsMailboxKey) who content
 
-    DeleteMessages{} -> do
+    DeleteMessages box -> deferred @p do
-      none
+      flip runContT pure do
+
+        -- TODO: possible-ddos
+        --   посылаем левые сообщения, заставляем считать
+        --   подписи
+        --
+        --   Решения:  ограничивать поток сообщения от пиров
+        --
+        --   Возможно, вообще принимать только сообщения от пиров,
+        --   которые содержатся в U {Policy(Mailbox_i)}
+        --
+        --   Возможно: PoW
+
+        let r = unboxSignedBox0 box
+
+        (mbox, spp) <- ContT $ maybe1 r none
+
+        let h = hashObject @HbSync (serialise mess) & HashRef
+
+        let routed = serialise (RoutedEntry h)
+        let routedHash = hashObject routed
+
+        seen <- hasBlock sto routedHash <&> isJust
+
+        unless seen $ lift do
+          gossip mess
+          -- TODO: expire-block-and-collect-garbage
+          --   $class: leak
+          void $ putBlock sto routed
+
+        mailboxAcceptDelete adapter (MailboxRefKey mbox) spp box
+
+        none
 
 

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

@@ -10,7 +10,7 @@ import Data.Hashable
 
 data ProofOfDelete =
   ProofOfDelete
-  { deleteMessage :: Maybe HashRef
+  { deleteMessage :: Maybe HashRef -- ^ different things?
   }
   deriving stock (Generic,Eq,Ord,Show)
 

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

@@ -31,6 +31,7 @@ import Control.Exception
 
 data MailboxServiceError =
     MailboxCreateFailed String
+  | MailboxOperationError String
   | MailboxSetPolicyFailed String
   | MailboxAuthError String
   deriving stock (Typeable,Show,Generic)

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

@@ -22,6 +22,7 @@ data RpcMailboxGetStatus
 data RpcMailboxFetch
 data RpcMailboxList
 data RpcMailboxSend
+data RpcMailboxDeleteMessages
 data RpcMailboxGet
 
 type MailboxAPI = '[ RpcMailboxPoke
@@ -32,6 +33,7 @@ type MailboxAPI = '[ RpcMailboxPoke
                    , RpcMailboxFetch
                    , RpcMailboxList
                    , RpcMailboxSend
+                   , RpcMailboxDeleteMessages
                    , RpcMailboxGet
                    ]
 
@@ -68,6 +70,9 @@ type instance Output RpcMailboxList  = [(MailboxRefKey 'HBS2Basic, MailboxType)]
 type instance Input RpcMailboxSend  = (Message HBS2Basic)
 type instance Output RpcMailboxSend = ()
 
+type instance Input RpcMailboxDeleteMessages  = (SignedBox (DeleteMessagesPayload HBS2Basic) HBS2Basic)
+type instance Output RpcMailboxDeleteMessages = (Either MailboxServiceError ())
+
 type instance Input RpcMailboxGet = (PubKey 'Sign HBS2Basic)
 type instance Output RpcMailboxGet = (Maybe HashRef)