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

{- | The advisory-sync plan: one ecosystem's sync wiring ('CveSyncHandle'), the
config-driven plan that builds it ('planCveSync'), and the projections the
composition root reads off the plan (the per-ecosystem rule capabilities, the
first-sync readiness gate, and the sync schedule). "Ecluse.Proxy"'s @runProxy@
builds the plan at boot and runs one supervised sync task per handle.
-}
module Ecluse.Proxy.CveSync (
    CveSyncHandle (..),
    planCveSync,
    sweepStaleTemps,
    sweepStep,
    cveRuleDepsFor,
    katipFaultReporter,
    cveSyncReady,
    cveSyncScheduleFor,
) where

import Data.Map.Strict qualified as Map
import Katip (LogEnv, Severity (WarningS), logFM, ls, sl)
import Katip.Monadic (runKatipContextT)
import System.Directory (createDirectoryIfMissing, listDirectory, removeFile)
import System.FilePath (isExtensionOf, (</>))
import System.IO.Error (IOError, catchIOError)

import Ecluse.Config (
    AdvisoriesSettings (advBucket, advDataDir, advMaxDatabaseBytes, advPollInterval),
    AppConfig (cfgAdvisories, cfgMounts),
 )
import Ecluse.Config.Ambient (AmbientAws (ambientAwsEndpointUrl), parseEndpointUrl)
import Ecluse.Core.Breaker (BreakerReporter)
import Ecluse.Core.Cve.Slot (CveSlot, currentAdvisoryEtag, newCveSlot, withSlotLookup)
import Ecluse.Core.Ecosystem (Ecosystem, ecosystemName)
import Ecluse.Core.Osv.Schema (osvDbFileName)
import Ecluse.Core.Rules (FaultReporter (..), RuleDeps (..))
import Ecluse.Runtime.Cve.Sync (S3CveSource, SyncEnv (..), SyncSchedule (SyncSchedule, schedBootBackoff, schedPollDelay), bootBackoffDelays, newS3CveSource, s3CveFetchFor)
import Ecluse.Runtime.Log (moduleField)

{- | The rules' boot-bound capabilities for one mount ecosystem: the CVE
lookup borrows through that ecosystem's own slot when the sync plan carries
one, and abstains otherwise, so a mount's rules can never read a neighbouring
ecosystem's advisory database.
-}
cveRuleDepsFor :: Map.Map Ecosystem CveSyncHandle -> BreakerReporter -> FaultReporter -> Ecosystem -> RuleDeps
cveRuleDepsFor :: Map Ecosystem CveSyncHandle
-> BreakerReporter -> FaultReporter -> Ecosystem -> RuleDeps
cveRuleDepsFor Map Ecosystem CveSyncHandle
plan BreakerReporter
reporter FaultReporter
faultReporter Ecosystem
eco =
    RuleDeps
        { rdWithCveLookup :: forall a. (Maybe CveLookup -> IO a) -> IO a
rdWithCveLookup = ((Maybe CveLookup -> IO a) -> IO a)
-> (CveSyncHandle -> (Maybe CveLookup -> IO a) -> IO a)
-> Maybe CveSyncHandle
-> (Maybe CveLookup -> IO a)
-> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (\Maybe CveLookup -> IO a
use -> Maybe CveLookup -> IO a
use Maybe CveLookup
forall a. Maybe a
Nothing) (CveSlot -> (Maybe CveLookup -> IO a) -> IO a
forall a. CveSlot -> (Maybe CveLookup -> IO a) -> IO a
withSlotLookup (CveSlot -> (Maybe CveLookup -> IO a) -> IO a)
-> (CveSyncHandle -> CveSlot)
-> CveSyncHandle
-> (Maybe CveLookup -> IO a)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CveSyncHandle -> CveSlot
csSlot) (Ecosystem -> Map Ecosystem CveSyncHandle -> Maybe CveSyncHandle
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ecosystem
eco Map Ecosystem CveSyncHandle
plan)
        , rdCurrentAdvisoryEtag :: IO (Maybe DbEtag)
rdCurrentAdvisoryEtag = IO (Maybe DbEtag)
-> (CveSyncHandle -> IO (Maybe DbEtag))
-> Maybe CveSyncHandle
-> IO (Maybe DbEtag)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe DbEtag -> IO (Maybe DbEtag)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DbEtag
forall a. Maybe a
Nothing) (CveSlot -> IO (Maybe DbEtag)
currentAdvisoryEtag (CveSlot -> IO (Maybe DbEtag))
-> (CveSyncHandle -> CveSlot) -> CveSyncHandle -> IO (Maybe DbEtag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CveSyncHandle -> CveSlot
csSlot) (Ecosystem -> Map Ecosystem CveSyncHandle -> Maybe CveSyncHandle
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ecosystem
eco Map Ecosystem CveSyncHandle
plan)
        , rdBreakerReporter :: BreakerReporter
rdBreakerReporter = BreakerReporter
reporter
        , rdFaultReporter :: FaultReporter
rdFaultReporter = FaultReporter
faultReporter
        }

