mirror of https://github.com/voidlizard/hbs2
wip, extracted BasicPolicy
This commit is contained in:
voidlizard
parent
599f1e9169
commit
f3ad2341a4
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue