module Dormouse.Client.Headers.MediaType 
  ( MediaType(..)
  , ContentType(..)
  , MediaTypeException
  , parseMediaType
  , encodeMediaType
  , applicationJson
  , applicationXWWWFormUrlEncoded
  , textHtml
  ) where

import Control.Exception.Safe (MonadThrow, throw)
import Control.Applicative ((<|>))
import qualified Data.ByteString as B
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.CaseInsensitive  (CI, mk, foldedCase)
import Dormouse.Client.Exception (MediaTypeException(..))
import qualified Data.Char as C
import qualified Data.Text as T
import qualified Data.Map.Strict as Map

-- | A Media Type indicates the format of content which can be transferred over the wire
data MediaType = MediaType 
  { MediaType -> ContentType
mainType :: ContentType -- ^ The general category of data associated with this Media Type
  , MediaType -> CI ByteString
subType :: CI B.ByteString -- ^ The subtype indicates the exact subtype of data associated with this Media Type
  , MediaType -> [CI ByteString]
suffixes :: [CI B.ByteString] -- ^ The suffixes specify additional information on the structure of this Media Type
  , MediaType -> Map (CI ByteString) ByteString
parameters :: Map.Map (CI B.ByteString) B.ByteString -- ^ Parameters serve to modify the content subtype specifying additional information, e.g. the @charset@
  } deriving (MediaType -> MediaType -> Bool
(MediaType -> MediaType -> Bool)
-> (MediaType -> MediaType -> Bool) -> Eq MediaType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MediaType -> MediaType -> Bool
$c/= :: MediaType -> MediaType -> Bool
== :: MediaType -> MediaType -> Bool
$c== :: MediaType -> MediaType -> Bool
Eq, Int -> MediaType -> ShowS
[MediaType] -> ShowS
MediaType -> String
(Int -> MediaType -> ShowS)
-> (MediaType -> String)
-> ([MediaType] -> ShowS)
-> Show MediaType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MediaType] -> ShowS
$cshowList :: [MediaType] -> ShowS
show :: MediaType -> String
$cshow :: MediaType -> String
showsPrec :: Int -> MediaType -> ShowS
$cshowsPrec :: Int -> MediaType -> ShowS
Show)

data ContentType
  = Text
  | Image
  | Audio
  | Video
  | Application
  | Multipart
  | Other (CI B.ByteString)
  deriving (ContentType -> ContentType -> Bool
(ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> Bool) -> Eq ContentType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContentType -> ContentType -> Bool
$c/= :: ContentType -> ContentType -> Bool
== :: ContentType -> ContentType -> Bool
$c== :: ContentType -> ContentType -> Bool
Eq, Int -> ContentType -> ShowS
[ContentType] -> ShowS
ContentType -> String
(Int -> ContentType -> ShowS)
-> (ContentType -> String)
-> ([ContentType] -> ShowS)
-> Show ContentType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContentType] -> ShowS
$cshowList :: [ContentType] -> ShowS
show :: ContentType -> String
$cshow :: ContentType -> String
showsPrec :: Int -> ContentType -> ShowS
$cshowsPrec :: Int -> ContentType -> ShowS
Show)

-- | Encode a Media Type as an ASCII ByteString
encodeMediaType :: MediaType -> B.ByteString
encodeMediaType :: MediaType -> ByteString
encodeMediaType MediaType
mediaType =
  let mainTypeBs :: ByteString
mainTypeBs = CI ByteString -> ByteString
forall s. CI s -> s
foldedCase (CI ByteString -> ByteString)
-> (ContentType -> CI ByteString) -> ContentType -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentType -> CI ByteString
mainTypeAsByteString (ContentType -> ByteString) -> ContentType -> ByteString
forall a b. (a -> b) -> a -> b
$ MediaType -> ContentType
mainType MediaType
mediaType
      subTypeBs :: ByteString
subTypeBs = CI ByteString -> ByteString
forall s. CI s -> s
foldedCase (CI ByteString -> ByteString) -> CI ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ MediaType -> CI ByteString
subType MediaType
mediaType
      suffixesBs :: [ByteString]
