diff --git a/hbs2-peer/app/MailboxProtoWorker.hs b/hbs2-peer/app/MailboxProtoWorker.hs index 2386c13b..67a9962c 100644 --- a/hbs2-peer/app/MailboxProtoWorker.hs +++ b/hbs2-peer/app/MailboxProtoWorker.hs @@ -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 - diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs index c7067a3d..249c7645 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox.hs @@ -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 diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy/Basic.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy/Basic.hs index 23063799..c6ad52eb 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy/Basic.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy/Basic.hs @@ -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]