-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module Ecluse.Config.Rule (
    RulePolicy (..),
    emptyPolicy,
    PolicyError (..),
    renderPolicyError,
    knownRuleTypes,
    resolvePolicy,
    RulePatch (..),
    RuleEntry (..),
) where

import Data.Map.Strict qualified as Map
import Data.Time (NominalDiffTime)
import Validation (eitherToValidation, validationToEither)

import Ecluse.Core.Package (mkScope)
import Ecluse.Core.Rules.Types (
    DenyIfCveParams (..),
    FailureAlignment (..),
    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)

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
    , RuleEntry -> Maybe Double
entryMinSeverity :: Maybe Double
    , RuleEntry -> Maybe Text
entryOnUnavailable :: 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" ->
        NominalDiffTime -> Rule
AllowIfOlderThan
            (NominalDiffTime -> Rule)
-> Either [PolicyError] NominalDiffTime
-> Either [PolicyError] Rule
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> Text
-> Text
-> (Integer -> Either [PolicyError] NominalDiffTime)
-> Maybe Integer
-> Either [PolicyError] NominalDiffTime
forall a b.
Text
-> Text
-> Text
-> (a -> Either [PolicyError] b)
-> Maybe a
-> Either [PolicyError] b
requireField Text
name Text
"AllowIfOlderThan" Text
"ageSeconds" (Text -> Integer -> Either [PolicyError] NominalDiffTime
validateAgeSeconds Text
name) (RuleEntry -> Maybe Integer
entryAgeSeconds RuleEntry
entry)
    Text
"AllowScope" ->
        Scope -> Rule
AllowScope (Scope -> Rule) -> (Text -> Scope) -> Text -> Rule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Scope
mkScope (Text -> Rule)
-> Either [PolicyError] Text -> Either [PolicyError] Rule
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> Text
-> Text
-> (Text -> Either [PolicyError] Text)
-> Maybe Text
-> Either [PolicyError] Text
forall a b.
Text
-> Text
-> Text
-> (a -> Either [PolicyError] b)
-> Maybe a
-> Either [PolicyError] b
requireField Text
name Text
"AllowScope" Text
"scope" Text -> Either [PolicyError] Text
forall a b. b -> Either a b
Right (RuleEntry -> Maybe Text
entryScope RuleEntry
entry)
    Text
"DenyByIdentity" ->
        Text -> Rule
DenyByIdentity (Text -> Rule)
-> Either [PolicyError] Text -> Either [PolicyError] Rule
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> Text
-> Text
-> (Text -> Either [PolicyError] Text)
-> Maybe Text
-> Either [PolicyError] Text
forall a b.
Text
-> Text
-> Text
-> (a -> Either [PolicyError] b)
-> Maybe a
-> Either [PolicyError] b
requireField Text
name Text
"DenyByIdentity" Text
"identity" Text -> Either [PolicyError] Text
forall a b. b -> Either a b
Right (RuleEntry -> Maybe Text
entryIdentity RuleEntry
entry)
    Text
"AllowByIdentity" ->
        Text -> Rule
AllowByIdentity (Text -> Rule)
-> Either [PolicyError] Text -> Either [PolicyError] Rule
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> Text
-> Text
-> (Text -> Either [PolicyError] Text)
-> Maybe Text
-> Either [PolicyError] Text
forall a b.
Text
-> Text
-> Text
-> (a -> Either [PolicyError] b)
-> Maybe a
-> Either [PolicyError] b
requireField Text
name Text
"AllowByIdentity" Text
"identity" Text -> Either [PolicyError] Text
forall a b. b -> Either a b
Right (RuleEntry -> Maybe Text
entryIdentity RuleEntry
entry)
    Text
"AllowIfRemediatesCve" -> Rule -> Either [PolicyError] Rule
forall a b. b -> Either a b
Right Rule
AllowIfRemediatesCve
    Text
"DenyIfCve" -> DenyIfCveParams -> Rule
DenyIfCve (DenyIfCveParams -> Rule)
-> Either [PolicyError] DenyIfCveParams
-> Either [PolicyError] Rule
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> RuleEntry -> Either [PolicyError] DenyIfCveParams
buildDenyIfCveParams Text
name RuleEntry
entry
    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]

{- | Extract a rule type's required field, running @validate@ on it, or report the
type is missing it (@"<ruleType>" requires "<field>"@). Unifies the required-field
decode across every builder that has one.
-}
requireField :: Text -> Text -> Text -> (a -> Either [PolicyError] b) -> Maybe a -> Either [PolicyError] b
requireField :: forall a b.
Text
-> Text
-> Text
-> (a -> Either [PolicyError] b)
-> Maybe a
-> Either [PolicyError] b
requireField Text
name Text
ruleType Text
field =
    Either [PolicyError] b
