-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module CargoHold.API.V3
  ( upload,
    download,
    downloadUnsafe,
    checkMetadata,
    delete,
    renewToken,
    deleteToken,
    randToken,
  )
where

import CargoHold.API.AuditLog
import CargoHold.API.Error
import CargoHold.API.Util
import CargoHold.App
import qualified CargoHold.Metrics as Metrics
import CargoHold.Options
import CargoHold.S3 (AssetAuditLogMetadata (AssetAuditLogMetadata))
import qualified CargoHold.S3 as S3
import CargoHold.Types.V3
import qualified CargoHold.Types.V3 as V3
import CargoHold.Util
import qualified Codec.MIME.Parse as MIME
import qualified Codec.MIME.Type as MIME
import qualified Conduit
import Control.Applicative (optional)
import Control.Error
import Control.Lens (set, (^.))
import Control.Monad.Trans.Resource
import Crypto.Random (getRandomBytes)
import Data.Aeson (eitherDecodeStrict')
import Data.Attoparsec.ByteString.Char8
import Data.ByteString.Conversion (toByteString')
import qualified Data.CaseInsensitive as CI
import Data.Conduit
import qualified Data.Conduit.Attoparsec as Conduit
import Data.Domain (Domain)
import Data.Id
import qualified Data.List as List
import Data.Qualified
import qualified Data.Text.Ascii as Ascii
import Data.Text.Encoding (decodeLatin1)
import qualified Data.Text.Lazy as LT
import Data.Time.Clock
import Data.UUID.V4
import Imports hiding (take)
import Network.HTTP.Types.Header
import Network.Wai.Utilities (Error (..))
import URI.ByteString
import Wire.API.Asset

upload :: V3.Principal -> Int -> ConduitM () ByteString (ResourceT IO) () -> Handler (Asset' (Local AssetKey))
upload own maxBytes bdy = do
  (rsrc, sets) <- parseMetadata bdy assetSettings
  (src, hdrs) <- parseHeaders rsrc assetHeaders
  auditEnabled <- asks (.options.settings.assetAuditLogEnabled)
  let mWireMetaText = do
        guard auditEnabled
        AssetAuditLogMetadata
          <$> sets ^. V3.setAssetConvId
          <*> sets ^. V3.setAssetFilename
          <*> sets ^. V3.setAssetFiletype
  when (auditEnabled && isNothing mWireMetaText) $ throwE missingAuditMetadata
  let cl = fromIntegral $ hdrLength hdrs
  when (cl <= 0) $
    throwE invalidLength
  when (cl > maxBytes) $
    throwE assetTooLarge
  ast <- liftIO $ Id <$> nextRandom
  tok <- if sets ^. V3.setAssetPublic then pure Nothing else Just <$> randToken
  let ret = fromMaybe V3.AssetPersistent (sets ^. V3.setAssetRetention)
  key <- qualifyLocal (V3.AssetKeyV3 ast ret)
  void $ S3.uploadV3 own (tUnqualified key) hdrs mWireMetaText tok src
  qown <- qualifyLocal own
  when auditEnabled $ do
    let pathTxt = decodeLatin1 (toByteString' (S3.mkKey (tUnqualified key)))
    logUpload qown mWireMetaText pathTxt
  Metrics.s3UploadOk
  Metrics.s3UploadSize cl
  expires <- case V3.assetRetentionSeconds ret of
    Just n -> Just . addUTCTime n <$> liftIO getCurrentTime
    Nothing -> pure Nothing
  pure $!
    V3.mkAsset key
      & set V3.assetExpires expires
      & set V3.assetToken tok

renewToken :: V3.Principal -> V3.AssetKey -> Handler V3.AssetToken
renewToken own key = do
  tok <- randToken
  updateToken own key (Just tok)
  pure tok

deleteToken :: V3.Principal -> V3.AssetKey -> Handler ()
deleteToken own key = updateToken own key Nothing

updateToken :: V3.Principal -> V3.AssetKey -> Maybe V3.AssetToken -> Handler ()
updateToken own key tok = do
  m <- S3.getMetadataV3 key >>= maybe (throwE assetNotFound) pure
  unless (S3.v3AssetOwner m == own) $
    throwE unauthorised
  let m' = m {S3.v3AssetToken = tok}
  S3.updateMetadataV3 key m'

randToken :: (MonadIO m) => m V3.AssetToken
randToken = liftIO $ V3.AssetToken . Ascii.encodeBase64Url <$> getRandomBytes 16

download :: V3.Principal -> V3.AssetKey -> Maybe V3.AssetToken -> Maybe Domain -> Handler (Maybe URI)
download own key tok mbHost = runMaybeT $ do
  qown <- lift $ qualifyLocal own
  meta <- checkMetadata (tUntagged qown) key tok
  lift $ genSignedURL (Just $ tUntagged qown) (Just meta) (S3.mkKey key) mbHost

downloadUnsafe :: V3.AssetKey -> Maybe Domain -> Handler URI
downloadUnsafe key mbHost = do
  meta <- S3.getMetadataV3 key
  genSignedURL Nothing meta (S3.mkKey key) mbHost

checkMetadata :: Qualified V3.Principal -> V3.AssetKey -> Maybe V3.AssetToken -> MaybeT Handler S3.S3AssetMeta
checkMetadata qown key tok = do
  let own = qUnqualified qown
  s3 <- lift (S3.getMetadataV3 key) >>= maybe mzero pure
  guard $ own == S3.v3AssetOwner s3 || tok == S3.v3AssetToken s3
  pure s3

delete :: V3.Principal -> V3.AssetKey -> Handler ()
delete own key = do
  m <- S3.getMetadataV3 key >>= maybe (throwE assetNotFound) pure
  unless (S3.v3AssetOwner m == own) $
    throwE unauthorised
  S3.deleteV3 key

-----------------------------------------------------------------------------
-- Streaming multipart parsing

parseMetadata :: ConduitM () ByteString (ResourceT IO) () -> Parser a -> Handler (SealedConduitT () ByteString (ResourceT IO) (), a)
parseMetadata src psr = do
  (rsrc, meta) <- liftIO . runResourceT $ src $$+ sinkParser psr
  (rsrc,) <$> hoistEither meta

parseHeaders :: SealedConduitT () ByteString (ResourceT IO) () -> Parser a -> Handler (ConduitM () ByteString (ResourceT IO) (), a)
parseHeaders src prs = do
  (rsrc, hdrs) <- liftIO $ runResourceT $ src $$++ sinkParser prs
  let src' = Conduit.unsealConduitT rsrc
  (src',) <$> hoistEither hdrs

sinkParser :: Parser a -> ConduitM ByteString o (ResourceT IO) (Either Error a)
sinkParser p = fmapL mkError <$> Conduit.sinkParserEither p
  where
    mkError = clientError . LT.pack . mkMsg
    mkMsg e =
      "Expected: "
        ++ intercalate ", " (Conduit.errorContexts e)
        ++ ", "
        ++ Conduit.errorMessage e
        ++ " at "
        ++ show (Conduit.errorPosition e)

-- Parsing Primitives

assetSettings :: Parser V3.AssetSettings
assetSettings = do
  (ct, cl) <- metadataHeaders
  unless (MIME.mimeType ct == MIME.Application "json") $
    fail "Invalid metadata Content-Type. Expected 'application/json'."
  bs <- take (fromIntegral cl)
  either fail pure (eitherDecodeStrict' bs)

metadataHeaders :: Parser (MIME.Type, Word)
metadataHeaders =
  optional eol
    *> boundary
    *> (headers [hContentType, hContentLength] >>= go)
    <* eol
  where
    go hdrs = do
      ct <- contentType hdrs
      cl <- contentLength hdrs
      pure (ct, cl)

assetHeaders :: Parser CargoHold.Types.V3.AssetHeaders
assetHeaders =
  eol
    *> boundary
    *> (headers [hContentType, hContentLength, hContentMD5] >>= go)
    <* eol
  where
    go hdrs =
      CargoHold.Types.V3.AssetHeaders
        <$> contentType hdrs
        <*> contentLength hdrs

contentType :: [(HeaderName, ByteString)] -> Parser MIME.Type
contentType hdrs =
  maybe
    (fail "Missing Content-Type")
    (maybe (fail "Invalid MIME type") pure . MIME.parseMIMEType . decodeLatin1)
    (lookup (CI.mk "Content-Type") hdrs)

contentLength :: [(HeaderName, ByteString)] -> Parser Word
contentLength hdrs =
  maybe
    (fail "Missing Content-Type")
    (either fail pure . parseOnly decimal)
    (lookup (CI.mk "Content-Length") hdrs)

boundary :: Parser ()
boundary =
  char '-'
    *> char '-'
    *> takeTill isEOL
    *> eol
    <?> "MIME boundary"

-- | Always parses until the end of headers is reached
-- (a line not starting with a char that's valid in header names, usually an empty line),
-- or fails.
-- Not all listed headers must be found, but other headers (or duplicates) raise an error.
headers :: [HeaderName] -> Parser [(HeaderName, ByteString)]
headers allowed = do
  -- optional in case there is no header left to parse
  optional (CI.mk <$> takeWhile1 (\c -> isAlphaNum c || c == '-') <?> "header name") >>= \case
    Nothing ->
      pure []
    Just name
      | name `notElem` allowed ->
          -- might also be a duplicate
          fail $ "Unexpected header: " ++ show (CI.original name)
      | otherwise -> do
          _ <- char ':'
          skipSpace
          value <- takeTill isEOL <?> "header value"
          eol
          -- we don't want to parse it again (this also ensures quick termination)
          ((name, value) :) <$> headers (List.delete name allowed)

eol :: Parser ()
eol = endOfLine <?> "\r\n"

isEOL :: Char -> Bool
isEOL c = c == '\n' || c == '\r'
