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

{- | Compile OSV advisories and EPSS scores into the artifact consumed by CVE sync. Every pass
attempts the EPSS feed, and the ecosystem's 'EpssRequirement' decides whether a failed feed stops
publication or leaves the artifact recording unavailable enrichment.
-}
module Ecluse.Core.Osv.Compile (
    CompileSources (..),
    compileOsvToSqlite,
    PilotEpssRequired (..),
    osvToRow,
) where

import Conduit
import Control.Monad.Catch (MonadMask)
import Data.Conduit.List qualified as CL
import Data.Time (UTCTime, getCurrentTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import Database.SQLite.Simple
import Katip (KatipContext, Severity (..), SimpleLogPayload, katipAddContext, logFM, ls, sl)
import System.Directory (createDirectoryIfMissing, removeFile, renameFile)
import System.FilePath ((</>))
import System.IO (hClose, openTempFile)
import System.IO.Error (catchIOError)
import UnliftIO.Exception (bracket, throwIO)

import Ecluse.Core.BuildIdentity (productVersion)
import Ecluse.Core.Osv.Advisory (ExtractedOsv (..))
import Ecluse.Core.Osv.Ecosystem (OsvEcosystem (osvExportDirectory, osvWireName))
import Ecluse.Core.Osv.Epss (
    EpssEnrichment (EpssEnriched, EpssUnavailable),
    EpssFeed (efLastModified, efModelVersion, efScoreDate, efScores),
    EpssFeedFailure,
    acquireEpssFeed,
    enrichedFeed,
    enrichmentStatus,
    maxEpssFeedBytes,
    mkEpssScores,
    renderEpssFeedFailure,
    resolveEnrichment,
 )
import Ecluse.Core.Osv.Provenance (
    AdvisoryProvenance (..),
    QuietTime,
    SourceAge,
    provenanceRows,
    renderSourceAge,
    sourceAges,
    sourceQuiet,
 )
import Ecluse.Core.Osv.Retry (defaultOsvRetryPolicy, withOsvRetry)
import Ecluse.Core.Osv.Schema (
    EpssRequirement (EpssOptional, EpssRequired),
    EpssStatus (EnrichmentAvailable, EnrichmentUnavailable),
    MetaKey (..),
    metaTableDdl,
    osvDbFileName,
    osvSchemaEpoch,
    rangesTableDdl,
    renderEpssStatus,
    renderMetaKey,
 )
import Ecluse.Core.Osv.Stream (
    IngestStats (..),
    OsvAttempt (..),
    OsvIngest,
    PilotIngestAborted (..),
    defaultIngestLimits,
    newOsvIngest,
    readIngestStats,
    readOsvAttempt,
    resetIngestStats,
    resetOsvAttempt,
    streamOsvUrl,
    systemicDrop,
 )
import Ecluse.Core.Osv.Types (UpperBound (FixedBefore, LastAffected, Unbounded))
import Ecluse.Core.Security.Authority (credentialFreeUrl, dialledAuthorityLabel)
import Ecluse.Core.Telemetry.Metrics (
    AdvisoryCompileResult (CompileAborted, CompileCompleted),
    AdvisoryDropCause (DropMalformed, DropOversize),
 )
import Ecluse.Core.Telemetry.Record (AdvisoryCompileMetricsPort (acmpCompileAccepted, acmpCompileDropped, acmpCompileRun))
import Ecluse.Core.Telemetry.Span (withOptionalSpan)
import OpenTelemetry.Trace.Core (Span, SpanKind (Internal), SpanStatus (Error), TracerProvider, addAttribute, setStatus)

{- | The two upstreams one compile pass reads: the ecosystem's advisories, and the
exploitability scores it joins onto them.
-}
data CompileSources = CompileSources
    { CompileSources -> String
csOsvExportUrl :: String
    -- ^ The ecosystem's OSV export archive ('Ecluse.Core.Osv.Advisory.osvExportUrl').
    , CompileSources -> String
csEpssFeedUrl :: String
    -- ^ The EPSS daily feed, from the configured @advisories.epssFeedUrl@.
    }
    deriving stock (CompileSources -> CompileSources -> Bool
(CompileSources -> CompileSources -> Bool)
-> (CompileSources -> CompileSources -> Bool) -> Eq CompileSources
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompileSources -> CompileSources -> Bool
== :: CompileSources -> CompileSources -> Bool
$c/= :: CompileSources -> CompileSources -> Bool
/= :: CompileSources -> CompileSources -> Bool
Eq, Int -> CompileSources -> ShowS
[CompileSources] -> ShowS
CompileSources -> String
(Int -> CompileSources -> ShowS)
-> (CompileSources -> String)
-> ([CompileSources] -> ShowS)
-> Show CompileSources
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompileSources -> ShowS
showsPrec :: Int -> CompileSources -> ShowS
$cshow :: CompileSources -> String
show :: CompileSources -> String
$cshowList :: [CompileSources] -> ShowS
showList :: [CompileSources] -> ShowS
Show)

{- | Compile one ecosystem into @outDir@, refusing systemic drops, zero relevant rows, or a failed
EPSS feed the requirement makes fatal. A refusal leaves any previous artifact unchanged.
-}
compileOsvToSqlite :: (MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) => AdvisoryCompileMetricsPort -> Maybe TracerProvider -> FilePath -> OsvEcosystem -> EpssRequirement -> CompileSources -> QuietTime -> m FilePath
compileOsvToSqlite :: forall (m :: * -> *).
(MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) =>
AdvisoryCompileMetricsPort
-> Maybe TracerProvider
-> String
-> OsvEcosystem
-> EpssRequirement
-> CompileSources
-> QuietTime
-> m String
compileOsvToSqlite AdvisoryCompileMetricsPort
metrics Maybe TracerProvider
mTracerProvider String
outDir OsvEcosystem
eco EpssRequirement
requirement CompileSources
sources QuietTime
quietTime = do
    let dbFile :: String
dbFile = String
outDir String -> ShowS
</> Text -> String
osvDbFileName (OsvEcosystem -> Text
osvWireName OsvEcosystem
eco)
    Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
InfoS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
"Compiling OSV data for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> OsvEcosystem -> Text
osvWireName OsvEcosystem
eco Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText String
dbFile Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", EPSS enrichment " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EpssRequirement -> Text
renderRequirement EpssRequirement
requirement))

    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
