wip, integrating policy

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 theMailbox <+> pretty ha
-
-            debug $ yellow "mailbox: message stored" <+> pretty ref <+> 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
-
 

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
 

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]