{- | 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 tests can pin the hardening properties (the connection refuses
writes, schema-borne SQL is distrusted) directly against the connection the
handle actually uses.
-}
module Ecluse.Core.Cve.Internal (
    AdvisoryRange (..),
    CveDbRejected (..),
    openHardenedConnection,
    probeQuery,
    advisoriesQuery,
    provenanceQuery,
) where

import Database.SQLite.Simple (Connection, Only (..), close, execute_, open, query, query_)

import Ecluse.Core.Ecosystem (Ecosystem, ecosystemName)
import Ecluse.Core.Osv.Schema (MetaKey (MetaEcosystem), osvSchemaEpoch, renderMetaKey)

{- | One advisory range recorded against a package: the advisory's identifier,
its optional qualitative severity label, and the affected interval's bounds as
the artifact stores them (verbatim version text; 'Nothing' introduced means
"from the beginning", 'Nothing' fixed means "no fix known").
-}
data AdvisoryRange = AdvisoryRange
    { AdvisoryRange -> Text
arCveId :: Text
    , AdvisoryRange -> Maybe Text
arSeverity :: Maybe Text
    , AdvisoryRange -> Maybe Text
arIntroduced :: Maybe Text
    , AdvisoryRange -> Maybe Text
arFixed :: Maybe Text
    }
    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 a downloaded artifact was refused before a handle was built over it.

A rejection is a value, not an exception: the caller (the sync task, once it
exists) has a real decision to make, keep the last known-good database and
alarm, rather than a fault to unwind from.
-}
data CveDbRejected
    = {- | The artifact's @user_version@ stamp (carried) does not match this
      binary's 'osvSchemaEpoch'.
      -}
      CveDbWrongEpoch Int
    | {- | The ranges relation is not a plain table -- a view here is
      attacker-authored SQL wearing the table's name.
      -}
      CveDbRangesNotATable
    | {- | The artifact's @meta@ table names a different ecosystem (carried)
      than the one this handle was asked to serve.
      -}
      CveDbEcosystemMismatch (Maybe Text)
    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)

{- | Open an artifact read-only-in-effect and accept or reject it.

Hardening order matters: @trusted_schema = OFF@ (schema-defined functions,
views feeding triggers, and virtual tables in the file are distrusted) and
@query_only = ON@ (the connection refuses every write, so no trigger can ever
fire through it) are applied before the first query. Acceptance then checks,
cheapest and least trusting first: the 'osvSchemaEpoch' stamp, the ranges
relation being a real table, and the @meta@ ecosystem matching the one asked
for. A rejected artifact's connection is closed before returning.

Read-only is enforced at the connection level: sqlite-simple's public API has
no way to pass @SQLITE_OPEN_READONLY@ at open time, and @query_only@ yields
the same guarantee for every statement this connection will run.
-}
openHardenedConnection :: Ecosystem -> FilePath -> IO (Either CveDbRejected Connection)
openHardenedConnection :: Ecosystem -> String -> IO (Either CveDbRejected Connection)
openHardenedConnection Ecosystem
eco String
dbFile = do
    conn <- String -> IO Connection
open String
dbFile
    execute_ conn "PRAGMA trusted_schema = OFF"
    execute_ conn "PRAGMA query_only = ON"
    accepted <- acceptArtifact eco 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)

acceptArtifact :: Ecosystem -> Connection -> IO (Either CveDbRejected ())
acceptArtifact :: Ecosystem -> Connection -> IO (Either CveDbRejected ())
acceptArtifact Ecosystem
eco 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 ())
checkRangesTable Connection
conn)
    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)

checkEpochStamp :: Connection -> IO (Either CveDbRejected ())
checkEpochStamp :: Connection -> IO (Either CveDbRejected ())
checkEpochStamp Connection
conn = do
    stamped <- Connection -> Query -> IO [Only Int]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"PRAGMA user_version" :: IO [Only Int]
    pure $ case map fromOnly stamped 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)

checkRangesTable :: Connection -> IO (Either CveDbRejected ())
checkRangesTable :: Connection -> IO (Either CveDbRejected ())
checkRangesTable Connection
conn = do
    kinds <- Connection -> Query -> IO [Only Text]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"SELECT type FROM sqlite_master WHERE name = 'package_vulnerability_ranges'" :: IO [Only Text]
    pure $
        if map fromOnly kinds /= ["table"]
            then Left CveDbRangesNotATable
            else Right ()

checkMetaEcosystem :: Ecosystem -> Connection -> IO (Either CveDbRejected ())
checkMetaEcosystem :: Ecosystem -> Connection -> IO (Either CveDbRejected ())
checkMetaEcosystem Ecosystem
eco Connection
conn = do
    named <- 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
MetaEcosystem)) :: IO [Only Text]
    let found = Only Text -> Text
forall a. Only a -> a
fromOnly (Only Text -> Text) -> Maybe (Only Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Only Text] -> Maybe (Only Text)
forall a. [a] -> Maybe a
listToMaybe [Only Text]
named
    pure $
        if found == Just (ecosystemName eco)
            then Right ()
            else Left (CveDbEcosystemMismatch found)

{- | Does any advisory for this package name this exact version string as a
fixed bound? One indexed probe (@package_name, fixed_version@); deliberately
string equality, per the artifact contract's canonical-semver expectation.
-}
probeQuery :: Connection -> Text -> Text -> IO Bool
probeQuery :: Connection -> Text -> Text -> IO Bool
probeQuery Connection
conn Text
name Text
version = do
    hits <- Connection -> Query -> (Text, Text) -> IO [Only Int]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT 1 FROM package_vulnerability_ranges WHERE package_name = ? AND fixed_version = ? LIMIT 1" (Text
name, Text
version) :: IO [Only Int]
    pure (not (null hits))

-- | Every advisory range 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)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT cve_id, introduced_version, fixed_version, severity FROM package_vulnerability_ranges WHERE package_name = ?" (Text -> Only Text
forall a. a -> Only a
Only Text
name)
    pure (map toRange rows)
  where
    toRange :: (Text, Maybe Text, Maybe Text, Maybe Text) -> AdvisoryRange
toRange (Text
cveId, Maybe Text
intro, Maybe Text
fixed, Maybe Text
severity) =
        AdvisoryRange
            { arCveId :: Text
arCveId = Text
cveId
            , arIntroduced :: Maybe Text
arIntroduced = Maybe Text
intro
            , arFixed :: Maybe Text
arFixed = Maybe Text
fixed
            , arSeverity :: Maybe Text
arSeverity = Maybe Text
severity
            }

{- | The artifact's @meta@ provenance rows, key-sorted for a deterministic
snapshot. An artifact with no @meta@ table would have failed acceptance, so
this only ever runs on an accepted connection.
-}
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"