-> (a -> Either [PolicyError] b)
-> Maybe a
-> Either [PolicyError] b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([PolicyError] -> Either [PolicyError] b
forall a b. a -> Either a b
Left [Text -> Text -> PolicyError
MalformedRule Text
name (Text -> Text
quote Text
ruleType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" requires " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
quote Text
field)])

-- Validate a publish-age threshold: a non-negative number of seconds.
validateAgeSeconds :: Text -> Integer -> Either [PolicyError] NominalDiffTime
validateAgeSeconds :: Text -> Integer -> Either [PolicyError] NominalDiffTime
validateAgeSeconds Text
name Integer
secs
    | Integer
secs Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 = NominalDiffTime -> Either [PolicyError] NominalDiffTime
forall a b. b -> Either a b
Right (Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger Integer
secs)
    | Bool
otherwise = [PolicyError] -> Either [PolicyError] NominalDiffTime
forall a b. a -> Either a b
Left [Text -> Text -> PolicyError
MalformedRule Text
name Text
"\"ageSeconds\" must be non-negative"]

-- Validate a CVSS severity threshold: a base score in the range [0, 10].
validateMinSeverity :: Text -> Double -> Either [PolicyError] Double
validateMinSeverity :: Text -> Double -> Either [PolicyError] Double
validateMinSeverity Text
name Double
s
    | Double
s Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 Bool -> Bool -> Bool
&& Double
s Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
10 = Double -> Either [PolicyError] Double
forall a b. b -> Either a b
Right Double
s
    | Bool
otherwise = [PolicyError] -> Either [PolicyError] Double
forall a b. a -> Either a b
Left [Text -> Text -> PolicyError
MalformedRule Text
name Text
"\"minSeverity\" must be a CVSS score between 0 and 10"]

{- | Decode 'DenyIfCve''s parameters. @minSeverity@ (a CVSS base score, 0 to 10)
is required, so an operator states the threshold consciously. @onUnavailable@ is
optional and defaults to @deny@ (fail-closed): a package the advisory database
cannot vet is refused rather than admitted.
-}
buildDenyIfCveParams :: Text -> RuleEntry -> Either [PolicyError] DenyIfCveParams
buildDenyIfCveParams :: Text -> RuleEntry -> Either [PolicyError] DenyIfCveParams
buildDenyIfCveParams Text
name RuleEntry
entry =
    Double -> FailureAlignment -> DenyIfCveParams
DenyIfCveParams
        (Double -> FailureAlignment -> DenyIfCveParams)
-> Either [PolicyError] Double
-> Either [PolicyError] (FailureAlignment -> DenyIfCveParams)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> Text
-> Text
-> (Double -> Either [PolicyError] Double)
-> Maybe Double
-> Either [PolicyError] Double
forall a b.
Text
-> Text
-> Text
-> (a -> Either [PolicyError] b)
-> Maybe a
-> Either [PolicyError] b
requireField Text
name Text
"DenyIfCve" Text
"minSeverity" (Text -> Double -> Either [PolicyError] Double
validateMinSeverity Text
name) (RuleEntry -> Maybe Double
entryMinSeverity RuleEntry
entry)
        Either [PolicyError] (FailureAlignment -> DenyIfCveParams)
-> Either [PolicyError] FailureAlignment
-> Either [PolicyError] DenyIfCveParams
forall a b.
Either [PolicyError] (a -> b)
-> Either [PolicyError] a -> Either [PolicyError] b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Maybe Text -> Either [PolicyError] FailureAlignment
parseOnUnavailable Text
name (RuleEntry -> Maybe Text
entryOnUnavailable RuleEntry
entry)

-- Decode the @onUnavailable@ policy: how the rule resolves when the advisory
-- database cannot answer. Absent defaults to fail-closed.
parseOnUnavailable :: Text -> Maybe Text -> Either [PolicyError] FailureAlignment
parseOnUnavailable :: Text -> Maybe Text -> Either [PolicyError] FailureAlignment
parseOnUnavailable Text
name = \case
    Maybe Text
Nothing -> FailureAlignment -> Either [PolicyError] FailureAlignment
forall a b. b -> Either a b
Right FailureAlignment
FailDeny
    Just Text