{- | A 'FaultReporter' that logs an exhausted effectful-rule evaluation's fault detail
to a katip @WarningS@ line (the @rule@ and @fault@ fields), so a live advisory-database
query fault is diagnosable rather than collapsing to a bare @Unavailable@. The rendered
detail is bounded (the driver's @SQLError@ text or a timeout); it carries no secret (a
'Ecluse.Core.Credential.Secret' redacts under @show@) and never reaches the client
response.
-}
katipFaultReporter :: LogEnv -> FaultReporter
katipFaultReporter :: LogEnv -> FaultReporter
katipFaultReporter LogEnv
logEnv =
    (Text -> Text -> IO ()) -> FaultReporter
FaultReporter ((Text -> Text -> IO ()) -> FaultReporter)
-> (Text -> Text -> IO ()) -> FaultReporter
forall a b. (a -> b) -> a -> b
$ \Text
ruleName Text
detail ->
        LogEnv
-> SimpleLogPayload -> Namespace -> KatipContextT IO () -> IO ()
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
logEnv (Text -> SimpleLogPayload
moduleField Text
"Ecluse.Core.Rules" SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"rule" Text
ruleName SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"fault" Text
detail) Namespace
forall a. Monoid a => a
mempty (KatipContextT IO () -> IO ()) -> KatipContextT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Severity -> LogStr -> KatipContextT IO ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
"effectful rule evaluation faulted" :: Text))

{- | The readiness gate over the sync plan: ready once every configured
ecosystem's advisory database has first-synced. The flags flip one way, so
readiness never flaps on this; an empty plan (no bucket) is vacuously ready.
-}
cveSyncReady :: Map.Map Ecosystem CveSyncHandle -> IO Bool
cveSyncReady :: Map Ecosystem CveSyncHandle -> IO Bool
cveSyncReady Map Ecosystem CveSyncHandle
plan = (CveSyncHandle -> IO Bool) -> [CveSyncHandle] -> IO Bool
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Monad m) =>
(a -> m Bool) -> f a -> m Bool
allM (TVar Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar Bool -> IO Bool)
-> (CveSyncHandle -> TVar Bool) -> CveSyncHandle -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CveSyncHandle -> TVar Bool
csReady) (Map Ecosystem CveSyncHandle -> [CveSyncHandle]
forall k a. Map k a -> [a]
Map.elems Map Ecosystem CveSyncHandle
plan)

{- | The sync tasks' timing: the shipped boot burst over the configured poll
interval. The microsecond conversion cannot wrap: the config decoder bounds
the interval to @[1, maxBound div 1_000_000]@ seconds.
-}
cveSyncScheduleFor :: AppConfig -> SyncSchedule
cveSyncScheduleFor :: AppConfig -> SyncSchedule
cveSyncScheduleFor AppConfig
env =
    SyncSchedule
        { schedBootBackoff :: [Int]
schedBootBackoff = [Int]
bootBackoffDelays
        , schedPollDelay :: Int
schedPollDelay = NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (AdvisoriesSettings -> NominalDiffTime
advPollInterval (AppConfig -> AdvisoriesSettings
cfgAdvisories AppConfig
env)) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000
        }

