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

{- | The advisory lookup's internals: the hardened SQLite open and the raw queries
"Ecluse.Core.Cve" curates into the public handle.

Importing this module opts out of the public surface's stability promises. It exists so a test
can pin the hardening properties against the connection the handle actually uses.
-}
module Ecluse.Core.Cve.Internal (
    AdvisoryRange (..),
    CveDbRejected (..),
    openHardenedConnection,
    advisoriesQuery,
    coveredNamesQuery,
    toRange,
    provenanceQuery,
) where

import Database.SQLite.Simple (Connection, Only (..), SQLError, close, execute_, open, query, query_)
import UnliftIO.Exception (onException, try)

import Ecluse.Core.Ecosystem (Ecosystem, ecosystemName)
import Ecluse.Core.Osv.Schema (ColumnSpec (..), EpssEvidence (EpssAvailable, EpssNotEstablished), EpssRequirement (EpssOptional, EpssRequired), MetaKey (MetaEcosystem, MetaEpssStatus), TableSpec (..), decodeEpssEvidence, osvSchemaEpoch, osvTableSpecs, renderMetaKey)
import Ecluse.Core.Osv.Types (UpperBound (FixedBefore, LastAffected, Unbounded))

{- | An advisory segment with nullable CVSS and EPSS scores and verbatim version bounds.
The introduced bound is inclusive. Absence means the segment starts at the beginning.
-}
data AdvisoryRange = AdvisoryRange
    { AdvisoryRange -> Text
arCveId :: Text
    , AdvisoryRange -> Maybe Double
arSeverity :: Maybe Double
    , AdvisoryRange -> Maybe Text
arIntroduced :: Maybe Text
    , AdvisoryRange -> UpperBound
arUpperBound :: UpperBound
    , AdvisoryRange -> Maybe Double
arEpss :: Maybe Double
    }
    deriving stock (AdvisoryRange -> AdvisoryRange -> Bool
(AdvisoryRange -> AdvisoryRange -> Bool)
-> (AdvisoryRange -> AdvisoryRange -> Bool) -> Eq AdvisoryRange
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AdvisoryRange -> AdvisoryRange -> Bool
== :: AdvisoryRange -> AdvisoryRange -> Bool
$c/= :: AdvisoryRange -> AdvisoryRange -> Bool
/= :: AdvisoryRange -> AdvisoryRange -> Bool
Eq, Int -> AdvisoryRange -> ShowS
[AdvisoryRange] -> ShowS
AdvisoryRange -> String
(Int -> AdvisoryRange -> ShowS)
-> (AdvisoryRange -> String)
-> ([AdvisoryRange] -> ShowS)
-> Show AdvisoryRange
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AdvisoryRange -> ShowS
showsPrec :: Int -> AdvisoryRange -> ShowS
$cshow :: AdvisoryRange -> String
show :: AdvisoryRange -> String
$cshowList :: [AdvisoryRange] -> ShowS
showList :: [AdvisoryRange] -> ShowS
Show)

{- | Why the hardened open refused an artifact before building a handle over it. A
rejection is a value, not a fault, so the caller can keep the last known-good database.
-}
data CveDbRejected
    = -- | The artifact's @user_version@ differs from 'osvSchemaEpoch'.
      CveDbWrongEpoch Int
    | -- | SQLite refused the file or reported integrity faults, carrying its error or report.
      CveDbIntegrityFailed [Text]
    | -- | A required relation is absent, non-strict, or lacks a column with its required type.
      CveDbSchemaNonConformant Text
    | -- | The ecosystem marker differs from the requested ecosystem or is absent.
      CveDbEcosystemMismatch (Maybe Text)
    | -- | Required feed enrichment lacks the exact success marker.
      CveDbEpssNotEstablished
    deriving stock (CveDbRejected -> CveDbRejected -> Bool
(CveDbRejected -> CveDbRejected -> Bool)
-> (CveDbRejected -> CveDbRejected -> Bool) -> Eq CveDbRejected
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CveDbRejected -> CveDbRejected -> Bool
== :: CveDbRejected -> CveDbRejected -> Bool
$c/= :: CveDbRejected -> CveDbRejected -> Bool
/= :: CveDbRejected -> CveDbRejected -> Bool
Eq, Int -> CveDbRejected -> ShowS
[CveDbRejected] -> ShowS
CveDbRejected -> String
(Int -> CveDbRejected -> ShowS)
-> (CveDbRejected -> String)
-> ([CveDbRejected] -> ShowS)
-> Show CveDbRejected
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CveDbRejected -> ShowS
showsPrec :: Int -> CveDbRejected -> ShowS
$cshow :: CveDbRejected -> String
show :: CveDbRejected -> String
$cshowList :: [CveDbRejected] -> ShowS
showList :: [CveDbRejected] -> ShowS
Show)

