{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Ecluse.Config.Rule (
RulePolicy (..),
emptyPolicy,
PolicyError (..),
renderPolicyError,
resolvePolicy,
RulePatch (..),
emptyPatch,
RuleEntry (..),
) where
import Data.Map.Strict qualified as Map
import Validation (eitherToValidation, validationToEither)
import Ecluse.Core.Package (mkScope)
import Ecluse.Core.Rules.Types (
PrecededRule (..),
Rule (..),
defaultPrecedence,
ruleName,
)
newtype RulePolicy = RulePolicy
{ RulePolicy -> Map Text PrecededRule
policyRules :: Map Text PrecededRule
}
deriving stock (RulePolicy -> RulePolicy -> Bool
(RulePolicy -> RulePolicy -> Bool)
-> (RulePolicy -> RulePolicy -> Bool) -> Eq RulePolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RulePolicy -> RulePolicy -> Bool
== :: RulePolicy -> RulePolicy -> Bool
$c/= :: RulePolicy -> RulePolicy -> Bool
/= :: RulePolicy -> RulePolicy -> Bool
Eq, Int -> RulePolicy -> ShowS
[RulePolicy] -> ShowS
RulePolicy -> String
(Int -> RulePolicy -> ShowS)
-> (RulePolicy -> String)
-> ([RulePolicy] -> ShowS)
-> Show RulePolicy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RulePolicy -> ShowS
showsPrec :: Int -> RulePolicy -> ShowS
$cshow :: RulePolicy -> String
show :: RulePolicy -> String
$cshowList :: [RulePolicy] -> ShowS
showList :: [RulePolicy] -> ShowS
Show)
emptyPolicy :: RulePolicy
emptyPolicy :: RulePolicy
emptyPolicy = Map Text PrecededRule -> RulePolicy
RulePolicy Map Text PrecededRule
forall k a. Map k a
Map.empty
data PolicyError
= MissingRuleType Text
| UnknownRuleType Text Text
| MalformedRule Text Text
| SuppressUnknownRule Text
deriving stock (PolicyError -> PolicyError -> Bool
(PolicyError -> PolicyError -> Bool)
-> (PolicyError -> PolicyError -> Bool) -> Eq PolicyError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PolicyError -> PolicyError -> Bool
== :: PolicyError -> PolicyError -> Bool
$c/= :: PolicyError -> PolicyError -> Bool
/= :: PolicyError -> PolicyError -> Bool
Eq, Int -> PolicyError -> ShowS
[PolicyError] -> ShowS
PolicyError -> String
(Int -> PolicyError -> ShowS)
-> (PolicyError -> String)
-> ([PolicyError] -> ShowS)
-> Show PolicyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PolicyError -> ShowS
showsPrec :: Int -> PolicyError -> ShowS
$cshow :: PolicyError -> String
show :: PolicyError -> String
$cshowList :: [PolicyError] -> ShowS
showList :: [PolicyError] -> ShowS
Show)
renderPolicyError :: PolicyError -> Text
renderPolicyError :: PolicyError -> Text
renderPolicyError = \case
MissingRuleType Text
name ->
Text
"rule " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
quote Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not a default and is missing its \"type\""
UnknownRuleType Text
name Text
ty ->
Text
"rule " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
quote Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" names unknown type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
quote Text
ty
MalformedRule Text
name Text
reason ->
Text
"rule " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
quote Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reason
SuppressUnknownRule Text
name ->
Text
"rule " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
quote Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" disables a rule that no default defines"
quote :: Text -> Text
quote :: Text -> Text
quote Text
t = Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
newtype RulePatch = RulePatch (Map Text RuleEntry)
deriving stock (RulePatch -> RulePatch -> Bool
(RulePatch -> RulePatch -> Bool)
-> (RulePatch -> RulePatch -> Bool) -> Eq RulePatch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RulePatch -> RulePatch -> Bool
== :: RulePatch -> RulePatch -> Bool
$c/= :: RulePatch -> RulePatch -> Bool
/= :: RulePatch -> RulePatch -> Bool
Eq, Int -> RulePatch -> ShowS
[RulePatch] -> ShowS
RulePatch -> String
(Int -> RulePatch -> ShowS)
-> (RulePatch -> String)
-> ([RulePatch] -> ShowS)
-> Show RulePatch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RulePatch -> ShowS
showsPrec :: Int -> RulePatch -> ShowS
$cshow :: RulePatch -> String
show :: RulePatch -> String
$cshowList :: [RulePatch] -> ShowS
showList :: [RulePatch] -> ShowS
Show)
emptyPatch :: RulePatch
emptyPatch :: RulePatch
emptyPatch = Map Text RuleEntry -> RulePatch
RulePatch Map Text RuleEntry
forall k a. Map k a
Map.empty
data RuleEntry = RuleEntry
{ RuleEntry -> Maybe Text
entryType :: Maybe Text
, RuleEntry -> Maybe Int
entryPrecedence :: Maybe Int
, RuleEntry -> Maybe Bool
entryEnabled :: Maybe Bool
, RuleEntry -> Maybe Integer
entryAgeSeconds :: Maybe Integer
, RuleEntry -> Maybe Text
entryScope :: Maybe Text
, RuleEntry -> Maybe Text
entryIdentity :: Maybe Text
}
deriving stock (RuleEntry -> RuleEntry -> Bool
(RuleEntry -> RuleEntry -> Bool)
-> (RuleEntry -> RuleEntry -> Bool) -> Eq RuleEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RuleEntry -> RuleEntry -> Bool
== :: RuleEntry -> RuleEntry -> Bool
$c/= :: RuleEntry -> RuleEntry -> Bool
/= :: RuleEntry -> RuleEntry -> Bool
Eq, Int -> RuleEntry -> ShowS
[RuleEntry] -> ShowS
RuleEntry -> String
(Int -> RuleEntry -> ShowS)
-> (RuleEntry -> String)
-> ([RuleEntry] -> ShowS)
-> Show RuleEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RuleEntry -> ShowS
showsPrec :: Int -> RuleEntry -> ShowS
$cshow :: RuleEntry -> String
show :: RuleEntry -> String
$cshowList :: [RuleEntry] -> ShowS
showList :: [RuleEntry] -> ShowS
Show)
resolvePolicy :: RulePolicy -> RulePatch -> Either [PolicyError] RulePolicy
resolvePolicy :: RulePolicy -> RulePatch -> Either [PolicyError] RulePolicy
resolvePolicy (RulePolicy Map Text PrecededRule
base) (RulePatch Map Text RuleEntry
patch) =
Validation [PolicyError] RulePolicy
-> Either [PolicyError] RulePolicy
forall e a. Validation e a -> Either e a
validationToEither (Validation [PolicyError] RulePolicy
-> Either [PolicyError] RulePolicy)
-> Validation [PolicyError] RulePolicy
-> Either [PolicyError] RulePolicy
forall a b. (a -> b) -> a -> b
$
Map Text PrecededRule -> RulePolicy
RulePolicy (Map Text PrecededRule -> RulePolicy)
-> ([(Text, Maybe PrecededRule)] -> Map Text PrecededRule)
-> [(Text, Maybe PrecededRule)]
-> RulePolicy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Text PrecededRule
-> (Text, Maybe PrecededRule) -> Map Text PrecededRule)
-> Map Text PrecededRule
-> [(Text, Maybe PrecededRule)]
-> Map Text PrecededRule
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map Text PrecededRule
-> (Text, Maybe PrecededRule) -> Map Text PrecededRule
applyResolvedEntry Map Text PrecededRule
base
([(Text, Maybe PrecededRule)] -> RulePolicy)
-> Validation [PolicyError] [(Text, Maybe PrecededRule)]
-> Validation [PolicyError] RulePolicy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, RuleEntry)
-> Validation [PolicyError] (Text, Maybe PrecededRule))
-> [(Text, RuleEntry)]
-> Validation [PolicyError] [(Text, Maybe PrecededRule)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Either [PolicyError] (Text, Maybe PrecededRule)
-> Validation [PolicyError] (Text, Maybe PrecededRule)
forall e a. Either e a -> Validation e a
eitherToValidation (Either [PolicyError] (Text, Maybe PrecededRule)
-> Validation [PolicyError] (Text, Maybe PrecededRule))
-> ((Text, RuleEntry)
-> Either [PolicyError] (Text, Maybe PrecededRule))
-> (Text, RuleEntry)
-> Validation [PolicyError] (Text, Maybe PrecededRule)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text PrecededRule
-> (Text, RuleEntry)
-> Either [PolicyError] (Text, Maybe PrecededRule)
resolveEntry Map Text PrecededRule
base) (Map Text RuleEntry -> [(Text, RuleEntry)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text RuleEntry
patch)
applyResolvedEntry :: Map Text PrecededRule -> (Text, Maybe PrecededRule) -> Map Text PrecededRule
applyResolvedEntry :: Map Text PrecededRule
-> (Text, Maybe PrecededRule) -> Map Text PrecededRule
applyResolvedEntry Map Text PrecededRule
acc (Text
name, Maybe PrecededRule
Nothing) = Text -> Map Text PrecededRule -> Map Text PrecededRule
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
name Map Text PrecededRule
acc
applyResolvedEntry Map Text PrecededRule
acc (Text
name, Just PrecededRule
pr) = Text
-> PrecededRule -> Map Text PrecededRule -> Map Text PrecededRule
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name PrecededRule
pr Map Text PrecededRule
acc
resolveEntry :: Map Text PrecededRule -> (Text, RuleEntry) -> Either [PolicyError] (Text, Maybe PrecededRule)
resolveEntry :: Map Text PrecededRule
-> (Text, RuleEntry)
-> Either [PolicyError] (Text, Maybe PrecededRule)
resolveEntry Map Text PrecededRule
base (Text
name, RuleEntry
entry)
| RuleEntry -> Maybe Bool
entryEnabled RuleEntry
entry Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False =
if Text -> Map Text PrecededRule -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Text
name Map Text PrecededRule
base
then (Text, Maybe PrecededRule)
-> Either [PolicyError] (Text, Maybe PrecededRule)
forall a b. b -> Either a b
Right (Text
name, Maybe PrecededRule
forall a. Maybe a
Nothing)
else [PolicyError] -> Either [PolicyError] (Text, Maybe PrecededRule)
forall a b. a -> Either a b
Left [Text -> PolicyError
SuppressUnknownRule Text
name]
| Bool
otherwise =
case Text -> Map Text PrecededRule -> Maybe PrecededRule
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text PrecededRule
base of
Just PrecededRule
existing -> (Text
name,) (Maybe PrecededRule -> (Text, Maybe PrecededRule))
-> (PrecededRule -> Maybe PrecededRule)
-> PrecededRule
-> (Text, Maybe PrecededRule)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecededRule -> Maybe PrecededRule
forall a. a -> Maybe a
Just (PrecededRule -> (Text, Maybe PrecededRule))
-> Either [PolicyError] PrecededRule
-> Either [PolicyError] (Text, Maybe PrecededRule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> RuleEntry -> PrecededRule -> Either [PolicyError] PrecededRule
patchExistingRule Text
name RuleEntry
entry PrecededRule
existing
Maybe PrecededRule
Nothing -> (Text
name,) (Maybe PrecededRule -> (Text, Maybe PrecededRule))
-> (PrecededRule -> Maybe PrecededRule)
-> PrecededRule
-> (Text, Maybe PrecededRule)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecededRule -> Maybe PrecededRule
forall a. a -> Maybe a
Just (PrecededRule -> (Text, Maybe PrecededRule))
-> Either [PolicyError] PrecededRule
-> Either [PolicyError] (Text, Maybe PrecededRule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> RuleEntry -> Either [PolicyError] PrecededRule
addNewRule Text
name RuleEntry
entry
patchExistingRule :: Text -> RuleEntry -> PrecededRule -> Either [PolicyError] PrecededRule
patchExistingRule :: Text
-> RuleEntry -> PrecededRule -> Either [PolicyError] PrecededRule
patchExistingRule Text
name RuleEntry
entry (PrecededRule Int
prec Rule
rule) = do
rule' <- Text -> RuleEntry -> Rule -> Either [PolicyError] Rule
patchRuleValue Text
name RuleEntry
entry Rule
rule
pure (PrecededRule (fromMaybe prec (entryPrecedence entry)) rule')
addNewRule :: Text -> RuleEntry -> Either [PolicyError] PrecededRule
addNewRule :: Text -> RuleEntry -> Either [PolicyError] PrecededRule
addNewRule Text
name RuleEntry
entry = case RuleEntry -> Maybe Text
entryType RuleEntry
entry of
Maybe Text
Nothing -> [PolicyError] -> Either [PolicyError] PrecededRule
forall a b. a -> Either a b
Left [Text -> PolicyError
MissingRuleType Text
name]
Just Text
ty -> do
rule <- Text -> Text -> RuleEntry -> Either [PolicyError] Rule
buildRule Text
name Text
ty RuleEntry
entry
pure (PrecededRule (fromMaybe (defaultPrecedence rule) (entryPrecedence entry)) rule)
buildRule :: Text -> Text -> RuleEntry -> Either [PolicyError] Rule
buildRule :: Text -> Text -> RuleEntry -> Either [PolicyError] Rule
buildRule Text
name Text
ty RuleEntry
entry = case Text
ty of
Text
"AllowIfOlderThan" -> case RuleEntry -> Maybe Integer
entryAgeSeconds RuleEntry
entry of
Just Integer
secs
| Integer
secs Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 -> Rule -> Either [PolicyError] Rule
forall a b. b -> Either a b
Right (NominalDiffTime -> Rule
AllowIfOlderThan (Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger Integer
secs))
| Bool
otherwise -> [PolicyError] -> Either [PolicyError] Rule
forall a b. a -> Either a b
Left [Text -> Text -> PolicyError
MalformedRule Text
name Text
"\"ageSeconds\" must be non-negative"]
Maybe Integer
Nothing -> [PolicyError] -> Either [PolicyError] Rule
forall a b. a -> Either a b
Left [Text -> Text -> PolicyError
MalformedRule Text
name Text
"\"AllowIfOlderThan\" requires \"ageSeconds\""]
Text
"AllowScope" -> case RuleEntry -> Maybe Text
entryScope RuleEntry
entry of
Just Text
scope -> Rule -> Either [PolicyError] Rule
forall a b. b -> Either a b
Right (Scope -> Rule
AllowScope (Text -> Scope
mkScope Text
scope))
Maybe Text
Nothing -> [PolicyError] -> Either [PolicyError] Rule
forall a b. a -> Either a b
Left [Text -> Text -> PolicyError
MalformedRule Text
name Text
"\"AllowScope\" requires \"scope\""]
Text
"DenyByIdentity" -> case RuleEntry -> Maybe Text
entryIdentity RuleEntry
entry of
Just Text
ident -> Rule -> Either [PolicyError] Rule
forall a b. b -> Either a b
Right (Text -> Rule
DenyByIdentity Text
ident)
Maybe Text
Nothing -> [PolicyError] -> Either [PolicyError] Rule
forall a b. a -> Either a b
Left [Text -> Text -> PolicyError
MalformedRule Text
name Text
"\"DenyByIdentity\" requires \"identity\""]
Text
"AllowByIdentity" -> case RuleEntry -> Maybe Text
entryIdentity RuleEntry
entry of
Just Text
ident -> Rule -> Either [PolicyError] Rule
forall a b. b -> Either a b
Right (Text -> Rule
AllowByIdentity Text
ident)
Maybe Text
Nothing -> [PolicyError] -> Either [PolicyError] Rule
forall a b. a -> Either a b
Left [Text -> Text -> PolicyError
MalformedRule Text
name Text
"\"AllowByIdentity\" requires \"identity\""]
Text
"AllowIfRemediatesCve" -> Rule -> Either [PolicyError] Rule
forall a b. b -> Either a b
Right Rule
AllowIfRemediatesCve
Text
"DenyInstallTimeExecution" -> Rule -> Either [PolicyError] Rule
forall a b. b -> Either a b
Right Rule
DenyInstallTimeExecution
Text
_ -> [PolicyError] -> Either [PolicyError] Rule
forall a b. a -> Either a b
Left [Text -> Text -> PolicyError
UnknownRuleType Text
name Text
ty]
patchRuleValue :: Text -> RuleEntry -> Rule -> Either [PolicyError] Rule
patchRuleValue :: Text -> RuleEntry -> Rule -> Either [PolicyError] Rule
patchRuleValue Text
name RuleEntry
entry Rule
rule = do
() <- Text -> RuleEntry -> Rule -> Either [PolicyError] ()
checkRestatedType Text
name RuleEntry
entry Rule
rule
case rule of
AllowIfOlderThan NominalDiffTime
d -> case RuleEntry -> Maybe Integer
entryAgeSeconds RuleEntry
entry of
Just Integer
secs
| Integer
secs Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 -> Rule -> Either [PolicyError] Rule
forall a b. b -> Either a b
Right (NominalDiffTime -> Rule
AllowIfOlderThan (Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger Integer
secs))
| Bool
otherwise -> [PolicyError] -> Either [PolicyError] Rule
forall a b. a -> Either a b
Left [Text -> Text -> PolicyError
MalformedRule Text
name Text
"\"ageSeconds\" must be non-negative"]
Maybe Integer
Nothing -> Rule -> Either [PolicyError] Rule
forall a b. b -> Either a b
Right (NominalDiffTime -> Rule
AllowIfOlderThan NominalDiffTime
d)
AllowScope Scope
s -> Rule -> Either [PolicyError] Rule
forall a b. b -> Either a b
Right (Scope -> Rule
AllowScope (Scope -> (Text -> Scope) -> Maybe Text -> Scope
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Scope
s Text -> Scope
mkScope (RuleEntry -> Maybe Text
entryScope RuleEntry
entry)))
DenyByIdentity Text
i -> Rule -> Either [PolicyError] Rule
forall a b. b -> Either a b
Right (Text -> Rule
DenyByIdentity (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
i (RuleEntry -> Maybe Text
entryIdentity RuleEntry
entry)))
AllowByIdentity Text
i -> Rule -> Either [PolicyError] Rule
forall a b. b -> Either a b
Right (Text -> Rule
AllowByIdentity (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
i (RuleEntry -> Maybe Text
entryIdentity RuleEntry
entry)))
Rule
AllowIfRemediatesCve -> Rule -> Either [PolicyError] Rule
forall a b. b -> Either a b
Right Rule
AllowIfRemediatesCve
Rule
DenyInstallTimeExecution -> Rule -> Either [PolicyError] Rule
forall a b. b -> Either a b
Right Rule
DenyInstallTimeExecution
checkRestatedType :: Text -> RuleEntry -> Rule -> Either [PolicyError] ()
checkRestatedType :: Text -> RuleEntry -> Rule -> Either [PolicyError] ()
checkRestatedType Text
name RuleEntry
entry Rule
rule = case RuleEntry -> Maybe Text
entryType RuleEntry
entry of
Maybe Text
Nothing -> () -> Either [PolicyError] ()
forall a b. b -> Either a b
Right ()
Just Text
ty
| Text
ty Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Rule -> Text
ruleName Rule
rule -> () -> Either [PolicyError] ()
forall a b. b -> Either a b
Right ()
| Text
ty Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Text]
knownRuleTypes -> [PolicyError] -> Either [PolicyError] ()
forall a b. a -> Either a b
Left [Text -> Text -> PolicyError
MalformedRule Text
name (Text
"\"type\" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
quote Text
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" does not match the default rule it patches")]
| Bool
otherwise -> [PolicyError] -> Either [PolicyError] ()
forall a b. a -> Either a b
Left [Text -> Text -> PolicyError
UnknownRuleType Text
name Text
ty]
knownRuleTypes :: [Text]
knownRuleTypes :: [Text]
knownRuleTypes =
[ Text
"AllowScope"
, Text
"AllowIfOlderThan"
, Text
"AllowByIdentity"
, Text
"AllowIfRemediatesCve"
, Text
"DenyInstallTimeExecution"
, Text
"DenyByIdentity"
]