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

module Ecluse.Pilot (
    runPilot,
    pilotApplication,

    -- * One-shot compilation
    PilotCompileOptions (..),
    runPilotCompile,
    PilotUploadUnconfigured (..),
) where

import Conduit (MonadResource, runResourceT)
import Control.Monad.Catch (MonadMask)
import Katip (KatipContext, LogEnv, Severity (InfoS), logFM, ls)
import Katip.Monadic (runKatipContextT)
import Network.Wai (Application)
import UnliftIO (MonadUnliftIO)
import UnliftIO.Concurrent (threadDelay)
import UnliftIO.Exception (throwIO)

import Ecluse.Boot (BootEnv (..))
import Ecluse.Config (
    AdvisoriesSettings (advBucket, advCompileInterval, advDataDir, advOsvExportBaseUrl),
    AppConfig (cfgAdvisories, cfgServer),
    Config (configApp),
    ServerSettings (srvPort),
 )
import Ecluse.Config.Ambient (AmbientAws (ambientAwsEndpointUrl), parseEndpointUrl)
import Ecluse.Core.Osv.Advisory (osvExportUrl)
import Ecluse.Core.Osv.Compile (compileOsvToSqlite)
import Ecluse.Core.Supervision (
    BackoffSchedule (BackoffSchedule, bsBaseMicros, bsCapMicros),
    FaultDisposition (Transient),
    SupervisionPolicy (SupervisionPolicy, spBackoff, spClassify, spLabel),
    superviseLoop,
 )
import Ecluse.Runtime.Log (moduleField)
import Ecluse.Runtime.Pilot.Export (exportToS3)
import Ecluse.Runtime.Server (ServerConfig (scCheckReady, scDrain, scPort), mkServerConfig, probeApplication, raceServerAgainstLoop, runWarp, serverMiddleware)
import Ecluse.Runtime.Telemetry (Telemetry, telemetryTracerProvider)

{- | The WAI application for the Pilot worker mode.
It exposes liveness and readiness probes.
-}
pilotApplication :: ServerConfig -> IO Application
pilotApplication :: ServerConfig -> IO Application
pilotApplication ServerConfig
cfg = Application -> IO Application
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerConfig -> Middleware
serverMiddleware ServerConfig
cfg (DrainSignal -> IO Bool -> IO Bool -> Application
probeApplication (ServerConfig -> DrainSignal
scDrain ServerConfig
cfg) (ServerConfig -> IO Bool
scCheckReady ServerConfig
cfg) (Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)))

{- | The entry point for the Pilot worker mode.
Pilot runs as a standalone HTTP server that only exposes liveness and readiness
probes, while it concurrently runs the OSV export loop.

The probe server is raced against the export loop through
'Ecluse.Runtime.Server.raceServerAgainstLoop' (see there for the shutdown invariant):
the export loop never returns (it idles with no bucket, or supervises every fault as
transient with one), so the server's graceful return on shutdown must cancel it -- a
cancelled export cycle resumes from the remote artifact on the next boot.
-}
runPilot :: BootEnv -> IO ()
runPilot :: BootEnv -> IO ()
runPilot BootEnv
bootEnv = do
    let logEnv :: LogEnv
logEnv = BootEnv -> LogEnv
beLogEnv BootEnv
bootEnv
        port :: Int
port = ServerSettings -> Int
srvPort (AppConfig -> ServerSettings
cfgServer (BootEnv -> AppConfig
beConfig BootEnv
bootEnv))
        cfg :: ServerConfig
cfg = ([MountBinding] -> ServerConfig
mkServerConfig []){scPort = port}

    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.Pilot") Namespace
forall a. Monoid a => a
mempty (KatipContextT IO () -> IO ()) -> KatipContextT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Severity -> LogStr -> KatipContextT IO ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
InfoS (String -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (String
"Pilot mode starting up on port " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
port :: String))
        KatipContextT IO () -> KatipContextT IO () -> KatipContextT IO ()