{- | Harden the connection before acceptance. SQLite's query-only pragma refuses writes.
Rejection and opening faults close the connection before returning.
-}
openHardenedConnection :: Ecosystem -> EpssRequirement -> FilePath -> IO (Either CveDbRejected Connection)
openHardenedConnection :: Ecosystem
-> EpssRequirement
-> String
-> IO (Either CveDbRejected Connection)
openHardenedConnection Ecosystem
eco EpssRequirement
epssRequirement String
dbFile = do
    conn <- String -> IO Connection
open String
dbFile
    -- The 'onException' guard closes the connection when a statement throws instead, for
    -- example a non-SQLite file whose first file-touching pragma raises.
    accepted <-
        (hardenConnection conn >> acceptArtifact eco epssRequirement conn)
            `onException` close conn
    case accepted of
        Left CveDbRejected
rejection -> do
            Connection -> IO ()
close Connection
conn
            Either CveDbRejected Connection
-> IO (Either CveDbRejected Connection)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CveDbRejected -> Either CveDbRejected Connection
forall a b. a -> Either a b
Left CveDbRejected
rejection)
        Right () -> Either CveDbRejected Connection
-> IO (Either CveDbRejected Connection)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Connection -> Either CveDbRejected Connection
forall a b. b -> Either a b
Right Connection
conn)

hardenConnection :: Connection -> IO ()
hardenConnection :: Connection -> IO ()
hardenConnection Connection
conn = do
    Connection -> Query -> IO ()
execute_ Connection
conn Query
"PRAGMA trusted_schema = OFF"
    Connection -> Query -> IO ()
execute_ Connection
conn Query
"PRAGMA query_only = ON"
    Connection -> Query -> IO ()
execute_ Connection
conn Query
"PRAGMA cell_size_check = ON"
    Connection -> Query -> IO ()
execute_ Connection
conn Query
"PRAGMA mmap_size = 0"

acceptArtifact :: Ecosystem -> EpssRequirement -> Connection -> IO (Either CveDbRejected ())
acceptArtifact :: Ecosystem
-> EpssRequirement -> Connection -> IO (Either CveDbRejected ())
acceptArtifact Ecosystem
eco EpssRequirement
epssRequirement Connection
conn = ExceptT CveDbRejected IO () -> IO (Either CveDbRejected ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT CveDbRejected IO () -> IO (Either CveDbRejected ()))
-> ExceptT CveDbRejected IO () -> IO (Either CveDbRejected ())
forall a b. (a -> b) -> a -> b
$ do
    IO (Either CveDbRejected ()) -> ExceptT CveDbRejected IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Connection -> IO (Either CveDbRejected ())
checkEpochStamp Connection
conn)
    IO (Either CveDbRejected ()) -> ExceptT CveDbRejected IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Connection -> IO (Either CveDbRejected ())
checkIntegrity Connection
conn)
    (TableSpec -> ExceptT CveDbRejected IO ())
-> [TableSpec] -> ExceptT CveDbRejected IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (IO (Either CveDbRejected ()) -> ExceptT CveDbRejected IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either CveDbRejected ()) -> ExceptT CveDbRejected IO ())
-> (TableSpec -> IO (Either CveDbRejected ()))
-> TableSpec
-> ExceptT CveDbRejected IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> TableSpec -> IO (Either CveDbRejected ())
checkTableConformance Connection
conn) [TableSpec]
osvTableSpecs
    IO (Either CveDbRejected ()) -> ExceptT CveDbRejected IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Ecosystem -> Connection -> IO (Either CveDbRejected ())
