-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT

{- | Read one synced advisory artifact through a pinned lookup capability.
Package keys are canonical per ecosystem.
-}
module Ecluse.Core.Cve (
    -- * The opened artifact
    CveDb (..),
    openCveDb,
    CveDbRejected (..),

    -- * The consumer view
    CveLookup (..),
    AdvisoryRange (..),
    CveQueryFault (..),

    -- * Pure range matching
    PackageAdvisories,
    packageAdvisories,
    keepAdvisories,
    affecting,
    fixedAt,
    MissingScorePolicy (..),
    scoreAtLeast,
) where

import Data.Map.Strict qualified as Map
import UnliftIO.Exception (catch, catchAny, onException, throwIO)

import Ecluse.Core.Cve.Internal (AdvisoryRange (..), CveDbRejected (..), advisoriesQuery, coveredNamesQuery, openHardenedConnection, provenanceQuery)
import Ecluse.Core.Ecosystem (Ecosystem)
import Ecluse.Core.Osv.Provenance (AdvisoryProvenance, decodeProvenance)
import Ecluse.Core.Osv.Schema (EpssRequirement)
import Ecluse.Core.Osv.Types (UpperBound (..))
import Ecluse.Core.Version (Version, VersionKey, parseVersionKey, renderVersion, versionKeyIn)

import Database.SQLite.Simple (Connection, SQLError, close)

{- | Query canonical package keys, with npm scopes inline, and raw version strings.
Display names must not be used as query keys.
-}
data CveLookup = CveLookup
    { CveLookup -> Text -> IO [AdvisoryRange]
cveAdvisoriesFor :: Text -> IO [AdvisoryRange]
    {- ^ Every advisory range recorded against a package name, for a rule predicate to read.
    Throws the confined 'CveQueryFault' on a query fault, as every field here does.
    -}
    , CveLookup -> IO [Text]
cveCoveredNames :: IO [Text]
    -- ^ Every package name this generation records an advisory against, for a store sweep.
    }

-- | A database query fault for the rule's resilience policy to classify.
data CveQueryFault = CveQueryFault
    { CveQueryFault -> Text
cqfQuery :: Text
    -- ^ Which handle field was asked (@advisories-for@ or @covered-names@).
    , CveQueryFault -> Text
cqfDetail :: Text
    -- ^ The rendered 'SQLError', for the operator's outage report. Never parsed.
    }
    deriving stock (CveQueryFault -> CveQueryFault -> Bool
(CveQueryFault -> CveQueryFault -> Bool)
-> (CveQueryFault -> CveQueryFault -> Bool) -> Eq CveQueryFault
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CveQueryFault -> CveQueryFault -> Bool
== :: CveQueryFault -> CveQueryFault -> Bool
$c/= :: CveQueryFault -> CveQueryFault -> Bool
/= :: CveQueryFault -> CveQueryFault -> Bool
Eq, Int -> CveQueryFault -> ShowS
[CveQueryFault] -> ShowS
CveQueryFault -> String
(Int -> CveQueryFault -> ShowS)
-> (CveQueryFault -> String)
-> ([CveQueryFault] -> ShowS)
-> Show CveQueryFault
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CveQueryFault -> ShowS
showsPrec :: Int -> CveQueryFault -> ShowS
$cshow :: CveQueryFault -> String
show :: CveQueryFault -> String
$cshowList :: [CveQueryFault] -> ShowS
showList :: [CveQueryFault] -> ShowS
Show)

instance Exception CveQueryFault

