{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-unused-do-bind #-}
module PostgREST.MediaType
  ( MediaType(..)
  , MTVndPlanOption (..)
  , MTVndPlanFormat (..)
  , toContentType
  , toMime
  , decodeMediaType
  ) where

import qualified Data.Aeson                    as JSON
import qualified Data.ByteString               as BS
import qualified Data.Text                     as T
import qualified Text.ParserCombinators.Parsec as P

import Data.Map                  (fromList, (!?))
import Data.Text.Encoding        (decodeLatin1)
import Network.HTTP.Types.Header (Header, hContentType)

import Protolude

-- | Enumeration of currently supported media types
data MediaType
  = MTApplicationJSON
  | MTGeoJSON
  | MTTextCSV
  | MTTextPlain
  | MTTextXML
  | MTOpenAPI
  | MTUrlEncoded
  | MTOctetStream
  | MTAny
  | MTOther Text
  -- vendored media types
  | MTVndArrayJSONStrip
  | MTVndSingularJSON Bool
  -- TODO MTVndPlan should only have its options as [Text]. Its ResultAggregate should have the typed attributes.
  | MTVndPlan MediaType MTVndPlanFormat [MTVndPlanOption]
  deriving (Eq, Show, Generic, JSON.ToJSON)
instance Hashable MediaType

data MTVndPlanOption
  = PlanAnalyze | PlanVerbose | PlanSettings | PlanBuffers | PlanWAL
  deriving (Eq, Show, Generic, JSON.ToJSON)
instance Hashable MTVndPlanOption

data MTVndPlanFormat
  = PlanJSON | PlanText
  deriving (Eq, Show, Generic, JSON.ToJSON)
instance Hashable MTVndPlanFormat

-- | Convert MediaType to a Content-Type HTTP Header
toContentType :: MediaType -> Header
toContentType ct = (hContentType, toMime ct <> charset)
  where
    charset = case ct of
      MTOctetStream -> mempty
      MTOther _     -> mempty
      _             -> "; charset=utf-8"

-- | Convert from MediaType to a ByteString representing the mime type
toMime :: MediaType -> ByteString
toMime MTApplicationJSON      = "application/json"
toMime MTVndArrayJSONStrip    = "application/vnd.pgrst.array+json;nulls=stripped"
toMime MTGeoJSON              = "application/geo+json"
toMime MTTextCSV              = "text/csv"
toMime MTTextPlain            = "text/plain"
toMime MTTextXML              = "text/xml"
toMime MTOpenAPI              = "application/openapi+json"
toMime (MTVndSingularJSON True)  = "application/vnd.pgrst.object+json;nulls=stripped"
toMime (MTVndSingularJSON False) = "application/vnd.pgrst.object+json"
toMime MTUrlEncoded           = "application/x-www-form-urlencoded"
toMime MTOctetStream          = "application/octet-stream"
toMime MTAny                  = "*/*"
toMime (MTOther ct)           = encodeUtf8 ct
toMime (MTVndPlan mt fmt opts)   =
  "application/vnd.pgrst.plan+" <> toMimePlanFormat fmt <>
  ("; for=\"" <> toMime mt <> "\"") <>
  (if null opts then mempty else "; options=" <> BS.intercalate "|" (toMimePlanOption <$> opts))

toMimePlanOption :: MTVndPlanOption -> ByteString
toMimePlanOption PlanAnalyze  = "analyze"
toMimePlanOption PlanVerbose  = "verbose"
toMimePlanOption PlanSettings = "settings"
toMimePlanOption PlanBuffers  = "buffers"
toMimePlanOption PlanWAL      = "wal"

toMimePlanFormat :: MTVndPlanFormat -> ByteString
toMimePlanFormat PlanJSON = "json"
toMimePlanFormat PlanText = "text"

-- | Convert from ByteString to MediaType.
--
-- >>> decodeMediaType "application/json"
-- MTApplicationJSON
--
-- >>> decodeMediaType "application/vnd.pgrst.plan;"
-- MTVndPlan MTApplicationJSON PlanText []
--
-- >>> decodeMediaType "application/vnd.pgrst.plan;for=\"application/json\""
-- MTVndPlan MTApplicationJSON PlanText []
--
-- >>> decodeMediaType "application/vnd.pgrst.plan ; for=\"text/xml\" ; options=analyze"
-- MTVndPlan MTTextXML PlanText [PlanAnalyze]
--
-- >>> decodeMediaType "application/vnd.pgrst.plan+json;for=\"text/csv\""
-- MTVndPlan MTTextCSV PlanJSON []
--
-- >>> decodeMediaType "application/vnd.pgrst.array+json;nulls=stripped"
-- MTVndArrayJSONStrip
--
-- >>> decodeMediaType "application/vnd.pgrst.array+json"
-- MTApplicationJSON
--
-- >>> decodeMediaType "application/vnd.pgrst.object+json;nulls=stripped"
-- MTVndSingularJSON True
--
-- >>> decodeMediaType "application/vnd.pgrst.object+json"
-- MTVndSingularJSON False
--
-- Test uppercase is parsed correctly (per issue #3478)
-- >>> decodeMediaType "ApplicatIon/vnd.PgRsT.object+json"
-- MTVndSingularJSON False
--
-- >>> decodeMediaType "application/vnd.twkb"
-- MTOther "application/vnd.twkb"

decodeMediaType :: ByteString -> MediaType
decodeMediaType mt = decodeMediaType' $ decodeLatin1 mt
  where
    decodeMediaType' :: Text -> MediaType
    decodeMediaType' mt' =
      case (T.toLower mainType, T.toLower subType, params) of
        ("application", "json", _)                  -> MTApplicationJSON
        ("application", "geo+json", _)              -> MTGeoJSON
        ("text", "csv", _)                          -> MTTextCSV
        ("text", "plain", _)                        -> MTTextPlain
        ("text", "xml", _)                          -> MTTextXML
        ("application", "openapi+json", _)          -> MTOpenAPI
        ("application", "x-www-form-urlencoded", _) -> MTUrlEncoded
        ("application", "octet-stream", _)          -> MTOctetStream
        ("application", "vnd.pgrst.plan", _)        -> getPlan PlanText
        ("application", "vnd.pgrst.plan+text", _)   -> getPlan PlanText
        ("application", "vnd.pgrst.plan+json", _)   -> getPlan PlanJSON
        ("application", "vnd.pgrst.object+json", _) -> MTVndSingularJSON strippedNulls
        ("application", "vnd.pgrst.object", _)      -> MTVndSingularJSON strippedNulls
        ("application", "vnd.pgrst.array+json", _)  -> checkArrayNullStrip
        ("application", "vnd.pgrst.array", _)       -> checkArrayNullStrip
        ("*","*",_)                                 -> MTAny
        _                                           -> MTOther mt'
      where
        mediaTypeOrError = P.parse tokenizeMediaType "parsec: tokenizeMediaType failed" $ T.unpack mt'
        (mainType, subType, params') = case mediaTypeOrError of
          Right mt'' -> mt''
          Left _     -> (mt',"",[])
        params = fromList $ map (first T.toLower) params' -- normalize parameter names to lowercase, per RFC 7321
        getPlan fmt = MTVndPlan mtFor fmt $
          [PlanAnalyze  | inOpts "analyze" ] ++
          [PlanVerbose  | inOpts "verbose" ] ++
          [PlanSettings | inOpts "settings"] ++
          [PlanBuffers  | inOpts "buffers" ] ++
          [PlanWAL      | inOpts "wal"     ]
          where
            mtFor = decodeMediaType' $ fromMaybe "application/json" (params !? "for")
            inOpts str = str `elem` opts
            opts = T.splitOn "|" $ fromMaybe mempty (params !? "options")
        strippedNulls = fromMaybe "false" (params !? "nulls") == "stripped"
        checkArrayNullStrip = if strippedNulls then MTVndArrayJSONStrip else MTApplicationJSON

-- | Split a Media Type string into components
-- >>> P.parse tokenizeMediaType "" "application/vnd.pgrst.plan+json;for=\"text/csv\""
-- Right ("application","vnd.pgrst.plan+json",[("for","text/csv")])
--
-- >>> P.parse tokenizeMediaType "" "*/*"
-- Right ("*","*",[])
--
-- >>> P.parse tokenizeMediaType "" "application/vnd.pgrst.plan;wat=\"application/json;text/csv\""
-- Right ("application","vnd.pgrst.plan",[("wat","application/json;text/csv")])
--
-- >>> P.parse tokenizeMediaType "" "application/vnd.pgrst.plan+text; for=\"text/xml\"; options=analyze|verbose|settings|buffers|wal"
-- Right ("application","vnd.pgrst.plan+text",[("for","text/xml"),("options","analyze|verbose|settings|buffers|wal")])

-- TODO: Improve mediatype parser as per RFC 2045 https://datatracker.ietf.org/doc/html/rfc2045#section-5.1
tokenizeMediaType :: P.Parser (Text, Text, [(Text, Text)])
tokenizeMediaType = do
  mainType <- P.many1 (P.alphaNum <|> P.oneOf ".*")
  P.char '/'
  subType <- P.many1 (P.alphaNum <|> P.oneOf ".*+-")
  params <- P.many pSemicolonSeparatedKeyVals
  P.optional $ P.try $ P.spaces *> P.char ';' -- ending semicolon, discard input after that because it has already failed or we have hit EOF
  return (T.pack mainType, T.pack subType, params)
    where
      pSemicolonSeparatedKeyVals :: P.Parser (Text, Text)
      pSemicolonSeparatedKeyVals = P.try $ P.spaces *> P.char ';' *> P.spaces *> pKeyVal
        where
          pKeyVal :: P.Parser (Text, Text)
          pKeyVal = do
            key <- P.many1 (P.alphaNum <|> P.oneOf "-")
            P.spaces
            P.char '='
            P.spaces
            val <- P.try pQuoted <|> P.try pUnQuoted
            return (T.pack key, T.pack val)
              where
                pUnQuoted = P.many1 (P.alphaNum <|> P.oneOf "|-")
                pQuoted = P.char '\"' *> P.manyTill P.anyChar (P.char '\"')