outDir

    m String -> (String -> m ()) -> (String -> m ()) -> m ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
newCandidate String
outDir) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
removeCandidate) ((String -> m ()) -> m ()) -> (String -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \String
candidate -> do
        CompileRun -> String -> m ()
forall (m :: * -> *).
(MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) =>
CompileRun -> String -> m ()
compileCandidate CompileRun
run String
candidate
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
renameFile String
candidate String
dbFile
    String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
dbFile
  where
    run :: CompileRun
run =
        CompileRun
            { crMetrics :: AdvisoryCompileMetricsPort
crMetrics = AdvisoryCompileMetricsPort
metrics
            , crTracerProvider :: Maybe TracerProvider
crTracerProvider = Maybe TracerProvider
mTracerProvider
            , crEcosystem :: OsvEcosystem
crEcosystem = OsvEcosystem
eco
            , crEpss :: EpssRequirement
crEpss = EpssRequirement
requirement
            , crSources :: CompileSources
crSources = CompileSources
sources
            , crQuietTime :: QuietTime
crQuietTime = QuietTime
quietTime
            }

-- What stays fixed across one pass, so each step below takes one parameter rather than six.
data CompileRun = CompileRun
    { CompileRun -> AdvisoryCompileMetricsPort
crMetrics :: AdvisoryCompileMetricsPort
    , CompileRun -> Maybe TracerProvider
crTracerProvider :: Maybe TracerProvider
    , CompileRun -> OsvEcosystem
crEcosystem :: OsvEcosystem
    , CompileRun -> EpssRequirement
crEpss :: EpssRequirement
    , CompileRun -> CompileSources
crSources :: CompileSources
    , CompileRun -> QuietTime
crQuietTime :: QuietTime
    }

{- | A compile whose ecosystem requires EPSS enrichment met a failed feed, so it published nothing.
It names the feed by host and port alone, because the configured URL can carry a credential.
-}
data PilotEpssRequired = PilotEpssRequired
    { PilotEpssRequired -> Text
perEcosystem :: Text
    , PilotEpssRequired -> Text
perFeed :: Text
    -- ^ The feed's @host:port@.
    , PilotEpssRequired -> EpssFeedFailure
perFailure :: EpssFeedFailure
    }
    deriving stock (PilotEpssRequired -> PilotEpssRequired -> Bool
(PilotEpssRequired -> PilotEpssRequired -> Bool)
-> (PilotEpssRequired -> PilotEpssRequired -> Bool)
-> Eq PilotEpssRequired
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PilotEpssRequired -> PilotEpssRequired -> Bool
== :: PilotEpssRequired -> PilotEpssRequired -> Bool
$c/= :: PilotEpssRequired -> PilotEpssRequired -> Bool
/= :: PilotEpssRequired -> PilotEpssRequired -> Bool
Eq, Int -> PilotEpssRequired -> ShowS
[PilotEpssRequired] -> ShowS
PilotEpssRequired -> String
(Int -> PilotEpssRequired -> ShowS)
-> (PilotEpssRequired -> String)
-> ([PilotEpssRequired] -> ShowS)
-> Show PilotEpssRequired
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PilotEpssRequired -> ShowS
showsPrec :: Int -> PilotEpssRequired -> ShowS
$cshow :: PilotEpssRequired -> String
show :: PilotEpssRequired -> String
$cshowList :: [PilotEpssRequired] -> ShowS
showList :: [PilotEpssRequired] -> ShowS
Show)

instance Exception PilotEpssRequired where
    displayException :: PilotEpssRequired -> String
displayException = Text -> String
forall a. ToString a => a -> String
toString (Text -> String)
-> (PilotEpssRequired -> Text) -> PilotEpssRequired -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PilotEpssRequired -> Text
renderEpssRequired

renderEpssRequired :: PilotEpssRequired -> Text
renderEpssRequired :: PilotEpssRequired -> Text
renderEpssRequired PilotEpssRequired
refusal =
    PilotEpssRequired -> Text
perEcosystem PilotEpssRequired
refusal
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" requires EPSS enrichment, and the feed at "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PilotEpssRequired -> Text
perFeed PilotEpssRequired
refusal
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EpssFeedFailure -> Text
renderEpssFeedFailure (PilotEpssRequired -> EpssFeedFailure
perFailure PilotEpssRequired
refusal)

-- Fill one candidate file, which the caller renames into place only once this returns.
compileCandidate :: (MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) => CompileRun -> FilePath -> m ()
compileCandidate :: forall (m :: * -> *).
(MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) =>
CompileRun -> String -> m ()
compileCandidate CompileRun
run String
dbFile =
    Maybe TracerProvider
-> SpanKind -> Text -> (Maybe Span -> m ()) -> m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
Maybe TracerProvider
-> SpanKind -> Text -> (Maybe Span -> m a) -> m a
withOptionalSpan (CompileRun -> Maybe TracerProvider
crTracerProvider CompileRun
run) SpanKind
Internal Text
"ecluse.pilot.osv.compile" ((Maybe Span -> m ()) -> m ()) -> (Maybe Span -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Maybe Span
mSpan -> do
        Maybe Span -> (Span -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Span
mSpan (CompileRun -> Span -> m ()
forall (m :: * -> *). MonadIO m => CompileRun -> Span -> m ()
describeCompile CompileRun
run)

        -- Every record's date is judged against this one instant, so a long pass
        -- cannot let a later record pass a check an earlier one failed.
        now <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime

        -- The join needs the whole score table before the first advisory row lands.
        enrichment <- enrichOrRefuse run mSpan
        ingest <- newOsvIngest defaultIngestLimits (crEcosystem run) (maybe (mkEpssScores []) efScores (enrichedFeed enrichment)) now

        bracket (liftIO $ open dbFile) (liftIO . close) $ \Connection
conn -> do
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> IO ()
initSchema Connection
conn
            CompileRun -> OsvIngest -> Connection -> m ()
forall (m :: * -> *).
(MonadResource m, MonadMask m, KatipContext m) =>
CompileRun -> OsvIngest -> Connection -> m ()
ingestAdvisories CompileRun
run OsvIngest
ingest Connection
conn
            stats <- OsvIngest -> m IngestStats
forall (m :: * -> *). MonadIO m => OsvIngest -> m IngestStats
readIngestStats OsvIngest
ingest
            attempt <- readOsvAttempt ingest
            concludeCompile (crMetrics run) mSpan conn (conclusionOf run now enrichment attempt stats)

describeCompile :: (MonadIO m) => CompileRun -> Span -> m ()
describeCompile :: forall (m :: * -> *). MonadIO m => CompileRun -> Span -> m ()
describeCompile CompileRun
run Span
sp = do
    Span -> Text -> Text -> m ()
forall (m :: * -> *) a.
(MonadIO m, ToAttribute a) =>
Span -> Text -> a -> m ()
addAttribute Span
sp Text
"ecluse.osv.ecosystem" (OsvEcosystem -> Text
osvWireName (CompileRun -> OsvEcosystem
crEcosystem CompileRun
run))
    Span -> Text -> Text -> m ()
forall (m :: * -> *) a.
(MonadIO m, ToAttribute a) =>
Span -> Text -> a -> m ()
addAttribute Span
sp Text
"ecluse.osv.source_host" (Text -> Text
dialledAuthorityLabel (String -> Text
forall a. ToText a => a -> Text
toText (CompileSources -> String
csOsvExportUrl (CompileRun -> CompileSources
crSources CompileRun
run))))

-- The attempt runs whatever the requirement, so an ecosystem that could publish without scores
-- still carries them whenever the feed is up.
enrichOrRefuse :: (MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) => CompileRun -> Maybe Span -> m EpssEnrichment
enrichOrRefuse :: forall (m :: * -> *).
(MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) =>
CompileRun -> Maybe Span -> m EpssEnrichment
enrichOrRefuse CompileRun
run Maybe Span
mSpan = do
    acquired <- Int -> String -> m (Either EpssFeedFailure EpssFeed)
forall (m :: * -> *).
(MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) =>
Int -> String -> m (Either EpssFeedFailure EpssFeed)
acquireEpssFeed Int
maxEpssFeedBytes (CompileSources -> String
csEpssFeedUrl (CompileRun -> CompileSources
crSources CompileRun
run))
    forM_ mSpan $ \Span
sp -> Span -> Text -> Text -> m ()
forall (m :: * -> *) a.
(MonadIO m, ToAttribute a) =>
Span -> Text -> a -> m ()
addAttribute Span
sp Text
"ecluse.osv.epss_status" (EpssStatus -> Text
renderEpssStatus ((EpssFeedFailure -> EpssStatus)
-> (EpssFeed -> EpssStatus)
-> Either EpssFeedFailure EpssFeed
-> EpssStatus
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (EpssStatus -> EpssFeedFailure -> EpssStatus
forall a b. a -> b -> a
const EpssStatus
EnrichmentUnavailable) (EpssStatus -> EpssFeed -> EpssStatus
forall a b. a -> b -> a
const EpssStatus
EnrichmentAvailable) Either EpssFeedFailure EpssFeed
acquired))
    enrichment <- either (refuseRequiredEpss run mSpan) pure (resolveEnrichment (crEpss run) acquired)
    case enrichment of
        EpssUnavailable EpssFeedFailure
failure ->
            Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
"EPSS enrichment unavailable for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ecosystem Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CompileRun -> Text
epssFeedLabel CompileRun
run Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EpssFeedFailure -> Text
renderEpssFeedFailure EpssFeedFailure
failure Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". No " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ecosystem Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" rule depends on EPSS, so the artifact publishes without scores"))
        EpssEnriched EpssFeed
_ -> m ()
forall (f :: * -> *). Applicative f => f ()
pass
    pure enrichment
  where
    ecosystem :: Text
ecosystem = OsvEcosystem -> Text
osvWireName (CompileRun -> OsvEcosystem
crEcosystem CompileRun
run)

-- The throw leaves the candidate unrenamed, so nothing publishes and any previous artifact stays.
refuseRequiredEpss :: (KatipContext m) => CompileRun -> Maybe Span -> EpssFeedFailure -> m a
refuseRequiredEpss :: forall (m :: * -> *) a.
KatipContext m =>
CompileRun -> Maybe Span -> EpssFeedFailure -> m a
refuseRequiredEpss CompileRun
run Maybe Span
mSpan EpssFeedFailure
failure = do
    Maybe Span -> (Span -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Span
mSpan ((Span -> m ()) -> m ()) -> (Span -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Span
sp -> Span -> SpanStatus -> m ()
forall (m :: * -> *). MonadIO m => Span -> SpanStatus -> m ()
setStatus Span
sp (Text -> SpanStatus
Error Text
"required EPSS enrichment unavailable, compile abandoned")
    Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
ErrorS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
"Aborting OSV compile: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PilotEpssRequired -> Text
renderEpssRequired PilotEpssRequired
refusal))
    -- A fault for the caller: the scheduled loop retries on its cadence and a one-shot run exits non-zero.
    PilotEpssRequired -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PilotEpssRequired
refusal
  where
    refusal :: PilotEpssRequired
refusal =
        PilotEpssRequired
            { perEcosystem :: Text
perEcosystem = OsvEcosystem -> Text
osvWireName (CompileRun -> OsvEcosystem
crEcosystem CompileRun
run)
            , perFeed :: Text
perFeed = CompileRun -> Text
epssFeedLabel CompileRun
run
            , perFailure :: EpssFeedFailure
perFailure = EpssFeedFailure
failure
            }

epssFeedLabel :: CompileRun -> Text
epssFeedLabel :: CompileRun -> Text
epssFeedLabel CompileRun
run = Text -> Text
dialledAuthorityLabel (String -> Text
forall a. ToText a => a -> Text
toText (CompileSources -> String
csEpssFeedUrl (CompileRun -> CompileSources
crSources CompileRun
run)))

renderRequirement :: EpssRequirement -> Text
renderRequirement :: EpssRequirement -> Text
renderRequirement = \case
    EpssRequirement
EpssRequired -> Text
"required"
    EpssRequirement
EpssOptional -> Text
"optional"

-- A failed attempt leaves committed batches. NULL bounds defeat deduplication, so each retry
-- clears the table, the tally, and the source metadata before it re-streams.
ingestAdvisories :: (MonadResource m, MonadMask m, KatipContext m) => CompileRun -> OsvIngest -> Connection -> m ()
ingestAdvisories :: forall (m :: * -> *).
(MonadResource m, MonadMask m, KatipContext m) =>
CompileRun -> OsvIngest -> Connection -> m ()
ingestAdvisories CompileRun
run OsvIngest
ingest Connection
conn =
    RetryPolicyM m -> m () -> m ()
forall (m :: * -> *) a.
(MonadMask m, KatipContext m) =>
RetryPolicyM m -> m a -> m a
withOsvRetry RetryPolicyM m
forall (m :: * -> *). MonadIO m => RetryPolicyM m
defaultOsvRetryPolicy (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        OsvIngest -> m ()
forall (m :: * -> *). MonadIO m => OsvIngest -> m ()
resetIngestStats OsvIngest
ingest
        OsvIngest -> m ()
forall (m :: * -> *). MonadIO m => OsvIngest -> m ()
resetOsvAttempt OsvIngest
ingest
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO ()
execute_ Connection
conn Query
"DELETE FROM package_vulnerability_ranges"
        ConduitT () Void m () -> m ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m () -> m ()) -> ConduitT () Void m () -> m ()
forall a b. (a -> b) -> a -> b
$
            Maybe TracerProvider
-> OsvIngest -> String -> ConduitT () ExtractedOsv m ()
forall (m :: * -> *) i.
(MonadResource m, MonadThrow m, KatipContext m) =>
Maybe TracerProvider
-> OsvIngest -> String -> ConduitT i ExtractedOsv m ()
streamOsvUrl (CompileRun -> Maybe TracerProvider
crTracerProvider CompileRun
run) OsvIngest
ingest (CompileSources -> String
csOsvExportUrl (CompileRun -> CompileSources
crSources CompileRun
run))
                ConduitT () ExtractedOsv m ()
-> ConduitT ExtractedOsv Void m () -> ConduitT () Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (ExtractedOsv -> Bool) -> ConduitT ExtractedOsv ExtractedOsv m ()
forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
CL.filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== OsvEcosystem -> Text
osvExportDirectory (CompileRun -> OsvEcosystem
crEcosystem CompileRun
run)) (Text -> Bool) -> (ExtractedOsv -> Text) -> ExtractedOsv -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtractedOsv -> Text
extEcosystem)
                ConduitT ExtractedOsv ExtractedOsv m ()
