mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
voidlizard
parent
868068d1cc
commit
77401978fd
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue