{-# LANGUAGE OverloadedStrings #-}

module Ecluse.Pilot.Export (
    runExportLoop,
    exportToS3,
    buildS3Env,
) where

import Conduit (MonadResource, runResourceT)
import Control.Monad.Catch (MonadMask, MonadThrow)
import System.FilePath (takeFileName)
import UnliftIO (MonadUnliftIO)
import UnliftIO.Concurrent (threadDelay)
import UnliftIO.Exception (catchAny)

import Katip (KatipContext, Severity (..), logFM, ls)

import Ecluse.Composition (parseEndpointUrl)
import Ecluse.Config (AppConfig (..), Config (..))
import Ecluse.Pilot.Osv (osvExportUrl)
import Ecluse.Pilot.Osv.Compile (compileOsvToSqlite)
import Ecluse.Telemetry (Telemetry)

import Amazonka qualified as AWS
import Amazonka.S3 qualified as S3

runExportLoop :: (MonadMask m, MonadUnliftIO m, KatipContext m) => Telemetry -> Config -> m ()
runExportLoop :: forall (m :: * -> *).
(MonadMask m, MonadUnliftIO m, KatipContext m) =>
Telemetry -> Config -> m ()
runExportLoop Telemetry
telemetry Config
config = do
    let appCfg :: AppConfig
appCfg = Config -> AppConfig
configApp Config
config
    case AppConfig -> Maybe Text
cfgVulnerabilityDatabaseBucket 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 () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny (ResourceT m () -> m ()
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT m () -> m ()) -> ResourceT m () -> m ()
forall a b. (a -> b) -> a -> b
$ Telemetry -> AppConfig -> Text -> ResourceT m ()
forall (m :: * -> *).
(MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) =>
Telemetry -> AppConfig -> Text -> m ()
exportNpm Telemetry
telemetry AppConfig
appCfg Text
bucketName) ((SomeException -> m ()) -> m ())
-> (SomeException -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \SomeException
e ->
                    Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
ErrorS (String -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (String
"Export failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall b a. (Show a, IsString b) => a -> b
show SomeException
e :: String))
                Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay ((NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (AppConfig -> NominalDiffTime
cfgCveSyncInterval AppConfig
appCfg) :: Int) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000)

exportNpm :: (MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) => Telemetry -> AppConfig -> Text -> m ()
exportNpm :: forall (m :: * -> *).
(MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) =>
Telemetry -> AppConfig -> Text -> m ()
exportNpm Telemetry
telemetry 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 <- Telemetry -> String -> Text -> String -> m String
forall (m :: * -> *).
(MonadResource m, MonadMask m, MonadUnliftIO m, KatipContext m) =>
Telemetry -> String -> Text -> String -> m String
compileOsvToSqlite Telemetry
telemetry (AppConfig -> String
cfgOsvDataDir AppConfig
appCfg) Text
"npm" (Text -> Text -> String
osvExportUrl (AppConfig -> Text
cfgOsvExportBaseUrl AppConfig
appCfg) Text
"npm")
    exportToS3 appCfg bucketName dbPath

exportToS3 :: (MonadResource m, MonadThrow m, KatipContext m) => AppConfig -> Text -> FilePath -> m ()
exportToS3 :: forall (m :: * -> *).
(MonadResource m, MonadThrow m, KatipContext m) =>
AppConfig -> Text -> String -> m ()
exportToS3 AppConfig
appCfg Text
bucketName String
dbPath = 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
"Uploading " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText String
dbPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to S3 bucket " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bucketName))

    env <- IO Env -> m Env
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> m Env) -> IO Env -> m Env
forall a b. (a -> b) -> a -> b
$ AppConfig -> IO Env
buildS3Env AppConfig
appCfg
    let key = Text -> ObjectKey
S3.ObjectKey (String -> Text
forall a. ToText a => a -> Text
toText (String -> String
takeFileName String
dbPath))

    body <- liftIO $ AWS.chunkedFile 1048576 dbPath
    let req = BucketName -> ObjectKey -> RequestBody -> PutObject
S3.newPutObject (Text -> BucketName
S3.BucketName Text
bucketName) ObjectKey
key RequestBody
body

    void $ AWS.send env req

    logFM InfoS "S3 upload complete"

buildS3Env :: AppConfig -> IO AWS.Env
buildS3Env :: AppConfig -> IO Env
buildS3Env AppConfig
appCfg = do
    env <- (EnvNoAuth -> IO Env) -> IO Env
forall (m :: * -> *). MonadIO m => (EnvNoAuth -> m Env) -> m Env
AWS.newEnv EnvNoAuth -> IO Env
forall (m :: * -> *) (withAuth :: * -> *).
(MonadCatch m, MonadIO m, Foldable withAuth) =>
Env' withAuth -> m Env
AWS.discover
    pure $ case cfgAwsEndpointUrl appCfg >>= parseEndpointUrl of
        Just (Bool, Text, Int)
endpoint -> Service -> Env -> Env
forall (withAuth :: * -> *).
Service -> Env' withAuth -> Env' withAuth
AWS.configureService ((Bool, Text, Int) -> Service
customS3Endpoint (Bool, Text, Int)
endpoint) Env
env
        Maybe (Bool, Text, Int)
Nothing -> Env
env

customS3Endpoint :: (Bool, Text, Int) -> AWS.Service
customS3Endpoint :: (Bool, Text, Int) -> Service
customS3Endpoint (Bool
secure, Text
host, Int
port) =
    (Bool -> ByteString -> Int -> Service -> Service
AWS.setEndpoint Bool
secure (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
host) Int
port Service
S3.defaultService)
        { AWS.s3AddressingStyle = AWS.S3AddressingStylePath
        }