module Ecluse.Pilot (
    runPilot,
    pilotApplication,

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

import Conduit (runResourceT)
import Katip (LogEnv, Severity (InfoS), logFM, ls)
import Katip.Monadic (runKatipContextT)
import Network.Wai (Application)

import UnliftIO.Async (concurrently_)
import UnliftIO.Exception (throwIO)

import Ecluse.Boot (BootEnv (..))
import Ecluse.Config (AppConfig (cfgOsvExportBaseUrl, cfgPort, cfgVulnerabilityDatabaseBucket))
import Ecluse.Log (moduleField)
import Ecluse.Pilot.Export (exportToS3, runExportLoop)
import Ecluse.Pilot.Osv (osvExportUrl)
import Ecluse.Pilot.Osv.Compile (compileOsvToSqlite)
import Ecluse.Server (ServerConfig (scCheckReady, scDrain, scPort), mkServerConfig, probeApplication, runWarp, serverMiddleware)
import Ecluse.Telemetry (Telemetry)

{- | 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. Its actual worker loop will ingest advisory databases.
-}
runPilot :: BootEnv -> IO ()
runPilot :: BootEnv -> IO ()
runPilot BootEnv
bootEnv = do
    let logEnv :: LogEnv
logEnv = BootEnv -> LogEnv
beLogEnv BootEnv
bootEnv
        port :: Int
port = AppConfig -> Int
cfgPort (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 :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_
            (Telemetry -> Config -> KatipContextT IO ()
forall (m :: * -> *).
(MonadMask m, MonadUnliftIO m, KatipContext m) =>
Telemetry -> Config -> m ()
runExportLoop (BootEnv -> Telemetry
beTelemetry BootEnv
bootEnv) (BootEnv -> Config
beConfigFull BootEnv
bootEnv))
            (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 -> IO Application -> IO ()
runWarp ServerConfig
cfg (ServerConfig -> IO Application
pilotApplication ServerConfig
cfg))

{- | 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 -> AppConfig -> PilotCompileOptions -> IO FilePath
runPilotCompile :: LogEnv
-> Telemetry -> AppConfig -> PilotCompileOptions -> IO String
runPilotCompile LogEnv
logEnv Telemetry
telemetry AppConfig
appCfg PilotCompileOptions
opts = do
    let url :: String
url = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (Text -> Text -> String
osvExportUrl (AppConfig -> Text
cfgOsvExportBaseUrl 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 <- Telemetry
-> String -> Text -> String -> ResourceT (KatipContextT IO) String
forall (m :: * -> *).
(MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) =>
Telemetry -> String -> Text -> String -> m String
compileOsvToSqlite Telemetry
telemetry (PilotCompileOptions -> String
pcoOutDir PilotCompileOptions
opts) (PilotCompileOptions -> Text
pcoEcosystem PilotCompileOptions
opts) String
url
            when (pcoUpload opts) $
                case cfgVulnerabilityDatabaseBucket 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 -> AppConfig -> Text -> String -> ResourceT (KatipContextT IO) ()
forall (m :: * -> *).
(MonadResource m, MonadThrow m, KatipContext m) =>
AppConfig -> Text -> String -> m ()
exportToS3 AppConfig
appCfg Text
bucket String
dbFile
            pure dbFile