forall (m :: * -> *). MonadUnliftIO m => m () -> m () -> m ()
raceServerAgainstLoop
            (IO () -> KatipContextT IO ()
forall a. IO a -> KatipContextT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KatipContextT IO ()) -> IO () -> KatipContextT IO ()
forall a b. (a -> b) -> a -> b
$ ServerConfig -> (ServerConfig -> IO Application) -> IO ()
runWarp ServerConfig
cfg ServerConfig -> IO Application
pilotApplication)
            (Telemetry -> AmbientAws -> Config -> KatipContextT IO ()
forall (m :: * -> *).
(MonadMask m, MonadUnliftIO m, KatipContext m) =>
Telemetry -> AmbientAws -> Config -> m ()
runExportLoop (BootEnv -> Telemetry
beTelemetry BootEnv
bootEnv) (BootEnv -> AmbientAws
beAmbient BootEnv
bootEnv) (BootEnv -> Config
beConfigFull BootEnv
bootEnv))

{- | The Pilot steady-state export loop: compile the npm OSV artifact and upload it
to the configured S3 bucket, then wait the configured sync interval and repeat. With
no bucket configured the loop idles. Orchestration over the OSV producer (the compile
in "Ecluse.Core.Osv.Compile") and the S3 adapter ("Ecluse.Runtime.Pilot.Export"); it
lives in the shell because it reads the composed configuration.

The cycle runs under the shared supervision combinator: every fault is transient
here (a failed export is retried; there is no per-cycle wiring fault to fail up
on), and the backoff is pinned at the sync interval on both ends, so a failing
export retries at exactly the cadence a succeeding one repeats at.
-}
runExportLoop :: (MonadMask m, MonadUnliftIO m, KatipContext m) => Telemetry -> AmbientAws -> Config -> m ()
runExportLoop :: forall (m :: * -> *).
(MonadMask m, MonadUnliftIO m, KatipContext m) =>
Telemetry -> AmbientAws -> Config -> m ()
runExportLoop Telemetry
telemetry AmbientAws
ambient Config
config = do
    let appCfg :: AppConfig
appCfg = Config -> AppConfig
configApp Config
config
        intervalMicros :: Int
intervalMicros = (NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (AdvisoriesSettings -> NominalDiffTime
advCompileInterval (AppConfig -> AdvisoriesSettings
cfgAdvisories AppConfig
appCfg)) :: Int) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
    case AdvisoriesSettings -> Maybe Text
advBucket (AppConfig -> AdvisoriesSettings
cfgAdvisories AppConfig
appCfg) of
        Maybe Text
Nothing -> do
            Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
InfoS LogStr
"No S3 bucket configured for OSV database export; export loop disabled."
            m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int
24 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000)
        Just Text
bucketName -> 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
"S3 export loop starting up. Target bucket: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bucketName))
            m Void -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
                (m Void -> m ()) -> m Void -> m ()
forall a b. (a -> b) -> a -> b
$ SupervisionPolicy -> m () -> m Void
forall (m :: * -> *).
(MonadUnliftIO m, KatipContext m) =>
SupervisionPolicy -> m () -> m Void
superviseLoop
                    SupervisionPolicy
                        { spLabel :: Text
spLabel = Text
"pilot-export"
                        , spClassify :: SomeException -> FaultDisposition
spClassify = FaultDisposition -> SomeException -> FaultDisposition
forall a b. a -> b -> a
const FaultDisposition
Transient
                        , spBackoff :: BackoffSchedule
spBackoff = BackoffSchedule{bsBaseMicros :: Int
bsBaseMicros = Int
intervalMicros, bsCapMicros :: Int
bsCapMicros = Int
intervalMicros}
                        }
                (m () -> m Void) -> m () -> m Void
forall a b. (a -> b) -> a -> b
$ do
                    ResourceT m () -> m ()
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (Telemetry -> AmbientAws -> AppConfig -> Text -> ResourceT m ()
forall (m :: * -> *).
(MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) =>
Telemetry -> AmbientAws -> AppConfig -> Text -> m ()
exportNpm Telemetry
telemetry AmbientAws
ambient AppConfig
appCfg Text
bucketName)
                    Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
intervalMicros

-- | Compile the npm OSV artifact and upload it to the given bucket: one full cycle.
exportNpm :: (MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) => Telemetry -> AmbientAws -> AppConfig -> Text -> m ()
exportNpm :: forall (m :: * -> *).
(MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) =>
Telemetry -> AmbientAws -> AppConfig -> Text -> m ()
exportNpm Telemetry
telemetry AmbientAws
ambient AppConfig
appCfg Text
bucketName = do
    Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
InfoS LogStr
"Starting npm OSV database compilation"
    dbPath <- Maybe TracerProvider -> String -> Text -> String -> m String
forall (m :: * -> *).
(MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) =>
Maybe TracerProvider -> String -> Text -> String -> m String
compileOsvToSqlite (Telemetry -> Maybe TracerProvider
telemetryTracerProvider Telemetry
telemetry) (AdvisoriesSettings -> String
advDataDir (AppConfig -> AdvisoriesSettings
cfgAdvisories AppConfig
appCfg)) Text
"npm" (Text -> Text -> String
osvExportUrl (AdvisoriesSettings -> Text
advOsvExportBaseUrl (AppConfig -> AdvisoriesSettings
cfgAdvisories AppConfig
appCfg)) Text
"npm")
    exportToS3 (telemetryTracerProvider telemetry) (ambientAwsEndpointUrl ambient >>= parseEndpointUrl) bucketName dbPath

{- | Options for the one-shot 'runPilotCompile' mode: which ecosystem's export
to compile, where to fetch it from, and where the artifact lands.
-}
data PilotCompileOptions = PilotCompileOptions
    { PilotCompileOptions -> Text
pcoEcosystem :: Text
    , PilotCompileOptions -> Maybe String
pcoSource :: Maybe String
    {- ^ Overrides the export URL; 'Nothing' selects the configured export
    base for the ecosystem ('osvExportUrl' under @osvExportBaseUrl@).
    -}
    , PilotCompileOptions -> String
pcoOutDir :: FilePath
    , PilotCompileOptions -> Bool
pcoUpload :: Bool
    {- ^ After compiling, upload the artifact to the configured
    vulnerability-database bucket, completing one full sync cycle.
    -}
    }
    deriving stock (PilotCompileOptions -> PilotCompileOptions -> Bool
(PilotCompileOptions -> PilotCompileOptions -> Bool)
-> (PilotCompileOptions -> PilotCompileOptions -> Bool)
-> Eq PilotCompileOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PilotCompileOptions -> PilotCompileOptions -> Bool
== :: PilotCompileOptions -> PilotCompileOptions -> Bool
$c/= :: PilotCompileOptions -> PilotCompileOptions -> Bool
/= :: PilotCompileOptions -> PilotCompileOptions -> Bool
Eq, Int -> PilotCompileOptions -> String -> String
[PilotCompileOptions] -> String -> String
PilotCompileOptions -> String
(Int -> PilotCompileOptions -> String -> String)
-> (PilotCompileOptions -> String)
-> ([PilotCompileOptions] -> String -> String)
-> Show PilotCompileOptions
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> PilotCompileOptions -> String -> String
showsPrec :: Int -> PilotCompileOptions -> String -> String
$cshow :: PilotCompileOptions -> String
show :: PilotCompileOptions -> String
$cshowList :: [PilotCompileOptions] -> String -> String
showList :: [PilotCompileOptions] -> String -> String
Show)

{- | Requesting an upload without a configured vulnerability-database bucket.

This is a wiring fault at the composition root: there is no per-run decision a
caller could make about it, so it throws rather than returning a value the
caller could only re-raise.
-}
data PilotUploadUnconfigured = PilotUploadUnconfigured
    deriving stock (PilotUploadUnconfigured -> PilotUploadUnconfigured -> Bool
(PilotUploadUnconfigured -> PilotUploadUnconfigured -> Bool)
-> (PilotUploadUnconfigured -> PilotUploadUnconfigured -> Bool)
-> Eq PilotUploadUnconfigured
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PilotUploadUnconfigured -> PilotUploadUnconfigured -> Bool
== :: PilotUploadUnconfigured -> PilotUploadUnconfigured -> Bool
$c/= :: PilotUploadUnconfigured -> PilotUploadUnconfigured -> Bool
/= :: PilotUploadUnconfigured -> PilotUploadUnconfigured -> Bool
Eq, Int -> PilotUploadUnconfigured -> String -> String
[PilotUploadUnconfigured] -> String -> String
PilotUploadUnconfigured -> String
(Int -> PilotUploadUnconfigured -> String -> String)
-> (PilotUploadUnconfigured -> String)
-> ([PilotUploadUnconfigured] -> String -> String)
-> Show PilotUploadUnconfigured
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> PilotUploadUnconfigured -> String -> String
showsPrec :: Int -> PilotUploadUnconfigured -> String -> String
$cshow :: PilotUploadUnconfigured -> String
show :: PilotUploadUnconfigured -> String
$cshowList :: [PilotUploadUnconfigured] -> String -> String
showList :: [PilotUploadUnconfigured] -> String -> String
Show)

