From f3ad2341a49c2900966bb0abf6226c431f25d4cc Mon Sep 17 00:00:00 2001 From: voidlizard Date: Tue, 15 Oct 2024 06:08:27 +0300 Subject: [PATCH] wip, extracted BasicPolicy --- hbs2-peer/app/MailboxProtoWorker.hs | 67 +--------- hbs2-peer/hbs2-peer.cabal | 1 + .../HBS2/Peer/Proto/Mailbox/Policy/Basic.hs | 117 ++++++++++++++++++ 3 files changed, 119 insertions(+), 66 deletions(-) create mode 100644 hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy/Basic.hs diff --git a/hbs2-peer/app/MailboxProtoWorker.hs b/hbs2-peer/app/MailboxProtoWorker.hs index 8cd1e4e5..2386c13b 100644 --- a/hbs2-peer/app/MailboxProtoWorker.hs +++ b/hbs2-peer/app/MailboxProtoWorker.hs @@ -29,6 +29,7 @@ import HBS2.Peer.Proto import HBS2.Peer.Proto.Mailbox import HBS2.Peer.Proto.Mailbox.Entry import HBS2.Peer.Proto.Mailbox.Policy +import HBS2.Peer.Proto.Mailbox.Policy.Basic import HBS2.Net.Messaging.Unix import HBS2.Net.Auth.Credentials @@ -145,71 +146,6 @@ instance IsAcceptPolicy HBS2Basic () where policyAcceptPeer _ _ = pure True policyAcceptMessage _ _ _ = pure True -data BasicPolicyAction = - Allow | Deny - deriving (Eq,Ord,Show,Generic) - -data BasicPolicy s = - BasicPolicy - { bpDefaulPeerAction :: BasicPolicyAction - , bpDefaultSenderAction :: BasicPolicyAction - , bpPeers :: HashMap (PubKey 'Sign s) BasicPolicyAction - , bpSenders :: HashMap (Sender s) BasicPolicyAction - } - deriving stock (Generic) - -instance ForMailbox s => IsAcceptPolicy s (BasicPolicy s) where - - policyAcceptPeer BasicPolicy{..} p = do - pure False - - policyAcceptMessage BasicPolicy{..} s m = do - pure False - -parseBasicPolicy :: forall s m . (s ~ HBS2Basic, ForMailbox s, MonadUnliftIO m) - => [Syntax C] - -> m (Maybe (BasicPolicy s)) - -parseBasicPolicy syn = do - - tpAction <- newTVarIO Deny - tsAction <- newTVarIO Deny - tpeers <- newTVarIO mempty - tsenders <- newTVarIO mempty - - for_ syn $ \case - ListVal [SymbolVal "peer", SymbolVal "allow", SymbolVal "all"] -> do - atomically $ writeTVar tpAction Allow - - ListVal [SymbolVal "peer", SymbolVal "deny", SymbolVal "all"] -> do - atomically $ writeTVar tpAction Deny - - ListVal [SymbolVal "peer", SymbolVal "allow", SignPubKeyLike who] -> do - atomically $ modifyTVar tpeers (HM.insert who Allow) - - ListVal [SymbolVal "peer", SymbolVal "deny", SignPubKeyLike who] -> do - atomically $ modifyTVar tpeers (HM.insert who Deny) - - ListVal [SymbolVal "sender", SymbolVal "allow", SymbolVal "all"] -> do - atomically $ writeTVar tsAction Allow - - ListVal [SymbolVal "sender", SymbolVal "deny", SymbolVal "all"] -> do - atomically $ writeTVar tsAction Deny - - ListVal [SymbolVal "sender", SymbolVal "allow", SignPubKeyLike who] -> do - atomically $ modifyTVar tsenders (HM.insert who Allow) - - ListVal [SymbolVal "sender", SymbolVal "deny", SignPubKeyLike who] -> do - atomically $ modifyTVar tsenders (HM.insert who Deny) - - _ -> pure () - - a <- readTVarIO tpAction - b <- readTVarIO tsAction - c <- readTVarIO tpeers - d <- readTVarIO tsenders - - pure $ Just $ BasicPolicy @s a b c d instance (s ~ HBS2Basic, e ~ L4Proto, s ~ Encryption e) => IsMailboxProtoAdapter s (MailboxProtoWorker s e) where @@ -990,4 +926,3 @@ instance FromField MailboxType where -- TODO: test-basic-policy - diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 6c7634f3..d865c8fa 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -168,6 +168,7 @@ library HBS2.Peer.Proto.Mailbox.Entry HBS2.Peer.Proto.Mailbox.Ref HBS2.Peer.Proto.Mailbox.Policy + HBS2.Peer.Proto.Mailbox.Policy.Basic HBS2.Peer.Proto.BrowserPlugin HBS2.Peer.RPC.Client diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy/Basic.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy/Basic.hs new file mode 100644 index 00000000..8e0796ec --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy/Basic.hs @@ -0,0 +1,117 @@ +{-# Language AllowAmbiguousTypes #-} +{-# Language UndecidableInstances #-} +module HBS2.Peer.Proto.Mailbox.Policy.Basic + ( module HBS2.Peer.Proto.Mailbox.Policy + , BasicPolicyAction(..) + , getAsSyntax + , parseBasicPolicy + , BasicPolicy(..) + ) where + +import HBS2.Prelude.Plated + +import HBS2.Base58 +import HBS2.Peer.Proto.Mailbox.Types +import HBS2.Peer.Proto.Mailbox.Policy +import HBS2.Net.Auth.Credentials + +import HBS2.System.Dir + +import Data.Config.Suckless.Script + +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.Maybe + +data BasicPolicyAction = + Allow | Deny + deriving (Eq,Ord,Show,Generic) + +data BasicPolicy s = + BasicPolicy + { bpDefaulPeerAction :: BasicPolicyAction + , bpDefaultSenderAction :: BasicPolicyAction + , bpPeers :: HashMap (PubKey 'Sign s) BasicPolicyAction + , bpSenders :: HashMap (Sender s) BasicPolicyAction + } + deriving stock (Generic) + +instance ForMailbox s => Pretty (BasicPolicy s) where + pretty w = pretty (getAsSyntax @C w) + +instance ForMailbox s => IsAcceptPolicy s (BasicPolicy s) where + + policyAcceptPeer BasicPolicy{..} p = do + pure $ Allow == fromMaybe bpDefaultSenderAction (HM.lookup p bpPeers) + + policyAcceptMessage BasicPolicy{..} s m = do + pure $ Allow == fromMaybe bpDefaultSenderAction (HM.lookup s bpSenders) + +getAsSyntax :: forall c s . (ForMailbox s, IsContext c) + => BasicPolicy s -> [Syntax c] +getAsSyntax BasicPolicy{..} = + [ defPeerAction + , defSenderAction + ] <> peerActions <> senderActions + where + defPeerAction = mkList [mkSym "peer", action bpDefaulPeerAction, mkSym "all"] + defSenderAction = mkList [mkSym "sender", action bpDefaulPeerAction, mkSym "all"] + + peerActions = [ mkList [mkSym "peer", action a, mkSym (show $ pretty (AsBase58 who))] + | (who, a) <- HM.toList bpPeers ] + + senderActions = [ mkList [mkSym "sender", action a, mkSym (show $ pretty (AsBase58 who))] + | (who, a) <- HM.toList bpSenders ] + + + action = \case + Allow -> mkSym "allow" + Deny -> mkSym "deny" + + +parseBasicPolicy :: forall s c m . (IsContext c, s ~ HBS2Basic, ForMailbox s, MonadUnliftIO m) + => [Syntax c] + -> m (Maybe (BasicPolicy s)) + +parseBasicPolicy syn = do + + tpAction <- newTVarIO Deny + tsAction <- newTVarIO Deny + tpeers <- newTVarIO mempty + tsenders <- newTVarIO mempty + + for_ syn $ \case + ListVal [SymbolVal "peer", SymbolVal "allow", SymbolVal "all"] -> do + atomically $ writeTVar tpAction Allow + + ListVal [SymbolVal "peer", SymbolVal "deny", SymbolVal "all"] -> do + atomically $ writeTVar tpAction Deny + + ListVal [SymbolVal "peer", SymbolVal "allow", SignPubKeyLike who] -> do + atomically $ modifyTVar tpeers (HM.insert who Allow) + + ListVal [SymbolVal "peer", SymbolVal "deny", SignPubKeyLike who] -> do + atomically $ modifyTVar tpeers (HM.insert who Deny) + + ListVal [SymbolVal "sender", SymbolVal "allow", SymbolVal "all"] -> do + atomically $ writeTVar tsAction Allow + + ListVal [SymbolVal "sender", SymbolVal "deny", SymbolVal "all"] -> do + atomically $ writeTVar tsAction Deny + + ListVal [SymbolVal "sender", SymbolVal "allow", SignPubKeyLike who] -> do + atomically $ modifyTVar tsenders (HM.insert who Allow) + + ListVal [SymbolVal "sender", SymbolVal "deny", SignPubKeyLike who] -> do + atomically $ modifyTVar tsenders (HM.insert who Deny) + + _ -> pure () + + a <- readTVarIO tpAction + b <- readTVarIO tsAction + c <- readTVarIO tpeers + d <- readTVarIO tsenders + + pure $ Just $ BasicPolicy @s a b c d + +