checkMetaEcosystem Ecosystem
eco Connection
conn)
    IO (Either CveDbRejected ()) -> ExceptT CveDbRejected IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (EpssRequirement -> Connection -> IO (Either CveDbRejected ())
checkEpssRequirement EpssRequirement
epssRequirement Connection
conn)

checkEpochStamp :: Connection -> IO (Either CveDbRejected ())
checkEpochStamp :: Connection -> IO (Either CveDbRejected ())
checkEpochStamp Connection
conn = do
    -- The first header read can throw SQLITE_NOTADB. A typed rejection suppresses repeated downloads.
    stamped <- IO [Only Int] -> IO (Either SQLError [Only Int])
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (Connection -> Query -> IO [Only Int]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"PRAGMA user_version") :: IO (Either SQLError [Only Int])
    pure $ case stamped of
        Left SQLError
err -> CveDbRejected -> Either CveDbRejected ()
forall a b. a -> Either a b
Left ([Text] -> CveDbRejected
CveDbIntegrityFailed [Text
"not a valid SQLite database: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SQLError -> Text
forall b a. (Show a, IsString b) => a -> b
show SQLError
err])
        Right [Only Int]
rows -> case (Only Int -> Int) -> [Only Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Only Int -> Int
forall a. Only a -> a
fromOnly [Only Int]
rows of
            [Int
epoch]
                | Int
epoch Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
osvSchemaEpoch -> () -> Either CveDbRejected ()
forall a b. b -> Either a b
Right ()
                | Bool
otherwise -> CveDbRejected -> Either CveDbRejected ()
forall a b. a -> Either a b
Left (Int -> CveDbRejected
CveDbWrongEpoch Int
epoch)
            [Int]
_ -> CveDbRejected -> Either CveDbRejected ()
forall a b. a -> Either a b
Left (Int -> CveDbRejected
CveDbWrongEpoch Int
0)

-- SQLite can report corrupt pages as rows or throw during the integrity walk.
checkIntegrity :: Connection -> IO (Either CveDbRejected ())
checkIntegrity :: Connection -> IO (Either CveDbRejected ())
checkIntegrity Connection
conn = do
    result <- IO [Only Text] -> IO (Either SQLError [Only Text])
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (Connection -> Query -> IO [Only Text]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"PRAGMA quick_check") :: IO (Either SQLError [Only Text])
    pure $ case result of
        Left SQLError
err -> CveDbRejected -> Either CveDbRejected ()
forall a b. a -> Either a b
Left ([Text] -> CveDbRejected
CveDbIntegrityFailed [SQLError -> Text
forall b a. (Show a, IsString b) => a -> b
show SQLError
err])
        Right [Only Text]
report -> case (Only Text -> Text) -> [Only Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Only Text -> Text
forall a. Only a -> a
fromOnly [Only Text]
report of
            [Text
"ok"] -> () -> Either CveDbRejected ()
forall a b. b -> Either a b
Right ()
            [Text]
problems -> CveDbRejected -> Either CveDbRejected ()
forall a b. a -> Either a b
Left ([Text] -> CveDbRejected
CveDbIntegrityFailed [Text]
problems)

-- Require real strict tables and their decoded columns. Compatible extra columns remain acceptable.
checkTableConformance :: Connection -> TableSpec -> IO (Either CveDbRejected ())
checkTableConformance :: Connection -> TableSpec -> IO (Either CveDbRejected ())
checkTableConformance Connection
conn TableSpec
spec = do
    listed <- IO [(Maybe Text, Maybe Int)]
-> IO (Either SQLError [(Maybe Text, Maybe Int)])
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (Connection -> Query -> Only Text -> IO [(Maybe Text, Maybe Int)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT type, strict FROM pragma_table_list WHERE name = ?" (Text -> Only Text
forall a. a -> Only a
Only (TableSpec -> Text
tableName TableSpec
spec))) :: IO (Either SQLError [(Maybe Text, Maybe Int)])
    columns <- try (query conn "SELECT name, type, \"notnull\" FROM pragma_table_xinfo(?)" (Only (tableName spec))) :: IO (Either SQLError [(Maybe Text, Maybe Text, Maybe Int)])
    pure $ case (listed, columns) of
        (Right [(Just Text
"table", Just Int
1)], Right [(Maybe Text, Maybe Text, Maybe Int)]
cols)
            | (ColumnSpec -> Bool) -> [ColumnSpec] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([(Maybe Text, Maybe Text, Maybe Int)] -> ColumnSpec -> Bool
hasConformingColumn [(Maybe Text, Maybe Text, Maybe Int)]
cols) (TableSpec -> [ColumnSpec]
tableColumns TableSpec
spec) -> () -> Either CveDbRejected ()
forall a b. b -> Either a b
Right ()
        (Either SQLError [(Maybe Text, Maybe Int)],
 Either SQLError [(Maybe Text, Maybe Text, Maybe Int)])
_ -> CveDbRejected -> Either CveDbRejected ()
forall a b. a -> Either a b
Left (Text -> CveDbRejected
CveDbSchemaNonConformant (TableSpec -> Text
tableName TableSpec
spec))

-- Is the required column among the table's actual columns, under its declared
-- type and (where the decode relies on it) NOT NULL?
hasConformingColumn :: [(Maybe Text, Maybe Text, Maybe Int)] -> ColumnSpec -> Bool
hasConformingColumn :: [(Maybe Text, Maybe Text, Maybe Int)] -> ColumnSpec -> Bool
hasConformingColumn [(Maybe Text, Maybe Text, Maybe Int)]
cols ColumnSpec
spec = ((Maybe Text, Maybe Text, Maybe Int) -> Bool)
-> [(Maybe Text, Maybe Text, Maybe Int)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe Text, Maybe Text, Maybe Int) -> Bool
forall {a}.
(Eq a, Num a) =>
(Maybe Text, Maybe Text, Maybe a) -> Bool
conforms [(Maybe Text, Maybe Text, Maybe Int)]
cols
  where
    conforms :: (Maybe Text, Maybe Text, Maybe a) -> Bool
conforms (Maybe Text
name, Maybe Text
declaredType, Maybe a
notnull) =
        Maybe Text
name Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just (ColumnSpec -> Text
colName ColumnSpec
spec)
            Bool -> Bool -> Bool
&& Maybe Text
declaredType Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just (ColumnSpec -> Text
colDeclaredType ColumnSpec
spec)
            Bool -> Bool -> Bool
&& (Bool -> Bool
not (ColumnSpec -> Bool
colNotNull ColumnSpec
spec) Bool -> Bool -> Bool
|| Maybe a
notnull Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Maybe a
forall a. a -> Maybe a
Just a
1)

checkMetaEcosystem :: Ecosystem -> Connection -> IO (Either CveDbRejected ())
checkMetaEcosystem :: Ecosystem -> Connection -> IO (Either CveDbRejected ())
checkMetaEcosystem Ecosystem
eco Connection
conn = do
    found <- Connection -> MetaKey -> IO (Maybe Text)
readMetaValue Connection
conn MetaKey
MetaEcosystem
    pure $
        if found == Just (ecosystemName eco)
            then Right ()
            else Left (CveDbEcosystemMismatch found)

checkEpssRequirement :: EpssRequirement -> Connection -> IO (Either CveDbRejected ())
checkEpssRequirement :: EpssRequirement -> Connection -> IO (Either CveDbRejected ())
checkEpssRequirement EpssRequirement
EpssOptional Connection
_ = Either CveDbRejected () -> IO (Either CveDbRejected ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either CveDbRejected ()
forall a b. b -> Either a b
Right ())
checkEpssRequirement EpssRequirement
EpssRequired Connection
conn = do
    evidence <- Maybe Text -> EpssEvidence
decodeEpssEvidence (Maybe Text -> EpssEvidence) -> IO (Maybe Text) -> IO EpssEvidence
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> MetaKey -> IO (Maybe Text)
readMetaValue Connection
conn MetaKey
MetaEpssStatus
    pure $ case evidence of
        EpssEvidence
EpssAvailable -> () -> Either CveDbRejected ()
forall a b. b -> Either a b
Right ()
        EpssEvidence
EpssNotEstablished -> CveDbRejected -> Either CveDbRejected ()
forall a b. a -> Either a b
Left CveDbRejected
CveDbEpssNotEstablished

-- Table conformance and integrity precede this decode. Query faults establish no metadata evidence.
readMetaValue :: Connection -> MetaKey -> IO (Maybe Text)
readMetaValue :: Connection -> MetaKey -> IO (Maybe Text)
readMetaValue Connection
conn MetaKey
key = do
    result <- IO [Only Text] -> IO (Either SQLError [Only Text])
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (Connection -> Query -> Only Text -> IO [Only Text]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT value FROM meta WHERE key = ?" (Text -> Only Text
forall a. a -> Only a
Only (MetaKey -> Text
renderMetaKey MetaKey
key))) :: IO (Either SQLError [Only Text])
    pure (either (const Nothing) (fmap fromOnly . listToMaybe) result)

{- | Every package name this artifact records an advisory against, each once. The name index
covers the scan, and the result is what a store sweep intersects its listing with.
-}
coveredNamesQuery :: Connection -> IO [Text]
coveredNamesQuery :: Connection -> IO [Text]
coveredNamesQuery Connection
conn =
    (Only Text -> Text) -> [Only Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Only Text -> Text
forall a. Only a -> a
fromOnly ([Only Text] -> [Text]) -> IO [Only Text] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> IO [Only Text]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"SELECT DISTINCT package_name FROM package_vulnerability_ranges"

-- | Every advisory segment recorded against a package name.
advisoriesQuery :: Connection -> Text -> IO [AdvisoryRange]
advisoriesQuery :: Connection -> Text -> IO [AdvisoryRange]
advisoriesQuery Connection
conn Text
name = do
    rows <- Connection
-> Query
-> Only Text
-> IO
     [(Text, Maybe Text, Maybe Text, Maybe Text, Maybe Double,
       Maybe Double)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT cve_id, introduced_version, fixed_version, last_affected_version, severity, epss_score FROM package_vulnerability_ranges WHERE package_name = ?" (Text -> Only Text
forall a. a -> Only a
Only Text
name)
    pure (map toRange rows)

{- | One artifact row as an advisory segment, decoding the two nullable bound columns
into the segment's single upper bound.
-}
toRange :: (Text, Maybe Text, Maybe Text, Maybe Text, Maybe Double, Maybe Double) -> AdvisoryRange
toRange :: (Text, Maybe Text, Maybe Text, Maybe Text, Maybe Double,
 Maybe Double)
-> AdvisoryRange
toRange (Text
cveId, Maybe Text
intro, Maybe Text
fixed, Maybe Text
lastAffected, Maybe Double
severity, Maybe Double
epss) =
    AdvisoryRange
        { arCveId :: Text
arCveId = Text
cveId
        , arSeverity :: Maybe Double
arSeverity = Maybe Double
severity
        , arIntroduced :: Maybe Text
arIntroduced = Maybe Text
intro
        , arUpperBound :: UpperBound
arUpperBound = UpperBound
upper
        , arEpss :: Maybe Double
arEpss = Maybe Double
epss
        }
  where
    -- The writer fills at most one bound column. A row carrying both resolves as the fix.
    upper :: UpperBound
upper = case (Maybe Text
fixed, Maybe Text
lastAffected) of
        (Just Text
f, Maybe Text
_) -> Text -> UpperBound
FixedBefore Text
f
        (Maybe Text
Nothing, Just Text
la) -> Text -> UpperBound
LastAffected Text
la
        (Maybe Text
Nothing, Maybe Text
Nothing) -> UpperBound
Unbounded

{- | The artifact's @meta@ provenance rows, key-sorted for a deterministic snapshot.
It runs only on an accepted connection, so the @(Text, Text)@ decode cannot throw.
-}
provenanceQuery :: Connection -> IO [(Text, Text)]
provenanceQuery :: Connection -> IO [(Text, Text)]
provenanceQuery Connection
conn = Connection -> Query -> IO [(Text, Text)]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"SELECT key, value FROM meta ORDER BY key"