-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

{- | The S3 upload adapter for the compiled OSV artifact.

The amazonka-facing half of Pilot's export: @PutObject@ a compiled @osv.db@ into the
configured bucket over an S3 env built for an optional custom endpoint
('Ecluse.Runtime.Aws.S3.buildS3Env'). It takes a __pre-parsed__ endpoint tuple rather
than the application config, so it is an ecosystem-agnostic cloud adapter with no
dependency on the composition shell; the Pilot export loop resolves the endpoint from
config and passes it down.
-}
module Ecluse.Runtime.Pilot.Export (
    exportToS3,
) where

import Conduit (MonadResource)
import Control.Monad.Catch (MonadThrow)
import GHC.Clock (getMonotonicTime)
import Katip (KatipContext, Severity (..), katipAddContext, logFM, ls, sl)
import System.Directory (getFileSize)
import System.FilePath (takeFileName)
import UnliftIO (MonadUnliftIO)
import UnliftIO.Exception (bracket, withException)

import Amazonka qualified as AWS
import Amazonka.S3 qualified as S3
import Ecluse.Runtime.Aws.S3 (buildS3Env)
import OpenTelemetry.Context qualified as Ctx
import OpenTelemetry.Trace.Core (SpanKind (Client), SpanStatus (Error), TracerProvider, addAttribute, createSpan, defaultSpanArguments, endSpan, kind, makeTracer, setStatus, tracerOptions)

{- | Upload a compiled OSV artifact to the given S3 bucket, dialling an optional
custom endpoint (the pre-parsed @(secure, host, port)@ resolved from configuration).

The @PutObject@ runs inside an @ecluse.pilot.osv.upload@ client span (inert when
telemetry is off) carrying the bucket, object key, and byte count. A failed upload is
logged at the call site and marks the span errored before it propagates to the export
loop's supervisor, which otherwise sees only an opaque restart.
-}
exportToS3 :: (MonadResource m, MonadUnliftIO m, MonadThrow m, KatipContext m) => Maybe TracerProvider -> Maybe (Bool, Text, Int) -> Text -> FilePath -> m ()
exportToS3 :: forall (m :: * -> *).
(MonadResource m, MonadUnliftIO m, MonadThrow m, KatipContext m) =>
Maybe TracerProvider
-> Maybe (Bool, Text, Int) -> Text -> FilePath -> m ()
exportToS3 Maybe TracerProvider
mTracerProvider Maybe (Bool, Text, Int)
mEndpoint Text
bucketName FilePath
dbPath = do
    let keyText :: Text
keyText = FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> FilePath
takeFileName FilePath
dbPath)
        mTracer :: Maybe Tracer
mTracer = (\TracerProvider
tp -> TracerProvider -> InstrumentationLibrary -> TracerOptions -> Tracer
makeTracer TracerProvider
tp InstrumentationLibrary
"ecluse" TracerOptions
tracerOptions) (TracerProvider -> Tracer) -> Maybe TracerProvider -> Maybe Tracer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TracerProvider
mTracerProvider
    size <- IO Integer -> m Integer
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Integer -> m Integer) -> IO Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Integer
getFileSize FilePath
dbPath

    bracket
        (traverse (\Tracer
t -> Tracer -> Context -> Text -> SpanArguments -> m Span
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Tracer -> Context -> Text -> SpanArguments -> m Span
createSpan Tracer
t Context
Ctx.empty Text
"ecluse.pilot.osv.upload" SpanArguments
defaultSpanArguments{kind = Client}) mTracer)
        (mapM_ (`endSpan` Nothing))
        $ \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 ((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.bucket" Text
bucketName
                Span -> Text -> Text -> m ()
forall (m :: * -> *) a.
(MonadIO m, ToAttribute a) =>
Span -> Text -> a -> m ()
addAttribute Span
sp Text
"ecluse.osv.object_key" Text
keyText
                Span -> Text -> Text -> m ()
forall (m :: * -> *) a.
(MonadIO m, ToAttribute a) =>
Span -> Text -> a -> m ()
addAttribute Span
sp Text
"ecluse.osv.bytes" (Integer -> Text
forall b a. (Show a, IsString b) => a -> b
show Integer
size :: Text)
            SimpleLogPayload -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext (Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"bucket" Text
bucketName SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"object_key" Text
keyText SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Integer -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"bytes" Integer
size) (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
InfoS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
"Uploading " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
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
$ Maybe (Bool, Text, Int) -> IO Env
buildS3Env Maybe (Bool, Text, Int)
mEndpoint
            body <- liftIO $ AWS.chunkedFile 1048576 dbPath
            let req = BucketName -> ObjectKey -> RequestBody -> PutObject
S3.newPutObject (Text -> BucketName
S3.BucketName Text
bucketName) (Text -> ObjectKey
S3.ObjectKey Text
keyText) RequestBody
body

            start <- liftIO getMonotonicTime
            withException
                (void $ AWS.send env req)
                ( \(SomeException
e :: SomeException) -> 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
"S3 upload failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall b a. (Show a, IsString b) => a -> b
show SomeException
e))
                    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
"S3 upload failed for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
keyText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to bucket " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bucketName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall b a. (Show a, IsString b) => a -> b
show SomeException
e))
                )
            elapsed <- liftIO getMonotonicTime

            katipAddContext (sl "bucket" bucketName <> sl "bytes" size <> sl "duration_s" (elapsed - start)) $
                logFM InfoS "S3 upload complete"