-- | One configured ecosystem's advisory-sync wiring.
data CveSyncHandle = CveSyncHandle
    { CveSyncHandle -> CveSlot
csSlot :: CveSlot
    -- ^ The slot this ecosystem's mount rules borrow through.
    , CveSyncHandle -> TVar Bool
csReady :: TVar Bool
    -- ^ The one-way first-sync readiness flag.
    , CveSyncHandle -> SyncEnv
csEnv :: SyncEnv
    -- ^ The sync task's environment.
    }

{- | Build the advisory-sync plan from config: nothing without a configured
vulnerability-database bucket; otherwise one 'CveSyncHandle' per configured
mount ecosystem, each against its own stable per-ecosystem object key and
canonical on-disk path under the OSV data dir. Prepares the data dir (created
if missing; stray @.tmp@ downloads from an interrupted run swept) so the sync
tasks start clean. Note the readiness consequence: an operator who mounts an
ecosystem Pilot does not compile has declared an artifact that never arrives,
and the pod honestly never reports ready.
-}
planCveSync :: LogEnv -> AmbientAws -> AppConfig -> IO (Map.Map Ecosystem CveSyncHandle)
planCveSync :: LogEnv
-> AmbientAws -> AppConfig -> IO (Map Ecosystem CveSyncHandle)
planCveSync LogEnv
logEnv AmbientAws
ambient AppConfig
appCfg = case AdvisoriesSettings -> Maybe Text
advBucket (AppConfig -> AdvisoriesSettings
cfgAdvisories AppConfig
appCfg) of
    Maybe Text
Nothing -> Map Ecosystem CveSyncHandle -> IO (Map Ecosystem CveSyncHandle)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Ecosystem CveSyncHandle
forall k a. Map k a
Map.empty
    Just Text
bucket -> do
        let dataDir :: String
dataDir = AdvisoriesSettings -> String
advDataDir (AppConfig -> AdvisoriesSettings
cfgAdvisories AppConfig
appCfg)
        Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dataDir
        LogEnv -> String -> IO ()
sweepStaleTemps LogEnv
logEnv String
dataDir
        cveSource <- Maybe (Bool, Text, Int) -> IO S3CveSource
newS3CveSource (AmbientAws -> Maybe Text
ambientAwsEndpointUrl AmbientAws
ambient Maybe Text
-> (Text -> Maybe (Bool, Text, Int)) -> Maybe (Bool, Text, Int)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe (Bool, Text, Int)
parseEndpointUrl)
        Map.fromList <$> traverse (cveSyncHandleFor appCfg cveSource bucket) (Map.keys (cfgMounts appCfg))

-- One ecosystem's sync wiring: a fresh slot and readiness flag, and the sync
-- environment against the ecosystem's stable object key and canonical on-disk
-- path under the OSV data dir. The S3 env is captured once in 'cveSource', so every
-- ecosystem's transport shares one credential discovery.
cveSyncHandleFor :: AppConfig -> S3CveSource -> Text -> Ecosystem -> IO (Ecosystem, CveSyncHandle)
cveSyncHandleFor :: AppConfig
-> S3CveSource
-> Text
-> Ecosystem
-> IO (Ecosystem, CveSyncHandle)
cveSyncHandleFor AppConfig
appCfg S3CveSource
cveSource Text
bucket Ecosystem
eco = do
    slot <- IO CveSlot
newCveSlot
    ready <- newTVarIO False
    let key = Text -> String
