{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}

-- 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 Wire.API.Asset
  ( -- * Asset
    Asset,
    Asset',
    mkAsset,
    assetKey,
    assetExpires,
    assetToken,

    -- * AssetKey
    AssetKey (..),
    assetKeyToText,

    -- * AssetToken
    AssetToken (..),
    NewAssetToken (..),

    -- * Body Construction
    buildMultipartBody,
    beginMultipartBody,
    endMultipartBody,

    -- * AssetHeaders
    AssetHeaders (..),
    mkHeaders,

    -- * AssetSettings
    AssetSettings,
    defAssetSettings,
    setAssetPublic,
    setAssetRetention,
    setAssetFiletype,
    setAssetConvId,
    setAssetFilename,
    AssetRetention (..),
    assetRetentionSeconds,
    assetExpiringSeconds,
    assetVolatileSeconds,
    retentionToTextRep,
    AssetMIMEType (..),

    -- * Streaming
    AssetLocation (..),
    LocalOrRemoteAsset (..),
  )
where

import Cassandra qualified as C
import Codec.MIME.Parse qualified as MIMEP
import Codec.MIME.Type qualified as MIME
import Control.Lens (makeLenses, (?~))
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Aeson qualified as Aeson
import Data.Attoparsec.ByteString.Char8 hiding (I)
import Data.Bifunctor
import Data.ByteString.Builder
import Data.ByteString.Conversion
import Data.ByteString.Lazy qualified as LBS
import Data.Id
import Data.Json.Util (UTCTimeMillis (fromUTCTimeMillis), toUTCTimeMillis)
import Data.OpenApi qualified as S
import Data.Proxy
import Data.Qualified
import Data.SOP
import Data.Schema
import Data.Text qualified as T
import Data.Text.Ascii (AsciiBase64Url)
import Data.Text.Encoding qualified as T
import Data.Text.Encoding.Error qualified as T
import Data.Time.Clock
import Data.UUID qualified as UUID
import Imports
import Servant
import URI.ByteString
import Wire.API.Error
import Wire.API.PostgresMarshall
import Wire.API.Routes.MultiVerb
import Wire.Arbitrary (Arbitrary (..), GenericUniform (..))

--------------------------------------------------------------------------------
-- Asset

type Asset = Asset' (Qualified AssetKey)

-- | A newly uploaded asset.
data Asset' key = Asset
  { _assetKey :: key,
    _assetExpires :: Maybe UTCTime,
    _assetToken :: Maybe AssetToken
  }
  deriving stock (Eq, Show, Generic, Functor)

