mirror of https://github.com/voidlizard/hbs2
wip, delete messages
This commit is contained in:
voidlizard
parent
4831dcfa70
commit
3fde72e230
|
|
@ -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
|
||||
|
||||
|]
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ import Data.Hashable
|
|||
|
||||
data ProofOfDelete =
|
||||
ProofOfDelete
|
||||
{ deleteMessage :: Maybe HashRef
|
||||
{ deleteMessage :: Maybe HashRef -- ^ different things?
|
||||
}
|
||||
deriving stock (Generic,Eq,Ord,Show)
|
||||
|
||||
|
|
|
|||
|
|
@ -31,6 +31,7 @@ import Control.Exception
|
|||
|
||||
data MailboxServiceError =
|
||||
MailboxCreateFailed String
|
||||
| MailboxOperationError String
|
||||
| MailboxSetPolicyFailed String
|
||||
| MailboxAuthError String
|
||||
deriving stock (Typeable,Show,Generic)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue