mirror of https://github.com/voidlizard/hbs2
wip, integrating policy
This commit is contained in:
voidlizard
parent
15be1cc0b4
commit
3fc740099e
|
|
@ -20,6 +20,7 @@ import HBS2.Net.Proto
|
|||
import HBS2.Base58
|
||||
import HBS2.Storage
|
||||
import HBS2.Storage.Operations.Missed
|
||||
import HBS2.Storage.Operations.ByteString
|
||||
import HBS2.Merkle
|
||||
import HBS2.Hash
|
||||
import HBS2.Net.Auth.Credentials
|
||||
|
|
@ -53,10 +54,12 @@ import Control.Monad.Trans.Maybe
|
|||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Except (throwError)
|
||||
import Data.Coerce
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.HashSet qualified as HS
|
||||
import Data.Either
|
||||
import Data.List qualified as L
|
||||
import Data.Maybe
|
||||
import Data.Word
|
||||
|
|
@ -125,7 +128,7 @@ data MailboxProtoWorker (s :: CryptoScheme) e =
|
|||
, mpwStorage :: AnyStorage
|
||||
, mpwCredentials :: PeerCredentials s
|
||||
, mpwFetchQ :: TVar (HashSet (MailboxRefKey s))
|
||||
, inMessageQueue :: TBQueue (Message s, MessageContent s)
|
||||
, inMessageQueue :: TBQueue (Maybe (PubKey 'Sign s), Message s, MessageContent s)
|
||||
, inMessageMergeQueue :: TVar (HashMap (MailboxRefKey s) (HashSet HashRef))
|
||||
, inPolicyDownloadQ :: TVar (HashMap HashRef (PolicyDownload s))
|
||||
, inMailboxDownloadQ :: TVar (HashMap HashRef (MailboxDownload s))
|
||||
|
|
@ -145,7 +148,7 @@ pattern PlainMessageDelete x <- DeleteMessagesPayload (MailboxMessagePredicate1
|
|||
instance IsAcceptPolicy HBS2Basic () where
|
||||
policyAcceptPeer _ _ = pure True
|
||||
policyAcceptMessage _ _ _ = pure True
|
||||
|
||||
policyAcceptSender _ _ = pure True
|
||||
|
||||
instance (s ~ HBS2Basic, e ~ L4Proto, s ~ Encryption e) => IsMailboxProtoAdapter s (MailboxProtoWorker s e) where
|
||||
|
||||
|
|
@ -153,15 +156,20 @@ instance (s ~ HBS2Basic, e ~ L4Proto, s ~ Encryption e) => IsMailboxProtoAdapter
|
|||
|
||||
mailboxGetStorage = pure . mpwStorage
|
||||
|
||||
mailboxGetPolicy w = pure (AnyPolicy @s ())
|
||||
mailboxGetPolicy MailboxProtoWorker{..} mbox = do
|
||||
let def = AnyPolicy (defaultBasicPolicy @s)
|
||||
fromMaybe def <$> runMaybeT do
|
||||
dbe <- readTVarIO mailboxDB >>= toMPlus
|
||||
co <- loadPolicyContent dbe mpwStorage mbox
|
||||
pure (AnyPolicy co)
|
||||
|
||||
mailboxAcceptMessage MailboxProtoWorker{..} m c = do
|
||||
mailboxAcceptMessage MailboxProtoWorker{..} peer m c = do
|
||||
atomically do
|
||||
full <- isFullTBQueue inMessageQueue
|
||||
if full then do
|
||||
modifyTVar inMessageQueueDropped succ
|
||||
else do
|
||||
writeTBQueue inMessageQueue (m,c)
|
||||
writeTBQueue inMessageQueue (peer, m,c)
|
||||
modifyTVar inMessageQueueInNum succ
|
||||
|
||||
mailboxAcceptDelete MailboxProtoWorker{..} mbox dmp box = do
|
||||
|
|
@ -494,6 +502,32 @@ loadPolicyPayloadUnboxed dbe sto mbox = do
|
|||
<&> join
|
||||
<&> fmap snd
|
||||
|
||||
loadPolicyContent :: forall s m . (s ~ HBS2Basic, ForMailbox s, MonadIO m)
|
||||
=> DBPipeEnv
|
||||
-> AnyStorage
|
||||
-> MailboxRefKey s
|
||||
-> m (BasicPolicy s)
|
||||
loadPolicyContent dbe sto mbox = do
|
||||
let def = defaultBasicPolicy @s
|
||||
fromMaybe def <$> runMaybeT do
|
||||
SetPolicyPayload{..} <- loadPolicyPayloadUnboxed dbe sto mbox >>= toMPlus
|
||||
|
||||
lbs' <- runExceptT (readFromMerkle sto (SimpleKey (coerce sppPolicyRef)))
|
||||
|
||||
when (isLeft lbs') do
|
||||
warn $ yellow "can't read policy for" <+> pretty mbox
|
||||
|
||||
syn' <- toMPlus lbs'
|
||||
<&> LBS8.unpack
|
||||
<&> parseTop
|
||||
|
||||
when (isLeft syn') do
|
||||
warn $ yellow "can't parse policy for" <+> pretty mbox
|
||||
|
||||
syn <- toMPlus syn'
|
||||
|
||||
liftIO (parseBasicPolicy syn) >>= toMPlus
|
||||
|
||||
getMailboxType_ :: (ForMailbox s, MonadIO m) => DBPipeEnv -> MailboxRefKey s -> m (Maybe MailboxType)
|
||||
getMailboxType_ d r = do
|
||||
let sql = [qc|select type from mailbox where recipient = ? limit 1|]
|
||||
|
|
@ -586,15 +620,37 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do
|
|||
forever do
|
||||
pause @'Seconds 10
|
||||
mess <- atomically $ STM.flushTBQueue inMessageQueue
|
||||
for_ mess $ \(m,s) -> do
|
||||
for_ mess $ \(peer, m, s) -> do
|
||||
atomically $ modifyTVar inMessageQueueInNum pred
|
||||
|
||||
-- TODO: process-with-policy
|
||||
|
||||
for_ (messageRecipients s) $ \rcpt -> void $ runMaybeT do
|
||||
mbox <- getMailboxType_ @s dbe (MailboxRefKey rcpt)
|
||||
|
||||
let theMailbox = MailboxRefKey @s rcpt
|
||||
|
||||
mbox <- getMailboxType_ @s dbe theMailbox
|
||||
>>= toMPlus
|
||||
|
||||
-- FIXME: excess-sign-check
|
||||
(sender, _) <- unboxSignedBox0 (messageContent m) & toMPlus
|
||||
|
||||
po <- mailboxGetPolicy @s me theMailbox
|
||||
|
||||
acceptPeer <- maybe1 peer (pure True) $ \p ->
|
||||
policyAcceptPeer @s po p
|
||||
|
||||
unless acceptPeer do
|
||||
warn $ red "message dropped by peer policy"
|
||||
<+> pretty mbox <+> pretty (fmap AsBase58 peer)
|
||||
mzero
|
||||
|
||||
accept <- policyAcceptMessage @s po sender s
|
||||
|
||||
unless accept do
|
||||
warn $ red "message dropped by policy for" <+> pretty theMailbox
|
||||
mzero
|
||||
|
||||
-- TODO: ASAP-block-accounting
|
||||
ha' <- putBlock sto (serialise m) <&> fmap HashRef
|
||||
|
||||
|
|
@ -604,9 +660,7 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do
|
|||
err $ red "storage error, can't store message"
|
||||
mzero
|
||||
|
||||
let ref = MailboxRefKey @s rcpt
|
||||
|
||||
debug $ yellow "mailbox: message stored" <+> pretty ref <+> pretty ha
|
||||
debug $ yellow "mailbox: message stored" <+> pretty theMailbox <+> pretty ha
|
||||
|
||||
-- TODO: add-policy-reference
|
||||
let proof = ProofOfExist mzero
|
||||
|
|
@ -614,7 +668,7 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do
|
|||
|
||||
for_ h' $ \h -> do
|
||||
atomically do
|
||||
modifyTVar inMessageMergeQueue (HM.insertWith (<>) ref (HS.singleton (HashRef h)))
|
||||
modifyTVar inMessageMergeQueue (HM.insertWith (<>) theMailbox (HS.singleton (HashRef h)))
|
||||
|
||||
-- TODO: check-attachment-policy-for-mailbox
|
||||
|
||||
|
|
@ -829,7 +883,7 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do
|
|||
|
||||
Just (_, content) -> do
|
||||
-- FIXME: what-if-message-queue-full?
|
||||
mailboxAcceptMessage me normal content
|
||||
mailboxAcceptMessage me mzero normal content
|
||||
pure ()
|
||||
|
||||
failNum <- readTVarIO fails
|
||||
|
|
@ -919,10 +973,4 @@ instance ForMailbox s => FromField (MailboxRefKey s) where
|
|||
instance FromField MailboxType where
|
||||
fromField w = fromField @String w <&> fromString @MailboxType
|
||||
|
||||
-- TODO: test-multiple-recipients
|
||||
|
||||
-- TODO: implement-basic-policy
|
||||
|
||||
-- TODO: test-basic-policy
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -44,10 +44,11 @@ class ForMailbox s => IsMailboxProtoAdapter s a where
|
|||
|
||||
mailboxGetStorage :: forall m . MonadIO m => a -> m AnyStorage
|
||||
|
||||
mailboxGetPolicy :: forall m . MonadIO m => a -> m (AnyPolicy s)
|
||||
mailboxGetPolicy :: forall m . MonadIO m => a -> MailboxRefKey s -> m (AnyPolicy s)
|
||||
|
||||
mailboxAcceptMessage :: forall m . (ForMailbox s, MonadIO m)
|
||||
=> a
|
||||
-> Maybe (PubKey 'Sign s) -- ^ peer
|
||||
-> Message s
|
||||
-> MessageContent s
|
||||
-> m ()
|
||||
|
|
@ -154,7 +155,6 @@ mailboxProto inner adapter mess = deferred @p do
|
|||
-- common stuff
|
||||
|
||||
sto <- mailboxGetStorage @s adapter
|
||||
policy <- mailboxGetPolicy @s adapter
|
||||
pc <- mailboxGetCredentials @s adapter
|
||||
|
||||
now <- liftIO $ getPOSIXTime <&> round
|
||||
|
|
@ -163,22 +163,17 @@ mailboxProto inner adapter mess = deferred @p do
|
|||
|
||||
flip runContT pure $ callCC \exit -> do
|
||||
|
||||
se <- ContT $ maybe1 se' none
|
||||
|
||||
pip <- if inner then do
|
||||
pure $ view peerSignPk pc
|
||||
else do
|
||||
se <- ContT $ maybe1 se' none
|
||||
pure $ view peerSignKey se
|
||||
|
||||
acceptPeer <- policyAcceptPeer @s policy pip
|
||||
|
||||
unless acceptPeer do
|
||||
debug $ red "Peer rejected by policy" <+> pretty (AsBase58 pip)
|
||||
exit ()
|
||||
|
||||
case mailBoxProtoPayload mess of
|
||||
SendMessage msg -> do
|
||||
|
||||
debug $ red "AAAAAA!" <+> pretty now
|
||||
|
||||
-- проверить подпись быстрее, чем читать диск
|
||||
let unboxed' = unboxSignedBox0 @(MessageContent s) (messageContent msg)
|
||||
|
||||
|
|
@ -187,6 +182,7 @@ mailboxProto inner adapter mess = deferred @p do
|
|||
-- $workflow: backlog
|
||||
(_, content) <- ContT $ maybe1 unboxed' none
|
||||
|
||||
|
||||
let h = hashObject @HbSync (serialise mess) & HashRef
|
||||
|
||||
let routed = serialise (RoutedEntry h)
|
||||
|
|
@ -196,7 +192,18 @@ mailboxProto inner adapter mess = deferred @p do
|
|||
|
||||
unless seen $ lift do
|
||||
gossip mess
|
||||
mailboxAcceptMessage adapter msg content
|
||||
let whoever = if inner then Nothing else Just pip
|
||||
|
||||
-- TODO: maybe-dont-gossip-message-if-dropped-by-policy
|
||||
-- сейчас policy проверяется для почтового ящика,
|
||||
-- а тут мы еще не знаем, какой почтовый ящик и есть
|
||||
-- ли он вообще. надо бы не рассылать, если пира
|
||||
-- не поддерживаем.
|
||||
--
|
||||
-- с другой стороны -- мы не поддерживаем, а другие,
|
||||
-- может, поддерживают.
|
||||
|
||||
mailboxAcceptMessage adapter whoever msg content
|
||||
-- TODO: expire-block-and-collect-garbage
|
||||
-- $class: leak
|
||||
void $ putBlock sto routed
|
||||
|
|
@ -251,7 +258,7 @@ mailboxProto inner adapter mess = deferred @p do
|
|||
|
||||
let r = unboxSignedBox0 @(MailBoxStatusPayload s) box
|
||||
|
||||
let PeerData{..} = se
|
||||
PeerData{..} <- ContT $ maybe1 se' none
|
||||
|
||||
(who, content@MailBoxStatusPayload{..}) <- ContT $ maybe1 r none
|
||||
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@ module HBS2.Peer.Proto.Mailbox.Policy.Basic
|
|||
, BasicPolicyAction(..)
|
||||
, getAsSyntax
|
||||
, parseBasicPolicy
|
||||
, defaultBasicPolicy
|
||||
, BasicPolicy(..)
|
||||
) where
|
||||
|
||||
|
|
@ -73,6 +74,8 @@ getAsSyntax BasicPolicy{..} =
|
|||
Allow -> mkSym "allow"
|
||||
Deny -> mkSym "deny"
|
||||
|
||||
defaultBasicPolicy :: forall s . (ForMailbox s) => BasicPolicy s
|
||||
defaultBasicPolicy = BasicPolicy Deny Deny mempty mempty
|
||||
|
||||
parseBasicPolicy :: forall s c m . (IsContext c, s ~ HBS2Basic, ForMailbox s, MonadUnliftIO m)
|
||||
=> [Syntax c]
|
||||
|
|
|
|||
Loading…
Reference in New Issue