From 77401978fd304209a5703f8dd5339adcc911105e Mon Sep 17 00:00:00 2001 From: voidlizard Date: Fri, 11 Oct 2024 10:50:03 +0300 Subject: [PATCH] wip --- hbs2-peer/app/CLI/Mailbox.hs | 13 ++- hbs2-peer/app/MailboxProtoWorker.hs | 34 +++++- hbs2-peer/app/RPC2/Mailbox.hs | 6 + hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs | 103 ++++++++++++------ .../lib/HBS2/Peer/Proto/Mailbox/Entry.hs | 35 +++++- hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs | 5 + 6 files changed, 156 insertions(+), 40 deletions(-) diff --git a/hbs2-peer/app/CLI/Mailbox.hs b/hbs2-peer/app/CLI/Mailbox.hs index 2a0061e0..7095a632 100644 --- a/hbs2-peer/app/CLI/Mailbox.hs +++ b/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) diff --git a/hbs2-peer/app/MailboxProtoWorker.hs b/hbs2-peer/app/MailboxProtoWorker.hs index 5914d6dc..1667aed3 100644 --- a/hbs2-peer/app/MailboxProtoWorker.hs +++ b/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) diff --git a/hbs2-peer/app/RPC2/Mailbox.hs b/hbs2-peer/app/RPC2/Mailbox.hs index ef015773..76d5ea0a 100644 --- a/hbs2-peer/app/RPC2/Mailbox.hs +++ b/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 diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs index 33c965fe..d50ee739 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs +++ b/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 + { mbsMailboxKey :: MailboxKey s + , 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 @@ -55,13 +50,11 @@ data DeleteMessagesPayload s = deriving stock (Generic) data MailBoxProtoMessage s e = - SendMessage (Message s) -- already has signed box - | CheckMailbox (SignedBox (MailboxKey s) s) - | MailboxStatus (SignedBox (MailBoxStatusPayload s) s) - | SetPolicy (SignedBox (SetPolicyPayload s) s) - | GetPolicy (SignedBox (GetPolicyPayload s) s) - | CurrentPolicy (GetPolicyPayload s) - | DeleteMessages (SignedBox (DeleteMessagesPayload s) s) + SendMessage (Message s) -- already has signed box + | CheckMailbox (MailboxKey s) + | MailboxStatus (SignedBox (MailBoxStatusPayload s) s) -- signed by peer + | SetPolicy (SignedBox (SetPolicyPayload s) s) + | DeleteMessages (SignedBox (DeleteMessagesPayload s) s) deriving stock (Generic) data MailBoxProto s e = @@ -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 - -- TODO: implement-CheckMailbox - -- [ ] check-signed-box-or-drop - -- [ ] if-client-has-mailbox-then - -- [ ] get-mailbox-status - -- [ ] answer-MailboxStatus - -- [ ] gossip-message? + -- NOTE: CheckMailbox-auth + -- поскольку пир не владеет приватными ключами, + -- то и подписать это сообщение он не может. + -- + -- В таком случае, и в фоновом режиме нельзя будет + -- синхронизировать ящики. + -- + -- Поскольку все сообщения зашифрованы (но не их метаданные!) + -- статус мейлобокса является открытой в принципе информацией. + -- + -- Теперь у нас два пути: + -- 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 diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs index da92eda5..909f5f79 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Entry.hs +++ b/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) - Deleted r -> hashWithSalt salt (0xac3196b4809ea027 :: Word64, r) + Existed p r -> hashWithSalt salt (0x177c1a3ad45b678e :: Word64, serialise (p,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 diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs index e7efd74b..653d2f3a 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/Mailbox.hs +++ b/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)]