instance Exception PilotUploadUnconfigured

{- | Run a single OSV compilation, optionally upload it, and return the
artifact's path.

The same bounded-retry pipeline the export loop runs, without the loop or the
probe server: point it at an export (or a stub serving a fixture zip) and it
writes the artifact into the requested directory, then uploads it when
'pcoUpload' asks for one full sync cycle. A source that cannot be fetched or
parsed propagates as an exception, so the process exits non-zero, which makes
the command safe to script and to schedule.
-}
runPilotCompile :: LogEnv -> Telemetry -> AmbientAws -> AppConfig -> PilotCompileOptions -> IO FilePath
runPilotCompile :: LogEnv
-> Telemetry
-> AmbientAws
-> AppConfig
-> PilotCompileOptions
-> IO String
runPilotCompile LogEnv
logEnv Telemetry
telemetry AmbientAws
ambient AppConfig
appCfg PilotCompileOptions
opts = do
    let url :: String
url = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (Text -> Text -> String
osvExportUrl (AdvisoriesSettings -> Text
advOsvExportBaseUrl (AppConfig -> AdvisoriesSettings
cfgAdvisories AppConfig
appCfg)) (PilotCompileOptions -> Text
pcoEcosystem PilotCompileOptions
opts)) (PilotCompileOptions -> Maybe String
pcoSource PilotCompileOptions
opts)
    LogEnv
-> SimpleLogPayload
-> Namespace
-> KatipContextT IO String
-> IO String
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
logEnv (Text -> SimpleLogPayload
moduleField Text
"Ecluse.Pilot") Namespace
forall a. Monoid a => a
mempty (KatipContextT IO String -> IO String)
-> KatipContextT IO String -> IO String
forall a b. (a -> b) -> a -> b
$
        ResourceT (KatipContextT IO) String -> KatipContextT IO String
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT (KatipContextT IO) String -> KatipContextT IO String)
-> ResourceT (KatipContextT IO) String -> KatipContextT IO String
forall a b. (a -> b) -> a -> b
$ do
            dbFile <- Maybe TracerProvider
-> String -> Text -> String -> ResourceT (KatipContextT IO) String
forall (m :: * -> *).
(MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) =>
Maybe TracerProvider -> String -> Text -> String -> m String
compileOsvToSqlite (Telemetry -> Maybe TracerProvider
telemetryTracerProvider Telemetry
telemetry) (PilotCompileOptions -> String
pcoOutDir PilotCompileOptions
opts) (PilotCompileOptions -> Text
pcoEcosystem PilotCompileOptions
opts) String
url
            when (pcoUpload opts) $
                case advBucket (cfgAdvisories appCfg) of
                    Maybe Text
Nothing -> PilotUploadUnconfigured -> ResourceT (KatipContextT IO) ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PilotUploadUnconfigured
PilotUploadUnconfigured
                    Just Text
bucket -> Maybe TracerProvider
-> Maybe (Bool, Text, Int)
-> Text
-> String
-> ResourceT (KatipContextT IO) ()
forall (m :: * -> *).
(MonadResource m, MonadUnliftIO m, MonadThrow m, KatipContext m) =>
Maybe TracerProvider
-> Maybe (Bool, Text, Int) -> Text -> String -> m ()
exportToS3 (Telemetry -> Maybe TracerProvider
telemetryTracerProvider Telemetry
telemetry) (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) Text
bucket String
dbFile
            pure dbFile