-> ConduitT ExtractedOsv Void m ()
-> ConduitT ExtractedOsv Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Int -> ConduitT ExtractedOsv [ExtractedOsv] m ()
forall (m :: * -> *) a. Monad m => Int -> ConduitT a [a] m ()
CL.chunksOf Int
2000
                ConduitT ExtractedOsv [ExtractedOsv] m ()
-> ConduitT [ExtractedOsv] Void m ()
-> ConduitT ExtractedOsv Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Connection -> ConduitT [ExtractedOsv] Void m ()
forall (m :: * -> *) o.
MonadIO m =>
Connection -> ConduitT [ExtractedOsv] o m ()
sinkSqlite Connection
conn

data CompileConclusion = CompileConclusion
    { CompileConclusion -> Text
ccEcosystem :: Text
    , CompileConclusion -> CompileSources
ccSources :: CompileSources
    , CompileConclusion -> IngestStats
ccStats :: IngestStats
    , CompileConclusion -> EpssStatus
ccEpssStatus :: EpssStatus
    , CompileConclusion -> AdvisoryProvenance
ccProvenance :: AdvisoryProvenance
    , CompileConclusion -> QuietTime
ccQuietTime :: QuietTime
    , CompileConclusion -> UTCTime
ccNow :: UTCTime
    }

conclusionOf :: CompileRun -> UTCTime -> EpssEnrichment -> OsvAttempt -> IngestStats -> CompileConclusion
conclusionOf :: CompileRun
-> UTCTime
-> EpssEnrichment
-> OsvAttempt
-> IngestStats
-> CompileConclusion
conclusionOf CompileRun
run UTCTime
now EpssEnrichment
enrichment OsvAttempt
attempt IngestStats
stats =
    CompileConclusion
        { ccEcosystem :: Text
ccEcosystem = OsvEcosystem -> Text
osvWireName (CompileRun -> OsvEcosystem
crEcosystem CompileRun
run)
        , ccSources :: CompileSources
ccSources = CompileRun -> CompileSources
crSources CompileRun
run
        , ccStats :: IngestStats
ccStats = IngestStats
stats
        , ccEpssStatus :: EpssStatus
ccEpssStatus = EpssEnrichment -> EpssStatus
enrichmentStatus EpssEnrichment
enrichment
        , ccProvenance :: AdvisoryProvenance
ccProvenance = CompileSources
-> EpssEnrichment -> OsvAttempt -> AdvisoryProvenance
passProvenance (CompileRun -> CompileSources
crSources CompileRun
run) EpssEnrichment
enrichment OsvAttempt
attempt
        , ccQuietTime :: QuietTime
ccQuietTime = CompileRun -> QuietTime
crQuietTime CompileRun
run
        , ccNow :: UTCTime
ccNow = UTCTime
now
        }

newCandidate :: FilePath -> IO FilePath
newCandidate :: String -> IO String
newCandidate String
outDir = do
    (path, handle) <- String -> String -> IO (String, Handle)
openTempFile String
outDir String
".osv-candidate.db"
    hClose handle
    pure path

removeCandidate :: FilePath -> IO ()
removeCandidate :: String -> IO ()
removeCandidate String
path = IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
catchIOError (String -> IO ()
removeFile String
path) (IO () -> IOError -> IO ()
forall a b. a -> b -> a
const (IO () -> IOError -> IO ()) -> IO () -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- The sources as they described themselves, credential-free because the artifact reaches every
-- consumer. A feed that never arrived described nothing, so it records no EPSS source or date.
passProvenance :: CompileSources -> EpssEnrichment -> OsvAttempt -> AdvisoryProvenance
passProvenance :: CompileSources
-> EpssEnrichment -> OsvAttempt -> AdvisoryProvenance
passProvenance CompileSources
sources EpssEnrichment
enrichment OsvAttempt
attempt =
    AdvisoryProvenance
        { apOsvSource :: Maybe Text
apOsvSource = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Text
credentialFreeUrl (String -> Text
forall a. ToText a => a -> Text
toText (CompileSources -> String
csOsvExportUrl CompileSources
sources)))
        , apOsvLastModified :: Maybe UTCTime
apOsvLastModified = OsvAttempt -> Maybe UTCTime
oaLastModified OsvAttempt
attempt
        , apOsvNewestModified :: Maybe UTCTime
apOsvNewestModified = OsvAttempt -> Maybe UTCTime
oaNewestModified OsvAttempt
attempt
        , apEpssSource :: Maybe Text
apEpssSource = Text -> Text
credentialFreeUrl (String -> Text
forall a. ToText a => a -> Text
toText (CompileSources -> String
csEpssFeedUrl CompileSources
sources)) Text -> Maybe EpssFeed -> Maybe Text
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe EpssFeed
feed
        , apEpssLastModified :: Maybe UTCTime
apEpssLastModified = EpssFeed -> Maybe UTCTime
efLastModified (EpssFeed -> Maybe UTCTime) -> Maybe EpssFeed -> Maybe UTCTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe EpssFeed
feed
        , apEpssScoreDate :: Maybe UTCTime
apEpssScoreDate = EpssFeed -> Maybe UTCTime
efScoreDate (EpssFeed -> Maybe UTCTime) -> Maybe EpssFeed -> Maybe UTCTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe EpssFeed
feed
        , apEpssModelVersion :: Maybe Text
apEpssModelVersion = EpssFeed -> Maybe Text
efModelVersion (EpssFeed -> Maybe Text) -> Maybe EpssFeed -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe EpssFeed
feed
        }
  where
    feed :: Maybe EpssFeed
feed = EpssEnrichment -> Maybe EpssFeed
enrichedFeed EpssEnrichment
enrichment

concludeCompile :: (KatipContext m) => AdvisoryCompileMetricsPort -> Maybe Span -> Connection -> CompileConclusion -> m ()
concludeCompile :: forall (m :: * -> *).
KatipContext m =>
AdvisoryCompileMetricsPort
-> Maybe Span -> Connection -> CompileConclusion -> m ()
concludeCompile AdvisoryCompileMetricsPort
metrics Maybe Span
mSpan Connection
conn CompileConclusion
conclusion = do
    Maybe Span -> IngestStats -> m ()
forall (m :: * -> *).
MonadIO m =>
Maybe Span -> IngestStats -> m ()
recordCompileSpan Maybe Span
mSpan IngestStats
stats
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (AdvisoryCompileMetricsPort -> IngestStats -> IO ()
recordTallies AdvisoryCompileMetricsPort
metrics IngestStats
stats)
    counted <- IO [Only Int] -> m [Only Int]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Connection -> Query -> IO [Only Int]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"SELECT COUNT(*) FROM package_vulnerability_ranges" :: IO [Only Int])
    let rowCount = Int -> (Only Int -> Int) -> Maybe (Only Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 Only Int -> Int
forall a. Only a -> a
fromOnly ([Only Int] -> Maybe (Only Int)
forall a. [a] -> Maybe a
listToMaybe [Only Int]
counted)
    forM_ (compileRefusal stats rowCount) (refuseCompile metrics mSpan ecosystem stats)

    liftIO $ writeMeta conn conclusion rowCount
    liftIO (acmpCompileRun metrics CompileCompleted)
    forM_ mSpan $ \Span
sp -> Span -> Text -> Text -> m ()
forall (m :: * -> *) a.
(MonadIO m, ToAttribute a) =>
Span -> Text -> a -> m ()
addAttribute Span
sp Text
"ecluse.osv.row_count" (Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
rowCount :: Text)
    katipAddContext (sl "row_count" rowCount <> sl "epss_status" epssStatus <> dropFields ecosystem stats) $
        logFM InfoS (ls ("Compiled " <> show rowCount <> " advisory ranges for " <> ecosystem <> " (" <> renderDrops stats <> "), epss_status=" <> epssStatus))
    warnOnUnusableDates ecosystem stats
    logSourceAges ecosystem (sourceAges (ccNow conclusion) (ccQuietTime conclusion) (ccProvenance conclusion))
  where
    ecosystem :: Text
ecosystem = CompileConclusion -> Text
ccEcosystem CompileConclusion
conclusion
    stats :: IngestStats
stats = CompileConclusion -> IngestStats
ccStats CompileConclusion
conclusion
    epssStatus :: Text
epssStatus = EpssStatus -> Text
renderEpssStatus (CompileConclusion -> EpssStatus
ccEpssStatus CompileConclusion
conclusion)

recordCompileSpan :: (MonadIO m) => Maybe Span -> IngestStats -> m ()
recordCompileSpan :: forall (m :: * -> *).
MonadIO m =>
Maybe Span -> IngestStats -> m ()
recordCompileSpan Maybe Span
mSpan IngestStats
stats = Maybe Span -> (Span -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Span
mSpan ((Span -> m ()) -> m ()) -> (Span -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Span
sp -> do
    Span -> Text -> Text -> m ()
forall (m :: * -> *) a.
(MonadIO m, ToAttribute a) =>
Span -> Text -> a -> m ()
addAttribute Span
sp Text
"ecluse.osv.accepted" (Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (IngestStats -> Int
statAccepted IngestStats
stats) :: Text)
    Span -> Text -> Text -> m ()
forall (m :: * -> *) a.
(MonadIO m, ToAttribute a) =>
Span -> Text -> a -> m ()
addAttribute Span
sp Text
"ecluse.osv.dropped_oversize" (Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (IngestStats -> Int
statDroppedOversize IngestStats
stats) :: Text)
    Span -> Text -> Text -> m ()
forall (m :: * -> *) a.
(MonadIO m, ToAttribute a) =>
Span -> Text -> a -> m ()
addAttribute Span
sp Text
"ecluse.osv.dropped_malformed" (Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (IngestStats -> Int
statDroppedMalformed IngestStats
stats) :: Text)
    Span -> Text -> Text -> m ()
forall (m :: * -> *) a.
(MonadIO m, ToAttribute a) =>
Span -> Text -> a -> m ()
addAttribute Span
sp Text
"ecluse.osv.unorderable" (Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (IngestStats -> Int
statUnorderable IngestStats
stats) :: Text)

-- The refusal throws, so nothing after it in 'concludeCompile' runs: no metadata is written and
-- the candidate file is discarded unrenamed.
refuseCompile :: (KatipContext m) => AdvisoryCompileMetricsPort -> Maybe Span -> Text -> IngestStats -> Text -> m ()
refuseCompile :: forall (m :: * -> *).
KatipContext m =>
AdvisoryCompileMetricsPort
-> Maybe Span -> Text -> IngestStats -> Text -> m ()
refuseCompile AdvisoryCompileMetricsPort
metrics Maybe Span
mSpan Text
ecosystem IngestStats
stats Text
reason = do
    Maybe Span -> (Span -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Span
mSpan ((Span -> m ()) -> m ()) -> (Span -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Span
sp -> Span -> SpanStatus -> m ()
forall (m :: * -> *). MonadIO m => Span -> SpanStatus -> m ()
setStatus Span
sp (Text -> SpanStatus
Error (Text
reason Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", compile abandoned"))
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (AdvisoryCompileMetricsPort -> AdvisoryCompileResult -> IO ()
acmpCompileRun AdvisoryCompileMetricsPort
metrics AdvisoryCompileResult
CompileAborted)
    SimpleLogPayload -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext (Text -> IngestStats -> SimpleLogPayload
dropFields Text
ecosystem IngestStats
stats) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
ErrorS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
"Aborting OSV compile for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ecosystem Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reason Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IngestStats -> Text
renderDrops IngestStats
stats Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"))
    PilotIngestAborted -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (IngestStats -> PilotIngestAborted
PilotIngestAborted IngestStats
stats)

compileRefusal :: IngestStats -> Int -> Maybe Text
compileRefusal :: IngestStats -> Int -> Maybe Text
compileRefusal IngestStats
stats Int
rowCount
    | IngestStats -> Bool
systemicDrop IngestStats
stats = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"systemic advisory drop rate"
    | Int
rowCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"zero relevant advisory rows"
    | Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing

-- One line per pass, not per record: a source whose dates have gone wrong writes many, and
-- the rows are kept regardless.
warnOnUnusableDates :: (KatipContext m) => Text -> IngestStats -> m ()
warnOnUnusableDates :: forall (m :: * -> *). KatipContext m => Text -> IngestStats -> m ()
warnOnUnusableDates Text
ecosystem IngestStats
stats =
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
unusable Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
"Ignoring the modified date of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
unusable Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ecosystem Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" advisory record(s), unreadable or dated after this run's clock; their ranges are kept"))
  where
    unusable :: Int
unusable = IngestStats -> Int
statUnusableModified IngestStats
stats

-- The ages the sources declared, on every pass that published. A source past its threshold is
-- an operator alarm: raise the threshold for a slow ecosystem, or change the source.
logSourceAges :: (KatipContext m) => Text -> [SourceAge] -> m ()
logSourceAges :: forall (m :: * -> *). KatipContext m => Text -> [SourceAge] -> m ()
logSourceAges Text
ecosystem [SourceAge]
ages = [SourceAge] -> (SourceAge -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [SourceAge]
ages ((SourceAge -> m ()) -> m ()) -> (SourceAge -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \SourceAge
reading -> do
    Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
InfoS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
ecosystem Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SourceAge -> Text
renderSourceAge SourceAge
reading))
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SourceAge -> Bool
sourceQuiet SourceAge
reading) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
ErrorS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
ecosystem Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SourceAge -> Text
renderSourceAge SourceAge
reading Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", so the source has gone quiet"))