{- | One opened artifact: the consumer view plus the owner's close. Whoever holds
this owns the connection's lifetime. Hand a consumer 'cveDbLookup' only.
-}
data CveDb = CveDb
    { CveDb -> CveLookup
cveDbLookup :: CveLookup
    -- ^ The view consumers query through.
    , CveDb -> IO ()
cveDbClose :: IO ()
    {- ^ Release the connection. Owner-only, and __never throws__, since the connection is
    going away either way.
    -}
    , CveDb -> [(Text, Text)]
cveDbMeta :: [(Text, Text)]
    -- ^ The artifact's @meta@ provenance rows, snapshotted at open and key-sorted for the audit trail.
    , CveDb -> AdvisoryProvenance
cveDbProvenance :: AdvisoryProvenance
    {- ^ What the artifact records about the sources it was compiled from. An artifact written
    before those keys decodes as absence.
    -}
    }

-- | Reject incompatible artifacts as values. Opening faults leave no connection behind.
openCveDb :: Ecosystem -> EpssRequirement -> FilePath -> IO (Either CveDbRejected CveDb)
openCveDb :: Ecosystem
-> EpssRequirement -> String -> IO (Either CveDbRejected CveDb)
openCveDb Ecosystem
eco EpssRequirement
epssRequirement String
dbFile =
    Ecosystem
-> EpssRequirement
-> String
-> IO (Either CveDbRejected Connection)
openHardenedConnection Ecosystem
eco EpssRequirement
epssRequirement String
dbFile IO (Either CveDbRejected Connection)
-> (Either CveDbRejected Connection
    -> IO (Either CveDbRejected CveDb))
-> IO (Either CveDbRejected CveDb)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left CveDbRejected
rejection -> Either CveDbRejected CveDb -> IO (Either CveDbRejected CveDb)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CveDbRejected -> Either CveDbRejected CveDb
forall a b. a -> Either a b
Left CveDbRejected
rejection)
        Right Connection
conn -> do
            -- No-leak backstop for a fault below the artifact contract. Acceptance already made the
            -- provenance decode itself total.
            meta <- Connection -> IO [(Text, Text)]
provenanceQuery Connection
conn IO [(Text, Text)] -> IO () -> IO [(Text, Text)]
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`onException` Connection -> IO ()
close Connection
conn
            pure (Right (mkCveDb conn meta))