osvDbFileName (Ecosystem -> Text
ecosystemName Ecosystem
eco)
        syncEnv =
            SyncEnv
                { syncFetch :: CveFetch
syncFetch = S3CveSource -> Text -> Text -> Int -> CveFetch
s3CveFetchFor S3CveSource
cveSource Text
bucket (String -> Text
forall a. ToText a => a -> Text
toText String
key) (AdvisoriesSettings -> Int
advMaxDatabaseBytes (AppConfig -> AdvisoriesSettings
cfgAdvisories AppConfig
appCfg))
                , syncEcosystem :: Ecosystem
syncEcosystem = Ecosystem
eco
                , syncDbPath :: String
syncDbPath = AdvisoriesSettings -> String
advDataDir (AppConfig -> AdvisoriesSettings
cfgAdvisories AppConfig
appCfg) String -> String -> String
</> String
key
                , syncSlot :: CveSlot
syncSlot = CveSlot
slot
                }
    pure (eco, CveSyncHandle{csSlot = slot, csReady = ready, csEnv = syncEnv})

{- | Sweep stray in-progress downloads an interrupted run left beside the canonical
artifacts (relevant to in-pod container restarts, where an @emptyDir@ survives).
Best-effort: a filesystem fault (a read-only or mispermissioned data dir) is logged
at 'WarningS' against the affected path and the boot proceeds on a fresh-start
assumption, since a truly unusable dir surfaces again when the sync task downloads.
-}
sweepStaleTemps :: LogEnv -> FilePath -> IO ()
sweepStaleTemps :: LogEnv -> String -> IO ()
sweepStaleTemps LogEnv
logEnv String
dataDir =
    LogEnv -> String -> IO () -> IO ()
sweepStep LogEnv
logEnv String
dataDir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        entries <- String -> IO [String]
listDirectory String
dataDir
        traverse_ (removeStaleTemp logEnv dataDir) (filter (isExtensionOf "tmp") entries)

-- Remove one stray @.tmp@ entry, tolerating a per-entry filesystem fault so a single
-- unremovable file does not abort the rest of the sweep.
removeStaleTemp :: LogEnv -> FilePath -> FilePath -> IO ()
removeStaleTemp :: LogEnv -> String -> String -> IO ()
removeStaleTemp LogEnv
logEnv String
dataDir String
entry =
    let path :: String
path = String
dataDir String -> String -> String
</> String
entry in LogEnv -> String -> IO () -> IO ()
sweepStep LogEnv
logEnv String
path (String -> IO ()
removeFile String
path)

{- | Run one best-effort step of the stale-temp sweep: an 'IOError' (a read-only or
mispermissioned data dir) is logged at 'WarningS' against the affected path and
swallowed so the boot proceeds, while any non-'IO' exception propagates rather than
being hidden.
-}
sweepStep :: LogEnv -> FilePath -> IO () -> IO ()
sweepStep :: LogEnv -> String -> IO () -> IO ()
sweepStep LogEnv
logEnv String
path IO ()
step = IO ()
step IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` LogEnv -> String -> IOError -> IO ()
logSweepFailure LogEnv
logEnv String
path

-- Warn that a stale-temp sweep step could not touch a path, so a read-only or
-- mispermissioned OSV data dir is visible at boot. The path rides a structured field;
-- the OS error detail is the operator's own filesystem, not untrusted input.
logSweepFailure :: LogEnv -> FilePath -> IOError -> IO ()
logSweepFailure :: LogEnv -> String -> IOError -> IO ()
logSweepFailure LogEnv
logEnv String
path IOError
err =
    LogEnv
-> SimpleLogPayload -> Namespace -> KatipContextT IO () -> IO ()
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
logEnv SimpleLogPayload
payload Namespace
forall a. Monoid a => a
mempty (Severity -> LogStr -> KatipContextT IO ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
message))
  where
    payload :: SimpleLogPayload
payload = Text -> SimpleLogPayload
moduleField Text
"Ecluse.Proxy.CveSync" SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"path" (String -> Text
forall a. ToText a => a -> Text
toText String
path)
    message :: Text
message = Text
"could not sweep stale advisory temp files: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IOError -> Text
forall b a. (Show a, IsString b) => a -> b
show IOError
err :: Text