-- An abandoned pass records its tallies too, and a pass with no drops records a zero, so
-- the drop series exists before the first drop.
recordTallies :: AdvisoryCompileMetricsPort -> IngestStats -> IO ()
recordTallies :: AdvisoryCompileMetricsPort -> IngestStats -> IO ()
recordTallies AdvisoryCompileMetricsPort
metrics IngestStats
stats = do
    AdvisoryCompileMetricsPort -> Int -> IO ()
acmpCompileAccepted AdvisoryCompileMetricsPort
metrics (IngestStats -> Int
statAccepted IngestStats
stats)
    AdvisoryCompileMetricsPort -> AdvisoryDropCause -> Int -> IO ()
acmpCompileDropped AdvisoryCompileMetricsPort
metrics AdvisoryDropCause
DropOversize (IngestStats -> Int
statDroppedOversize IngestStats
stats)
    AdvisoryCompileMetricsPort -> AdvisoryDropCause -> Int -> IO ()
acmpCompileDropped AdvisoryCompileMetricsPort
metrics AdvisoryDropCause
DropMalformed (IngestStats -> Int
statDroppedMalformed IngestStats
stats)

renderDrops :: IngestStats -> Text
renderDrops :: IngestStats -> Text
renderDrops IngestStats
s =
    Text
"accepted "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (IngestStats -> Int
statAccepted IngestStats
s)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", dropped "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (IngestStats -> Int
statDroppedOversize IngestStats
s)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" oversize / "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (IngestStats -> Int
statDroppedMalformed IngestStats
s)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" malformed, kept "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (IngestStats -> Int
statUnorderable IngestStats
s)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" unorderable"

dropFields :: Text -> IngestStats -> SimpleLogPayload
dropFields :: Text -> IngestStats -> SimpleLogPayload
dropFields Text
ecosystem IngestStats
s =
    Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"ecosystem" Text
ecosystem
        SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Int -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"accepted" (IngestStats -> Int
statAccepted IngestStats
s)
        SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Int -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"dropped_oversize" (IngestStats -> Int
statDroppedOversize IngestStats
s)
        SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Int -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"dropped_malformed" (IngestStats -> Int
statDroppedMalformed IngestStats
s)
        SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Int -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"unorderable" (IngestStats -> Int
statUnorderable IngestStats
s)

initSchema :: Connection -> IO ()
initSchema :: Connection -> IO ()
initSchema Connection
conn = do
    Connection -> Query -> IO ()
execute_ Connection
conn (Text -> Query
Query Text
rangesTableDdl)
    -- A unique index rather than a composite PRIMARY KEY: @STRICT@ makes primary-key
    -- columns implicitly NOT NULL, and the three bound columns are legitimately NULL.
    Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE UNIQUE INDEX uq_ranges_segment ON package_vulnerability_ranges(package_name, cve_id, introduced_version, fixed_version, last_affected_version)"
    Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE INDEX idx_package_name ON package_vulnerability_ranges(package_name)"
    Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE INDEX idx_package_fixed ON package_vulnerability_ranges(package_name, fixed_version)"
    Connection -> Query -> IO ()
execute_ Connection
conn (Text -> Query
Query Text
metaTableDdl)
    Connection -> Query -> IO ()