deriving via Schema (Asset' key) instance (ToSchema (Asset' key)) => (ToJSON (Asset' key))

deriving via Schema (Asset' key) instance (ToSchema (Asset' key)) => (FromJSON (Asset' key))

deriving via Schema (Asset' key) instance (Typeable key, ToSchema (Asset' key)) => (S.ToSchema (Asset' key))

-- Generate expiry time with millisecond precision
instance (Arbitrary key) => Arbitrary (Asset' key) where
  arbitrary = Asset <$> arbitrary <*> (fmap milli <$> arbitrary) <*> arbitrary
    where
      milli = fromUTCTimeMillis . toUTCTimeMillis

mkAsset :: key -> Asset' key
mkAsset k = Asset k Nothing Nothing

instance ToSchema Asset where
  schema =
    object $
      Asset
        <$> _assetKey
          .= ( Qualified
                 <$> qUnqualified .= field "key" schema
                 <*> qDomain .= field "domain" schema
             )
        <*> (fmap toUTCTimeMillis . _assetExpires)
          .= maybe_
            (optField "expires" (fromUTCTimeMillis <$> schema))
        <*> _assetToken .= maybe_ (optField "token" schema)

--------------------------------------------------------------------------------
-- AssetKey

-- | A unique, versioned asset identifier.
-- Note: Can be turned into a sum type with additional constructors
-- for future versions.
data AssetKey = AssetKeyV3 AssetId AssetRetention
  deriving stock (Eq, Ord, Show, Generic)
  deriving (Arbitrary) via (GenericUniform AssetKey)
  deriving (FromJSON, ToJSON, S.ToSchema) via (Schema AssetKey)

instance FromByteString AssetKey where
  parser = do
    v <- decimal
    _ <- char '-'
    case (v :: Word) of
      3 -> parseV3
      _ -> fail $ "Invalid asset version: " ++ show v
    where
      -- AssetKeyV3 ::= Retention "-" uuid
      -- Retention  ::= decimal
      parseV3 = do
        r <- parser
        _ <- char '-'
        b <- takeByteString
        case UUID.fromASCIIBytes b of
          Just i -> pure $! AssetKeyV3 (Id i) r
          Nothing -> fail "Invalid asset ID"

instance ToByteString AssetKey where
  builder (AssetKeyV3 i r) =
    builder '3'
      <> builder '-'
      <> builder r
      <> builder '-'
      <> builder (UUID.toASCIIBytes (toUUID i))

assetKeyToText :: AssetKey -> Text
assetKeyToText = T.decodeUtf8 . toByteString'

instance ToSchema AssetKey where
  schema =
    assetKeyToText
      .= parsedTextWithDoc desc "AssetKey" (runParser parser . T.encodeUtf8)
      & doc' . S.schema . S.example ?~ toJSON ("3-1-47de4580-ae51-4650-acbb-d10c028cb0ac" :: Text)
    where
      desc =
        "S3 asset key for an icon image with retention information."

instance S.ToParamSchema AssetKey where
  toParamSchema _ = S.toParamSchema (Proxy @Text)

instance FromHttpApiData AssetKey where
  parseUrlPiece = first T.pack . runParser parser . T.encodeUtf8

instance C.Cql AssetKey where
  ctype = C.Tagged C.TextColumn
  toCql = C.CqlText . assetKeyToText
  fromCql (C.CqlText txt) = runParser parser . T.encodeUtf8 $ txt
  fromCql _ = Left "AssetKey: Text expected"

instance PostgresMarshall Text AssetKey where
  postgresMarshall = assetKeyToText

instance PostgresUnmarshall Text AssetKey where
  postgresUnmarshall = mapLeft (\e -> "failed to parse AssetKey: " <> T.pack e) . runParser parser . T.encodeUtf8

--------------------------------------------------------------------------------
-- AssetToken

-- | Asset tokens are bearer tokens that grant access to a single asset.
newtype AssetToken = AssetToken {assetTokenAscii :: AsciiBase64Url}
  deriving stock (Eq, Show)
  deriving newtype (FromByteString, ToByteString, Arbitrary)
  deriving (FromJSON, ToJSON, S.ToSchema) via (Schema AssetToken)

instance ToSchema AssetToken where
  schema =
    AssetToken
      <$> assetTokenAscii
        .= schema
      & doc' . S.schema . S.example ?~ toJSON ("aGVsbG8" :: Text)

instance S.ToParamSchema AssetToken where
  toParamSchema _ = S.toParamSchema (Proxy @Text)

instance FromHttpApiData AssetToken where
  parseUrlPiece = first T.pack . runParser parser . T.encodeUtf8

-- | A newly (re)generated token for an existing asset.
newtype NewAssetToken = NewAssetToken
  {newAssetToken :: AssetToken}
  deriving stock (Eq, Show)
  deriving newtype (Arbitrary)
  deriving (FromJSON, ToJSON, S.ToSchema) via (Schema NewAssetToken)

instance ToSchema NewAssetToken where
  schema =
    object $
      NewAssetToken <$> newAssetToken .= field "token" schema

--------------------------------------------------------------------------------
-- Body Construction

-- | Build a complete @multipart/mixed@ request body for a one-shot,
-- non-resumable asset upload.
buildMultipartBody :: AssetSettings -> MIME.Type -> LByteString -> Builder
buildMultipartBody sets typ bs =
  let hdrs = mkHeaders typ bs
   in beginMultipartBody sets hdrs <> lazyByteString bs <> endMultipartBody

-- | Begin building a @multipart/mixed@ request body for a non-resumable upload.
-- The returned 'Builder' can be immediately followed by the actual asset bytes.
beginMultipartBody :: AssetSettings -> AssetHeaders -> Builder
beginMultipartBody sets (AssetHeaders t l) =
  byteString
    "--frontier\r\n\
    \Content-Type: application/json\r\n\
    \Content-Length: "
    <> int64Dec (LBS.length settingsJson)
    <> byteString
      "\r\n\
      \\r\n"
    <> lazyByteString settingsJson
    <> byteString
      "\r\n\
      \--frontier\r\n\
      \Content-Type: "
    <> byteString (T.encodeUtf8 (MIME.showType t))
    <> byteString
      "\r\n\
      \Content-Length: "
    <> wordDec l
    <> "\r\n\
       \\r\n"
  where
    settingsJson = Aeson.encode (schemaToJSON sets)

-- | The trailer of a non-resumable @multipart/mixed@ request body initiated
-- via 'beginMultipartBody'.
endMultipartBody :: Builder
endMultipartBody = byteString "\r\n--frontier--\r\n"

--------------------------------------------------------------------------------
-- AssetHeaders

-- | Headers provided during upload.
data AssetHeaders = AssetHeaders
  { hdrType :: MIME.Type,
    hdrLength :: Word
  }

mkHeaders :: MIME.Type -> LByteString -> AssetHeaders
mkHeaders t b = AssetHeaders t (fromIntegral (LBS.length b))

--------------------------------------------------------------------------------
-- AssetSettings

-- | Settings provided during upload.
data AssetSettings = AssetSettings
  { _setAssetPublic :: Bool,
    _setAssetRetention :: Maybe AssetRetention,
    _setAssetConvId :: Maybe (Qualified ConvId),
    _setAssetFilename :: Maybe Text,
    _setAssetFiletype :: Maybe AssetMIMEType
  }
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform AssetSettings)
  deriving (FromJSON, ToJSON, S.ToSchema) via (Schema AssetSettings)

defAssetSettings :: AssetSettings
defAssetSettings = AssetSettings False Nothing Nothing Nothing Nothing

instance ToSchema AssetSettings where
  schema =
    object $
      AssetSettings
        <$> _setAssetPublic .= (fromMaybe False <$> optField "public" schema)
        <*> _setAssetRetention .= maybe_ (optField "retention" schema)
        <*> _setAssetConvId .= maybe_ (optField "convId" schema)
        <*> _setAssetFilename .= maybe_ (optField "filename" schema)
        <*> _setAssetFiletype .= maybe_ (optField "filetype" schema)

newtype AssetMIMEType = AssetMIMEType {unAssetMIMEType :: MIME.Type}
  deriving stock (Eq, Show)
  deriving newtype (Arbitrary)
  deriving (FromJSON, ToJSON, S.ToSchema) via (Schema AssetMIMEType)

instance ToSchema AssetMIMEType where
  schema =
    (MIME.showType . unAssetMIMEType) .= (AssetMIMEType <$> parsedText "MIMEType" (maybe (Left "Invalid MIME type") Right . MIMEP.parseMIMEType))

--------------------------------------------------------------------------------
-- AssetRetention

-- | The desired asset retention.
data AssetRetention
  = -- | The asset is retained indefinitely. Typically used
    -- for profile pictures / assets frequently accessed.
    AssetEternal
  | -- | DEPRECATED: should not be used by clients for new assets
    -- The asset is retained indefinitely.
    AssetPersistent
  | -- | The asset is retained for a short period of time.
    AssetVolatile
  | -- | The asset is retained indefinitely, storage is optimised
    -- for infrequent access
    AssetEternalInfrequentAccess
  | -- | The asset is retained for an extended period of time,
    -- but not indefinitely.
    AssetExpiring
  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)
  deriving (Arbitrary) via (GenericUniform AssetRetention)
  deriving (FromJSON, ToJSON, S.ToSchema) via (Schema AssetRetention)

-- | The minimum TTL in seconds corresponding to a chosen retention.
assetRetentionSeconds :: AssetRetention -> Maybe NominalDiffTime
assetRetentionSeconds AssetEternal = Nothing
assetRetentionSeconds AssetPersistent = Nothing
assetRetentionSeconds AssetVolatile = Just assetVolatileSeconds
assetRetentionSeconds AssetEternalInfrequentAccess = Nothing
assetRetentionSeconds AssetExpiring = Just assetExpiringSeconds

assetVolatileSeconds :: NominalDiffTime
assetVolatileSeconds = 28 * 24 * 3600 -- 28 days

assetExpiringSeconds :: NominalDiffTime
assetExpiringSeconds = 365 * 24 * 3600 -- 365 days

instance ToByteString AssetRetention where
  builder AssetEternal = builder '1'
  builder AssetPersistent = builder '2'
  builder AssetVolatile = builder '3'
  builder AssetEternalInfrequentAccess = builder '4'
  builder AssetExpiring = builder '5'

-- | ByteString representation is used in AssetKey
instance FromByteString AssetRetention where
  parser =
    decimal >>= \d -> case (d :: Word) of
      1 -> pure AssetEternal
      2 -> pure AssetPersistent
      3 -> pure AssetVolatile
      4 -> pure AssetEternalInfrequentAccess
      5 -> pure AssetExpiring
      _ -> fail $ "Invalid asset retention: " ++ show d

retentionToTextRep :: AssetRetention -> Text
retentionToTextRep AssetEternal = "eternal"
retentionToTextRep AssetPersistent = "persistent"
retentionToTextRep AssetVolatile = "volatile"
retentionToTextRep AssetEternalInfrequentAccess = "eternal-infrequent_access"
retentionToTextRep AssetExpiring = "expiring"

instance ToSchema AssetRetention where
  schema =
    enum @Text $
      foldMap
        (\value -> element (retentionToTextRep value) value)
        [minBound .. maxBound]

-- FUTUREWORK: switch to a better URI library (e.g. modern-uri)
--
-- This URI type is error-prone, since its internal representation is based on
-- ByteString, whereas URLs are defined in terms of characters, not octets (RFC
-- 3986).
newtype AssetLocation r = AssetLocation {getAssetLocation :: URIRef r}

instance ToHttpApiData (AssetLocation r) where
  toUrlPiece = T.decodeUtf8With T.lenientDecode . toHeader
  toHeader = serializeURIRef' . getAssetLocation

instance FromHttpApiData (AssetLocation Relative) where
  parseUrlPiece = parseHeader . T.encodeUtf8
  parseHeader =
    bimap (T.pack . show) AssetLocation
      . parseRelativeRef strictURIParserOptions

instance FromHttpApiData (AssetLocation Absolute) where
  parseUrlPiece = parseHeader . T.encodeUtf8
  parseHeader =
    bimap (T.pack . show) AssetLocation
      . parseURI strictURIParserOptions

instance S.ToParamSchema (AssetLocation r) where
  toParamSchema _ =
    mempty
      & S.type_ ?~ S.OpenApiString
      & S.format ?~ "url"

-- | An asset as returned by the download API: if the asset is local, only a
-- URL is returned, and if it is remote the content of the asset is streamed.
data LocalOrRemoteAsset
  = LocalAsset (AssetLocation Absolute)
  | RemoteAsset (SourceIO ByteString)

instance
  ( ResponseType r1 ~ AssetLocation Absolute,
    ResponseType r2 ~ SourceIO ByteString,
    KnownError (MapError e)
  ) =>
  AsUnion '[ErrorResponse e, r1, r2] (Maybe LocalOrRemoteAsset)
  where
  toUnion Nothing = Z (I (dynError @(MapError e)))
  toUnion (Just (LocalAsset loc)) = S (Z (I loc))
  toUnion (Just (RemoteAsset asset)) = S (S (Z (I asset)))

  fromUnion (Z (I _)) = Nothing
  fromUnion (S (Z (I loc))) = Just (LocalAsset loc)
  fromUnion (S (S (Z (I asset)))) = Just (RemoteAsset asset)
  fromUnion (S (S (S x))) = case x of {}

makeLenses ''Asset'
makeLenses ''AssetSettings