"deny" -> FailureAlignment -> Either [PolicyError] FailureAlignment
forall a b. b -> Either a b
Right FailureAlignment
FailDeny
    Just Text
"skip" -> FailureAlignment -> Either [PolicyError] FailureAlignment
forall a b. b -> Either a b
Right FailureAlignment
FailNoDecision
    Just Text
other -> [PolicyError] -> Either [PolicyError] FailureAlignment
forall a b. a -> Either a b
Left [Text -> Text -> PolicyError
MalformedRule Text
name (Text
"\"onUnavailable\" must be \"deny\" or \"skip\", not " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
quote Text
other)]

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 ->
            NominalDiffTime -> Rule
AllowIfOlderThan (NominalDiffTime -> Rule)
-> Either [PolicyError] NominalDiffTime
-> Either [PolicyError] Rule
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either [PolicyError] NominalDiffTime
-> (Integer -> Either [PolicyError] NominalDiffTime)
-> Maybe Integer
-> Either [PolicyError] NominalDiffTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NominalDiffTime -> Either [PolicyError] NominalDiffTime
forall a b. b -> Either a b
Right NominalDiffTime
d) (Text -> Integer -> Either [PolicyError] NominalDiffTime
validateAgeSeconds Text
name) (RuleEntry -> Maybe Integer
entryAgeSeconds RuleEntry
entry)
        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
        DenyIfCve DenyIfCveParams
params ->
            (DenyIfCveParams -> Rule)
-> Either [PolicyError] DenyIfCveParams
-> Either [PolicyError] Rule
forall a b.
(a -> b) -> Either [PolicyError] a -> Either [PolicyError] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DenyIfCveParams -> Rule
DenyIfCve (Either [PolicyError] DenyIfCveParams -> Either [PolicyError] Rule)
-> Either [PolicyError] DenyIfCveParams
-> Either [PolicyError] Rule
forall a b. (a -> b) -> a -> b
$
                Double -> FailureAlignment -> DenyIfCveParams
DenyIfCveParams
                    (Double -> FailureAlignment -> DenyIfCveParams)
-> Either [PolicyError] Double
-> Either [PolicyError] (FailureAlignment -> DenyIfCveParams)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either [PolicyError] Double
-> (Double -> Either [PolicyError] Double)
-> Maybe Double
-> Either [PolicyError] Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Double -> Either [PolicyError] Double
forall a b. b -> Either a b
Right (DenyIfCveParams -> Double
dicMinSeverity DenyIfCveParams
params)) (Text -> Double -> Either [PolicyError] Double
validateMinSeverity Text
name) (RuleEntry -> Maybe Double
entryMinSeverity RuleEntry
entry)
                    Either [PolicyError] (FailureAlignment -> DenyIfCveParams)
-> Either [PolicyError] FailureAlignment
-> Either [PolicyError] DenyIfCveParams
forall a b.
Either [PolicyError] (a -> b)
-> Either [PolicyError] a -> Either [PolicyError] b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either [PolicyError] FailureAlignment
-> (Text -> Either [PolicyError] FailureAlignment)
-> Maybe Text
-> Either [PolicyError] FailureAlignment
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FailureAlignment -> Either [PolicyError] FailureAlignment
forall a b. b -> Either a b
Right (DenyIfCveParams -> FailureAlignment
dicOnUnavailable DenyIfCveParams
params)) (Text -> Maybe Text -> Either [PolicyError] FailureAlignment
parseOnUnavailable Text
name (Maybe Text -> Either [PolicyError] FailureAlignment)
-> (Text -> Maybe Text)
-> Text
-> Either [PolicyError] FailureAlignment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just) (RuleEntry -> Maybe Text
entryOnUnavailable RuleEntry
entry)
        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]

{- | The rule type names the diagnostics recognise: the vocabulary
'checkRestatedType' treats as a real-but-mismatched type (a 'MalformedRule')
rather than an unknown one (an 'UnknownRuleType'). Exported so a test can pin it
against drift from the 'Ecluse.Core.Rules.Types.Rule' constructors, their
'buildRule' branches, and 'Ecluse.Core.Rules.Types.ruleName'.
-}
knownRuleTypes :: [Text]
knownRuleTypes :: [Text]
knownRuleTypes =
    [ Text
"AllowScope"
    , Text
"AllowIfOlderThan"
    , Text
"AllowByIdentity"
    , Text
"AllowIfRemediatesCve"
    , Text
"DenyIfCve"
    , Text
"DenyInstallTimeExecution"
    , Text
"DenyByIdentity"
    ]