mkCveDb :: Connection -> [(Text, Text)] -> CveDb
mkCveDb :: Connection -> [(Text, Text)] -> CveDb
mkCveDb Connection
conn [(Text, Text)]
meta =
    CveDb
        { cveDbLookup :: CveLookup
cveDbLookup =
            CveLookup
                { cveAdvisoriesFor :: Text -> IO [AdvisoryRange]
cveAdvisoriesFor = Text -> IO [AdvisoryRange] -> IO [AdvisoryRange]
forall a. Text -> IO a -> IO a
taggedQuery Text
"advisories-for" (IO [AdvisoryRange] -> IO [AdvisoryRange])
-> (Text -> IO [AdvisoryRange]) -> Text -> IO [AdvisoryRange]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> Text -> IO [AdvisoryRange]
advisoriesQuery Connection
conn
                , cveCoveredNames :: IO [Text]
cveCoveredNames = Text -> IO [Text] -> IO [Text]
forall a. Text -> IO a -> IO a
taggedQuery Text
"covered-names" (Connection -> IO [Text]
coveredNamesQuery Connection
conn)
                }
        , cveDbClose :: IO ()
cveDbClose = Connection -> IO ()
close Connection
conn IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` IO () -> SomeException -> IO ()
forall a b. a -> b -> a
const IO ()
forall (f :: * -> *). Applicative f => f ()
pass
        , cveDbMeta :: [(Text, Text)]
cveDbMeta = [(Text, Text)]
meta
        , cveDbProvenance :: AdvisoryProvenance
cveDbProvenance = [(Text, Text)] -> AdvisoryProvenance
decodeProvenance [(Text, Text)]
meta
        }

-- The SQLite edge: the driver's 'SQLError' never escapes the handle, only this module's
-- confined 'CveQueryFault'.
taggedQuery :: Text -> IO a -> IO a
taggedQuery :: forall a. Text -> IO a -> IO a
taggedQuery Text
tag IO a
act = IO a
act IO a -> (SQLError -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SQLError
err :: SQLError) -> CveQueryFault -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Text -> Text -> CveQueryFault
CveQueryFault Text
tag (SQLError -> Text
forall b a. (Show a, IsString b) => a -> b
show SQLError
err))

{- | One package's advisory segments, each with its bounds parsed once under the package's
ecosystem, so every version of the package tests against ordering keys.
-}
data PackageAdvisories = PackageAdvisories
    { PackageAdvisories -> Ecosystem
paEcosystem :: Ecosystem
    , PackageAdvisories -> [Segment]
paSegments :: [Segment]
    , -- Lazy: only the remediation rule reads it, so a deny rule's filtered copy never builds it.
      PackageAdvisories -> Map Text [AdvisoryRange]
paFixes :: ~(Map Text [AdvisoryRange])
    }

-- One advisory row and the bounds matching reads from it.
data Segment = Segment
    { Segment -> AdvisoryRange
segRange :: AdvisoryRange
    , -- Lazy: parsed when a version is first matched, so a request that matches none parses nothing.
      Segment -> SegmentBounds
segBounds :: ~SegmentBounds
    }

-- A bound the grammar cannot parse is no bound, so no version can be shown to be outside it.
data SegmentBounds
    = -- A point whose one string the grammar rejects, matched as text.
      OnlyText Text
    | -- The inclusive lower bound and the upper bound.
      Ordered (Maybe VersionKey) UpperKey

data UpperKey = Below VersionKey | AtMost VersionKey | NoUpper

-- | Parse every segment's bounds at most once, under the package's ecosystem.
packageAdvisories :: Ecosystem -> [AdvisoryRange] -> PackageAdvisories
packageAdvisories :: Ecosystem -> [AdvisoryRange] -> PackageAdvisories
packageAdvisories Ecosystem
eco = Ecosystem -> [Segment] -> PackageAdvisories
fromSegments Ecosystem
eco ([Segment] -> PackageAdvisories)
-> ([AdvisoryRange] -> [Segment])
-> [AdvisoryRange]
-> PackageAdvisories
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AdvisoryRange -> Segment) -> [AdvisoryRange] -> [Segment]
forall a b. (a -> b) -> [a] -> [b]
map (\AdvisoryRange
ar -> AdvisoryRange -> SegmentBounds -> Segment
Segment AdvisoryRange
ar (Ecosystem -> AdvisoryRange -> SegmentBounds
segmentBounds Ecosystem
eco AdvisoryRange
ar))

-- | Keep only the segments whose row passes the test.
keepAdvisories :: (AdvisoryRange -> Bool) -> PackageAdvisories -> PackageAdvisories
keepAdvisories :: (AdvisoryRange -> Bool) -> PackageAdvisories -> PackageAdvisories
keepAdvisories AdvisoryRange -> Bool
keep PackageAdvisories
advisories = Ecosystem -> [Segment] -> PackageAdvisories
fromSegments (PackageAdvisories -> Ecosystem
paEcosystem PackageAdvisories
advisories) ((Segment -> Bool) -> [Segment] -> [Segment]
forall a. (a -> Bool) -> [a] -> [a]
filter (AdvisoryRange -> Bool
keep (AdvisoryRange -> Bool)
-> (Segment -> AdvisoryRange) -> Segment -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Segment -> AdvisoryRange
segRange) (PackageAdvisories -> [Segment]
paSegments PackageAdvisories
advisories))

-- The fixes index keeps row order within each fixed version.
fromSegments :: Ecosystem -> [Segment] -> PackageAdvisories
fromSegments :: Ecosystem -> [Segment] -> PackageAdvisories
fromSegments Ecosystem
eco [Segment]
segments =
    PackageAdvisories
        { paEcosystem :: Ecosystem
paEcosystem = Ecosystem
eco
        , paSegments :: [Segment]
paSegments = [Segment]
segments
        , paFixes :: Map Text [AdvisoryRange]
paFixes = ([AdvisoryRange] -> [AdvisoryRange] -> [AdvisoryRange])
-> [(Text, [AdvisoryRange])] -> Map Text [AdvisoryRange]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (([AdvisoryRange] -> [AdvisoryRange] -> [AdvisoryRange])
-> [AdvisoryRange] -> [AdvisoryRange] -> [AdvisoryRange]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [AdvisoryRange] -> [AdvisoryRange] -> [AdvisoryRange]
forall a. Semigroup a => a -> a -> a
(<>)) [(Text
fixed, [Segment -> AdvisoryRange
segRange Segment
s]) | Segment
s <- [Segment]
segments, FixedBefore Text
fixed <- [AdvisoryRange -> UpperBound
arUpperBound (Segment -> AdvisoryRange
segRange Segment
s)]]
        }

{- | The rows whose fixed bound is this version's exact text, in row order. A row with a fixed bound
always decodes to 'FixedBefore', so this is an exact match on the artifact's @fixed_version@.
-}
fixedAt :: PackageAdvisories -> Version -> [AdvisoryRange]
fixedAt :: PackageAdvisories -> Version -> [AdvisoryRange]
fixedAt PackageAdvisories
advisories Version
version = [AdvisoryRange]
-> Text -> Map Text [AdvisoryRange] -> [AdvisoryRange]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] (Version -> Text
renderVersion Version
version) (PackageAdvisories -> Map Text [AdvisoryRange]
paFixes PackageAdvisories
advisories)

{- | The rows whose affected interval holds a version of the package, in row order. __Fail-closed:__
an unprovable comparison counts as __inside__, bar a point the grammar cannot order.
-}
affecting :: PackageAdvisories -> Version -> [AdvisoryRange]
affecting :: PackageAdvisories -> Version -> [AdvisoryRange]
affecting PackageAdvisories
advisories Version
version = [Segment -> AdvisoryRange
segRange Segment
s | Segment
s <- PackageAdvisories -> [Segment]
paSegments PackageAdvisories
advisories, SegmentBounds -> Bool
holds (Segment -> SegmentBounds
segBounds Segment
s)]
  where
    key :: Maybe VersionKey
key = Ecosystem -> Version -> Maybe VersionKey
versionKeyIn (PackageAdvisories -> Ecosystem
paEcosystem PackageAdvisories
advisories) Version
version
    holds :: SegmentBounds -> Bool
holds = \case
        OnlyText Text
only -> Version -> Text
renderVersion Version
version Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
only
        Ordered Maybe VersionKey
lower UpperKey
upper -> Bool -> (VersionKey -> Bool) -> Maybe VersionKey -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\VersionKey
k -> VersionKey -> Maybe VersionKey -> Bool
atOrAbove VersionKey
k Maybe VersionKey
lower Bool -> Bool -> Bool
&& VersionKey -> UpperKey -> Bool
withinUpper VersionKey
k UpperKey
upper) Maybe VersionKey
key

atOrAbove :: VersionKey -> Maybe VersionKey -> Bool
atOrAbove :: VersionKey -> Maybe VersionKey -> Bool
atOrAbove VersionKey
k = Bool -> (VersionKey -> Bool) -> Maybe VersionKey -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (VersionKey
k VersionKey -> VersionKey -> Bool
forall a. Ord a => a -> a -> Bool
>=)

-- A fix is an exclusive upper bound and last_affected an inclusive one.
withinUpper :: VersionKey -> UpperKey -> Bool
withinUpper :: VersionKey -> UpperKey -> Bool
withinUpper VersionKey
k = \case
    Below VersionKey
fixed -> VersionKey
k VersionKey -> VersionKey -> Bool
forall a. Ord a => a -> a -> Bool
< VersionKey
fixed
    AtMost VersionKey
lastAffected -> VersionKey
k VersionKey -> VersionKey -> Bool
forall a. Ord a => a -> a -> Bool
<= VersionKey
lastAffected
    UpperKey
NoUpper -> Bool
True

{- OSV writes an enumerated version as introduced == last_affected. When the grammar rejects that
string, the segment names it literally, since nothing can order it against anything. -}
segmentBounds :: Ecosystem -> AdvisoryRange -> SegmentBounds
segmentBounds :: Ecosystem -> AdvisoryRange -> SegmentBounds
segmentBounds Ecosystem
eco AdvisoryRange
ar = case (AdvisoryRange -> Maybe Text
arIntroduced AdvisoryRange
ar, AdvisoryRange -> UpperBound
arUpperBound AdvisoryRange
ar) of
    (Just Text
introduced, LastAffected Text
lastAffected)
        | Text
introduced Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
lastAffected -> SegmentBounds
-> (VersionKey -> SegmentBounds)
-> Maybe VersionKey
-> SegmentBounds
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> SegmentBounds
OnlyText Text
introduced) (\VersionKey
k -> Maybe VersionKey -> UpperKey -> SegmentBounds
Ordered (VersionKey -> Maybe VersionKey
forall a. a -> Maybe a
Just VersionKey
k) (VersionKey -> UpperKey
AtMost VersionKey
k)) Maybe VersionKey
introducedKey
    (Maybe Text
_, UpperBound
upper) -> Maybe VersionKey -> UpperKey -> SegmentBounds
Ordered Maybe VersionKey
introducedKey (UpperBound -> UpperKey
upperKey UpperBound
upper)
  where
    keyOf :: Text -> Maybe VersionKey
keyOf = Either VersionError VersionKey -> Maybe VersionKey
forall l r. Either l r -> Maybe r
rightToMaybe (Either VersionError VersionKey -> Maybe VersionKey)
-> (Text -> Either VersionError VersionKey)
-> Text
-> Maybe VersionKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ecosystem -> Text -> Either VersionError VersionKey
parseVersionKey Ecosystem
eco
    introducedKey :: Maybe VersionKey
introducedKey = Text -> Maybe VersionKey
keyOf (Text -> Maybe VersionKey) -> Maybe Text -> Maybe VersionKey
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AdvisoryRange -> Maybe Text
arIntroduced AdvisoryRange
ar
    upperKey :: UpperBound -> UpperKey
upperKey = \case
        FixedBefore Text
fixed -> UpperKey
-> (VersionKey -> UpperKey) -> Maybe VersionKey -> UpperKey
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UpperKey
NoUpper VersionKey -> UpperKey
Below (Text -> Maybe VersionKey
keyOf Text
fixed)
        LastAffected Text
lastAffected -> UpperKey
-> (VersionKey -> UpperKey) -> Maybe VersionKey -> UpperKey
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UpperKey
NoUpper VersionKey -> UpperKey
AtMost (Text -> Maybe VersionKey
keyOf Text
lastAffected)
        UpperBound
Unbounded -> UpperKey
NoUpper

-- | Whether an individual absent score supplies threshold evidence.
data MissingScorePolicy
    = -- | CVSS keeps its denial for unscored advisories, including malware.
      DenyMissingScore
    | -- | EPSS requires a known score to supply a denial.
      AbstainMissingScore

-- | Compare a score with the deny threshold using the metric's missing-score policy.
scoreAtLeast :: MissingScorePolicy -> Double -> Maybe Double -> Bool
scoreAtLeast :: MissingScorePolicy -> Double -> Maybe Double -> Bool
scoreAtLeast MissingScorePolicy
missing Double
threshold = Bool -> (Double -> Bool) -> Maybe Double -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
absent (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
threshold)
  where
    absent :: Bool
absent = case MissingScorePolicy
missing of
        MissingScorePolicy
DenyMissingScore -> Bool
True
        MissingScorePolicy
AbstainMissingScore -> Bool
False