From 3fde72e230f061991b91aa1680dec2f5c7766586 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Mon, 14 Oct 2024 07:50:08 +0300 Subject: [PATCH] wip, delete messages --- hbs2-peer/app/CLI/Mailbox.hs | 50 ++++++++ hbs2-peer/app/MailboxProtoWorker.hs | 111 +++++++++++++++++- hbs2-peer/app/RPC2/Mailbox.hs | 8 ++ hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs | 55 +++++++-- .../lib/HBS2/Peer/Proto/Mailbox/Entry.hs | 2 +- .../lib/HBS2/Peer/Proto/Mailbox/Types.hs | 1 + hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs | 5 + 7 files changed, 217 insertions(+), 15 deletions(-) diff --git a/hbs2-peer/app/CLI/Mailbox.hs b/hbs2-peer/app/CLI/Mailbox.hs index 0c150387..8da45c8c 100644 --- a/hbs2-peer/app/CLI/Mailbox.hs +++ b/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 + +|] + + diff --git a/hbs2-peer/app/MailboxProtoWorker.hs b/hbs2-peer/app/MailboxProtoWorker.hs index c57362b5..08f1d77e 100644 --- a/hbs2-peer/app/MailboxProtoWorker.hs +++ b/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{..} ref predicate = do - pure $ Right () + mailboxSendDelete w@MailboxProtoWorker{..} box = do + debug $ red "mailboxSendDelete" + + 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 diff --git a/hbs2-peer/app/RPC2/Mailbox.hs b/hbs2-peer/app/RPC2/Mailbox.hs index 0076e35d..9263e4eb 100644 --- a/hbs2-peer/app/RPC2/Mailbox.hs +++ b/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 diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs index 2219f198..07b75968 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs +++ b/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 - -> MailboxMessagePredicate + -> SignedBox (DeleteMessagesPayload s) s -> 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 - none + DeleteMessages box -> deferred @p do + 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 diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs index 2036a4f5..5f7f07c2 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs +++ b/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) diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs index fb628d70..918db403 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs +++ b/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) diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs index f0897f39..f2c7b7bf 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs +++ b/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)