suffixesBs = (CI ByteString -> ByteString) -> [CI ByteString] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\CI ByteString
x -> ByteString
"+" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> CI ByteString -> ByteString
forall s. CI s -> s
foldedCase CI ByteString
x) ([CI ByteString] -> [ByteString])
-> [CI ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ MediaType -> [CI ByteString]
suffixes MediaType
mediaType
      paramsBs :: ByteString
paramsBs = (ByteString -> CI ByteString -> ByteString -> ByteString)
-> ByteString -> Map (CI ByteString) ByteString -> ByteString
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (\ByteString
acc CI ByteString
k ByteString
v -> ByteString
acc ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"; " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> CI ByteString -> ByteString
forall s. CI s -> s
foldedCase CI ByteString
k ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
v) ByteString
"" (Map (CI ByteString) ByteString -> ByteString)
-> Map (CI ByteString) ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ MediaType -> Map (CI ByteString) ByteString
parameters MediaType
mediaType
  in ByteString
mainTypeBs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
subTypeBs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> ByteString
B.concat [ByteString]
suffixesBs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
paramsBs
  where 
    mainTypeAsByteString :: ContentType -> CI ByteString
mainTypeAsByteString ContentType
Text        = CI ByteString
"text"
    mainTypeAsByteString ContentType
Image       = CI ByteString
"image"
    mainTypeAsByteString ContentType
Audio       = CI ByteString
"audio"
    mainTypeAsByteString ContentType
Video       = CI ByteString
"video"
    mainTypeAsByteString ContentType
Application = CI ByteString
"application"
    mainTypeAsByteString ContentType
Multipart   = CI ByteString
"multipart"
    mainTypeAsByteString (Other CI ByteString
x)   = CI ByteString
x

-- | Parse a Media Type from an ASCII ByteString
parseMediaType :: MonadThrow m => B.ByteString -> m MediaType
parseMediaType :: ByteString -> m MediaType
parseMediaType ByteString
bs = (String -> m MediaType)
-> (MediaType -> m MediaType)
-> Either String MediaType
-> m MediaType
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (MediaTypeException -> m MediaType
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (MediaTypeException -> m MediaType)
-> (String -> MediaTypeException) -> String -> m MediaType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MediaTypeException
MediaTypeException (Text -> MediaTypeException)
-> (String -> Text) -> String -> MediaTypeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) MediaType -> m MediaType
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String MediaType -> m MediaType)
-> Either String MediaType -> m MediaType
forall a b. (a -> b) -> a -> b
$ Parser MediaType -> ByteString -> Either String MediaType
forall a. Parser a -> ByteString -> Either String a
A.parseOnly Parser MediaType
pMediaType ByteString
bs

-- | The @application/json@ Media Type
applicationJson :: MediaType
applicationJson :: MediaType
applicationJson = MediaType :: ContentType
-> CI ByteString
-> [CI ByteString]
-> Map (CI ByteString) ByteString
-> MediaType
MediaType 
  { mainType :: ContentType
mainType = ContentType
Application
  , subType :: CI ByteString
subType = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
"json"
  , suffixes :: [CI ByteString]
suffixes = []
  , parameters :: Map (CI ByteString) ByteString
parameters = Map (CI ByteString) ByteString
forall k a. Map k a
Map.empty
  }

-- | The @application/x-www-form-urlencoded@ Media Type
applicationXWWWFormUrlEncoded :: MediaType
applicationXWWWFormUrlEncoded :: MediaType
applicationXWWWFormUrlEncoded = MediaType :: ContentType
-> CI ByteString
-> [CI ByteString]
-> Map (CI ByteString) ByteString
-> MediaType
MediaType 
  { mainType :: ContentType
mainType = ContentType
Application
  , subType :: CI ByteString
subType = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
"x-www-form-urlencoded"
  , suffixes :: [CI ByteString]
suffixes = []
  , parameters :: Map (CI ByteString) ByteString
parameters = Map (CI ByteString) ByteString
forall k a. Map k a
Map.empty
  }

-- | The @text/html@ Media Type
textHtml :: MediaType
textHtml :: MediaType
textHtml = MediaType :: ContentType
-> CI ByteString
-> [CI ByteString]
-> Map (CI ByteString) ByteString
-> MediaType
MediaType 
  { mainType :: ContentType
mainType = ContentType
Text
  , subType :: CI ByteString
subType = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
"html"
  , suffixes :: [CI ByteString]
suffixes = []
  , parameters :: Map (CI ByteString) ByteString
parameters = Map (CI ByteString) ByteString
forall k a. Map k a
Map.empty
  }

pContentType :: A.Parser ContentType
pContentType :: Parser ContentType
pContentType = 
  (ByteString -> ContentType)
-> Parser ByteString ByteString -> Parser ContentType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CI ByteString -> ContentType
convertContentType (CI ByteString -> ContentType)
-> (ByteString -> CI ByteString) -> ByteString -> ContentType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk) (Parser ByteString ByteString -> Parser ContentType)
-> Parser ByteString ByteString -> Parser ContentType
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser ByteString ByteString
A.takeWhile1 Char -> Bool
isAsciiAlpha
  where 
    convertContentType :: CI B.ByteString -> ContentType
    convertContentType :: CI ByteString -> ContentType
convertContentType CI ByteString
"text"        = ContentType
Text
    convertContentType CI ByteString
"image"       = ContentType
Image
    convertContentType CI ByteString
"audio"       = ContentType
Audio
    convertContentType CI ByteString
"video"       = ContentType
Video
    convertContentType CI ByteString
"application" = ContentType
Application
    convertContentType CI ByteString
"multipart"   = ContentType
Multipart
    convertContentType CI ByteString
