mirror of https://github.com/voidlizard/hbs2
126 lines
3.9 KiB
Haskell
126 lines
3.9 KiB
Haskell
{-# Language AllowAmbiguousTypes #-}
|
|
{-# Language UndecidableInstances #-}
|
|
module HBS2.Peer.Proto.Mailbox.Policy.Basic
|
|
( module HBS2.Peer.Proto.Mailbox.Policy
|
|
, BasicPolicyAction(..)
|
|
, getAsSyntax
|
|
, parseBasicPolicy
|
|
, defaultBasicPolicy
|
|
, 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
|
|
{ bpDefaultPeerAction :: BasicPolicyAction
|
|
, bpDefaultSenderAction :: BasicPolicyAction
|
|
, bpPeers :: HashMap (PubKey 'Sign s) BasicPolicyAction
|
|
, bpSenders :: HashMap (Sender s) BasicPolicyAction
|
|
}
|
|
deriving stock (Generic,Typeable)
|
|
|
|
deriving stock instance ForMailbox s => Eq (BasicPolicy s)
|
|
|
|
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 bpDefaultPeerAction (HM.lookup p bpPeers)
|
|
|
|
policyAcceptSender BasicPolicy{..} p = do
|
|
pure $ Allow == fromMaybe bpDefaultSenderAction (HM.lookup p bpSenders)
|
|
|
|
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 bpDefaultPeerAction, mkSym "all"]
|
|
defSenderAction = mkList [mkSym "sender", action bpDefaultSenderAction, 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"
|
|
|
|
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]
|
|
-> 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
|
|
|
|
|