execute_ Connection
conn (String -> Query
forall a. IsString a => String -> a
fromString (String
"PRAGMA user_version = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
osvSchemaEpoch))

-- Written once, after the stream completes and the refusals pass: the row count and the
-- source provenance are only meaningful for a complete artifact.
writeMeta :: Connection -> CompileConclusion -> Int -> IO ()
writeMeta :: Connection -> CompileConclusion -> Int -> IO ()
writeMeta Connection
conn CompileConclusion
conclusion Int
rowCount = do
    builtAt <- IO UTCTime
getCurrentTime
    executeMany
        conn
        "INSERT INTO meta (key, value) VALUES (?, ?)"
        ( [ (renderMetaKey MetaPilotVersion, productVersion)
          , (renderMetaKey MetaEcosystem, ccEcosystem conclusion)
          , (renderMetaKey MetaBuiltAt, toText (iso8601Show builtAt))
          , (renderMetaKey MetaSourceUrl, dialledAuthorityLabel (toText (csOsvExportUrl sources)))
          , (renderMetaKey MetaEpssStatus, renderEpssStatus status)
          , (renderMetaKey MetaRowCount, show rowCount)
          ]
            <> [(renderMetaKey MetaEpssSourceUrl, dialledAuthorityLabel (toText (csEpssFeedUrl sources))) | status == EnrichmentAvailable]
            <> provenanceRows (ccProvenance conclusion)
        )
  where
    sources :: CompileSources
sources = CompileConclusion -> CompileSources
ccSources CompileConclusion
conclusion
    status :: EpssStatus
status = CompileConclusion -> EpssStatus
ccEpssStatus CompileConclusion
conclusion

sinkSqlite :: (MonadIO m) => Connection -> ConduitT [ExtractedOsv] o m ()
sinkSqlite :: forall (m :: * -> *) o.
MonadIO m =>
Connection -> ConduitT [ExtractedOsv] o m ()
sinkSqlite Connection
conn = ([ExtractedOsv] -> ConduitT [ExtractedOsv] o m ())
-> ConduitT [ExtractedOsv] o m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (([ExtractedOsv] -> ConduitT [ExtractedOsv] o m ())
 -> ConduitT [ExtractedOsv] o m ())
-> ([ExtractedOsv] -> ConduitT [ExtractedOsv] o m ())
-> ConduitT [ExtractedOsv] o m ()
forall a b. (a -> b) -> a -> b
$ \[ExtractedOsv]
batch ->
    IO () -> ConduitT [ExtractedOsv] o m ()
forall a. IO a -> ConduitT [ExtractedOsv] o m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT [ExtractedOsv] o m ())
-> IO () -> ConduitT [ExtractedOsv] o m ()
forall a b. (a -> b) -> a -> b
$
        Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
withTransaction Connection
conn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Connection
-> Query
-> [(Text, Text, Maybe Text, Maybe Text, Maybe Text, Maybe Double,
     Maybe Double)]
-> IO ()
forall q. ToRow q => Connection -> Query -> [q] -> IO ()
executeMany
                Connection
conn
                Query
"INSERT OR IGNORE INTO package_vulnerability_ranges (package_name, cve_id, introduced_version, fixed_version, last_affected_version, severity, epss_score) VALUES (?, ?, ?, ?, ?, ?, ?)"
                ((ExtractedOsv
 -> (Text, Text, Maybe Text, Maybe Text, Maybe Text, Maybe Double,
     Maybe Double))
-> [ExtractedOsv]
-> [(Text, Text, Maybe Text, Maybe Text, Maybe Text, Maybe Double,
     Maybe Double)]
forall a b. (a -> b) -> [a] -> [b]
map ExtractedOsv
-> (Text, Text, Maybe Text, Maybe Text, Maybe Text, Maybe Double,
    Maybe Double)
osvToRow [ExtractedOsv]
batch)

{- | One extracted segment as its artifact row. The upper bound spreads over the
@fixed_version@ and @last_affected_version@ columns, and fills at most one of them.
-}
osvToRow :: ExtractedOsv -> (Text, Text, Maybe Text, Maybe Text, Maybe Text, Maybe Double, Maybe Double)
osvToRow :: ExtractedOsv
-> (Text, Text, Maybe Text, Maybe Text, Maybe Text, Maybe Double,
    Maybe Double)
osvToRow ExtractedOsv
osv = (ExtractedOsv -> Text
extPackage ExtractedOsv
osv, ExtractedOsv -> Text
extCveId ExtractedOsv
osv, ExtractedOsv -> Maybe Text
extIntroduced ExtractedOsv
osv, Maybe Text
fixed, Maybe Text
lastAffected, ExtractedOsv -> Maybe Double
extSeverity ExtractedOsv
osv, ExtractedOsv -> Maybe Double
extEpss ExtractedOsv
osv)
  where
    (Maybe Text
fixed, Maybe Text
lastAffected) = case ExtractedOsv -> UpperBound
extUpperBound ExtractedOsv
osv of
        FixedBefore Text
f -> (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
f, Maybe Text
forall a. Maybe a
Nothing)
        LastAffected Text
la -> (Maybe Text
forall a. Maybe a
Nothing, Text -> Maybe Text
forall a. a -> Maybe a
Just Text
la)
        UpperBound
Unbounded -> (Maybe Text
forall a. Maybe a
Nothing, Maybe Text
forall a. Maybe a
Nothing)