x             = CI ByteString -> ContentType
Other CI ByteString
x

pSubType :: A.Parser (CI B.ByteString)
pSubType :: Parser (CI ByteString)
pSubType = (ByteString -> CI ByteString)
-> Parser ByteString ByteString -> Parser (CI ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk (Parser ByteString ByteString -> Parser (CI ByteString))
-> Parser ByteString ByteString -> Parser (CI ByteString)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser ByteString ByteString
A.takeWhile1 Char -> Bool
isSubtypeChar

pSuffix :: A.Parser (CI B.ByteString)
pSuffix :: Parser (CI ByteString)
pSuffix = (ByteString -> CI ByteString)
-> Parser ByteString ByteString -> Parser (CI ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk (Parser ByteString ByteString -> Parser (CI ByteString))
-> Parser ByteString ByteString -> Parser (CI ByteString)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser ByteString ByteString
A.takeWhile1 Char -> Bool
isAsciiAlpha

pMediaType :: A.Parser MediaType
pMediaType :: Parser MediaType
pMediaType = do
  ContentType
mainType' <- Parser ContentType
pContentType
  Char
_ <- Char -> Parser Char
A.char Char
'/'
  CI ByteString
subType' <- Parser (CI ByteString)
pSubType
  [CI ByteString]
suffixes' <- Parser (CI ByteString)
pSuffix Parser (CI ByteString)
-> Parser Char -> Parser ByteString [CI ByteString]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`A.sepBy` Char -> Parser Char
A.char Char
'+'
  [(CI ByteString, ByteString)]
parameters' <- Parser ByteString (CI ByteString, ByteString)
-> Parser ByteString [(CI ByteString, ByteString)]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
A.many' (Char -> Parser Char
A.char Char
';' Parser Char -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ()
A.skipSpace Parser ByteString ()
-> Parser ByteString (CI ByteString, ByteString)
-> Parser ByteString (CI ByteString, ByteString)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString (CI ByteString, ByteString)
pParam)
  MediaType -> Parser MediaType
forall (m :: * -> *) a. Monad m => a -> m a
return (MediaType -> Parser MediaType) -> MediaType -> Parser MediaType
forall a b. (a -> b) -> a -> b
$ MediaType :: ContentType
-> CI ByteString
-> [CI ByteString]
-> Map (CI ByteString) ByteString
-> MediaType
MediaType { mainType :: ContentType
mainType = ContentType
mainType', subType :: CI ByteString
subType = CI ByteString
subType', suffixes :: [CI ByteString]
suffixes = [CI ByteString]
suffixes', parameters :: Map (CI ByteString) ByteString
parameters = [(CI ByteString, ByteString)] -> Map (CI ByteString) ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(CI ByteString, ByteString)]
parameters'}

-- | Checks whether a char is ascii & alpha
isAsciiAlpha :: Char -> Bool
isAsciiAlpha :: Char -> Bool
isAsciiAlpha Char
c = Char -> Bool
C.isAlpha Char
c Bool -> Bool -> Bool
&& Char -> Bool
C.isAscii Char
c

isSpecial :: Char -> Bool
isSpecial :: Char -> Bool
isSpecial Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'@' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'[' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
']' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'?' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'='

isTokenChar :: Char -> Bool
isTokenChar :: Char -> Bool
isTokenChar Char
c = (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isSpecial Char
c) Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
C.isSpace Char
c) Bool -> Bool -> Bool
&& Char -> Bool
C.isAscii Char
c Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
C.isControl Char
c)

isQuotedChar :: Char -> Bool
isQuotedChar :: Char -> Bool
isQuotedChar Char
c = Char -> Bool
C.isAscii Char
c Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
C.isControl Char
c)

isSubtypeChar :: Char -> Bool
isSubtypeChar :: Char -> Bool
isSubtypeChar Char
c = (Char -> Bool
isTokenChar Char
c) Bool -> Bool -> Bool
&& (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'+')

pTokens :: A.Parser B.ByteString
pTokens :: Parser ByteString ByteString
pTokens = (Char -> Bool) -> Parser ByteString ByteString
A.takeWhile1 Char -> Bool
isTokenChar

pQuotedString :: A.Parser B.ByteString
pQuotedString :: Parser ByteString ByteString
pQuotedString = Char -> Parser Char
A.char Char
'"' Parser Char
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString ByteString
A.takeWhile Char -> Bool
isQuotedChar Parser ByteString ByteString
-> Parser Char -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
A.char Char
'"'

pParam :: A.Parser (CI B.ByteString, B.ByteString)
pParam :: Parser ByteString (CI ByteString, ByteString)
pParam = do
  ByteString
attribute <- Parser ByteString ByteString
pTokens
  Char
_ <- Char -> Parser Char
A.char Char
'='
  ByteString
value <- Parser ByteString ByteString
pTokens Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
pQuotedString
  (CI ByteString, ByteString)
-> Parser ByteString (CI ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
attribute, ByteString
value)