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

{- | The S3 upload adapter for the compiled OSV artifact: @PutObject@ an @osv.db@ into the
configured bucket, over an S3 env built for an optional custom endpoint
('Ecluse.Runtime.Aws.S3.buildS3Env'). It takes a __resolved__ 'AwsEndpoint' rather than the
application config, so it holds no dependency on the composition shell.
-}
module Ecluse.Runtime.Pilot.Export (
    exportToS3,
) where

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

import Amazonka qualified as AWS
import Amazonka.S3 qualified as S3
import Ecluse.Core.Telemetry.Record (timedSeconds)
import Ecluse.Core.Telemetry.Span (withOptionalSpan)
import Ecluse.Runtime.Aws.Env (AwsEndpoint)
import Ecluse.Runtime.Aws.S3 (buildS3Env)
import OpenTelemetry.Trace.Core (Span, SpanKind (Client), SpanStatus (Error), TracerProvider, addAttribute, setStatus)

{- | Upload an OSV artifact to @bucketName@ under the caller's @keyText@, which it derives from the
configured store so the proxy's sync reads this object. A failed upload logs and errors its span.
-}
exportToS3 :: (MonadResource m, MonadUnliftIO m, MonadThrow m, KatipContext m) => Maybe TracerProvider -> Maybe AwsEndpoint -> Text -> Text -> FilePath -> m ()
exportToS3 :: forall (m :: * -> *).
(MonadResource m, MonadUnliftIO m, MonadThrow m, KatipContext m) =>
Maybe TracerProvider
-> Maybe AwsEndpoint -> Text -> Text -> FilePath -> m ()
exportToS3 Maybe TracerProvider
mTracerProvider Maybe AwsEndpoint
mEndpoint Text
bucketName Text
keyText FilePath
dbPath = do
    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

    withOptionalSpan mTracerProvider Client "ecluse.pilot.osv.upload" $ \Maybe Span
mSpan -> do
        Maybe Span -> Text -> Text -> Integer -> m ()
forall (m :: * -> *).
MonadIO m =>
Maybe Span -> Text -> Text -> Integer -> m ()
stampUploadSpan Maybe Span
mSpan Text
bucketName Text
keyText Integer
size
        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 AwsEndpoint -> IO Env
buildS3Env Maybe AwsEndpoint
mEndpoint
        body <- liftIO $ AWS.chunkedFile 1048576 dbPath
        let request = BucketName -> ObjectKey -> RequestBody -> PutObject
S3.newPutObject (Text -> BucketName
S3.BucketName Text
bucketName) (Text -> ObjectKey
S3.ObjectKey Text
keyText) RequestBody
body

        -- Only the send is timed: building the env and the chunked body is not upload time.
        (_, elapsed) <-
            timedSeconds $
                withException (void (AWS.send env request)) (reportUploadFailure mSpan bucketName keyText)

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

stampUploadSpan :: (MonadIO m) => Maybe Span -> Text -> Text -> Integer -> m ()
stampUploadSpan :: forall (m :: * -> *).
MonadIO m =>
Maybe Span -> Text -> Text -> Integer -> m ()
stampUploadSpan Maybe Span
mSpan Text
bucketName Text
keyText Integer
size =
    Maybe Span -> (Span -> m ()) -> m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust 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)

-- Observation only: 'withException' re-raises, so the upload still fails after this runs.
reportUploadFailure :: (KatipContext m) => Maybe Span -> Text -> Text -> SomeException -> m ()
reportUploadFailure :: forall (m :: * -> *).
KatipContext m =>
Maybe Span -> Text -> Text -> SomeException -> m ()
reportUploadFailure Maybe Span
mSpan Text
bucketName Text
keyText SomeException
err = do
    Maybe Span -> (Span -> m ()) -> m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust 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
err))
    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
err))