{-# LANGUAGE OverloadedStrings #-}

module Network.Wai.Predicate.Parser.MediaType
    ( MediaType (..)
    , readMediaTypes
    ) where

import Control.Applicative
import Data.Attoparsec.ByteString.Char8
import Data.ByteString (ByteString)
import Data.List (sortBy)
import Network.HTTP.Types
import Network.Wai.Predicate.Request

import qualified Data.ByteString.Char8 as C

data MediaType = MediaType
    { MediaType -> ByteString
medType    :: !ByteString
    , MediaType -> ByteString
medSubtype :: !ByteString
    , MediaType -> Double
medQuality :: !Double
    , MediaType -> [(ByteString, ByteString)]
medParams  :: ![(ByteString, ByteString)]
    } 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)

readMediaTypes :: (HasHeaders r) => HeaderName -> r -> [MediaType]
readMediaTypes :: HeaderName -> r -> [MediaType]
readMediaTypes HeaderName
k r
r =
    (MediaType -> MediaType -> Ordering) -> [MediaType] -> [MediaType]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy MediaType -> MediaType -> Ordering
q ([MediaType] -> [MediaType])
-> ([ByteString] -> [MediaType]) -> [ByteString] -> [MediaType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> [MediaType]) -> [ByteString] -> [MediaType]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ByteString -> [MediaType]
parseMediaTypes ([ByteString] -> [MediaType]) -> [ByteString] -> [MediaType]
forall a b. (a -> b) -> a -> b
$ HeaderName -> r -> [ByteString]
forall r. HasHeaders r => HeaderName -> r -> [ByteString]
lookupHeader HeaderName
k r
r
  where
    q :: MediaType -> MediaType -> Ordering
q MediaType
a MediaType
b = MediaType -> Double
medQuality MediaType
b Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` MediaType -> Double
medQuality MediaType
a

parseMediaTypes :: ByteString -> [MediaType]
parseMediaTypes :: ByteString -> [MediaType]
parseMediaTypes = (String -> [MediaType])
-> ([MediaType] -> [MediaType])
-> Either String [MediaType]
-> [MediaType]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([MediaType] -> String -> [MediaType]
forall a b. a -> b -> a
const []) [MediaType] -> [MediaType]
forall a. a -> a
id (Either String [MediaType] -> [MediaType])
-> (ByteString -> Either String [MediaType])
-> ByteString
-> [MediaType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser [MediaType] -> ByteString -> Either String [MediaType]
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser [MediaType]
mediaTypes

mediaTypes :: Parser [MediaType]
mediaTypes :: Parser [MediaType]
mediaTypes = Parser MediaType
mediaType Parser MediaType -> Parser ByteString Char -> Parser [MediaType]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Char -> Parser ByteString Char
char Char
','

mediaType :: Parser MediaType
mediaType :: Parser MediaType
mediaType =
    ByteString -> ByteString -> [(ByteString, ByteString)] -> MediaType
toMediaType (ByteString
 -> ByteString -> [(ByteString, ByteString)] -> MediaType)
-> Parser ByteString ByteString
-> Parser
     ByteString (ByteString -> [(ByteString, ByteString)] -> MediaType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString -> Parser ByteString ByteString
forall a. Parser a -> Parser a
trim Parser ByteString ByteString
typ Parser
  ByteString (ByteString -> [(ByteString, ByteString)] -> MediaType)
-> Parser ByteString ByteString
-> Parser ByteString ([(ByteString, ByteString)] -> MediaType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Parser ByteString Char
char Char
'/' Parser ByteString Char
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString -> Parser ByteString ByteString
forall a. Parser a -> Parser a
trim Parser ByteString ByteString
subtyp) Parser ByteString ([(ByteString, ByteString)] -> MediaType)
-> Parser ByteString [(ByteString, ByteString)] -> Parser MediaType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString [(ByteString, ByteString)]
params
  where
    toMediaType :: ByteString -> ByteString -> [(ByteString, ByteString)] -> MediaType
toMediaType ByteString
t ByteString
s [(ByteString, ByteString)]
p =
        case ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"q" [(ByteString, ByteString)]
p Maybe ByteString -> (ByteString -> Maybe Double) -> Maybe Double
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe Double
toDouble of
            Just Double
q  -> ByteString
-> ByteString -> Double -> [(ByteString, ByteString)] -> MediaType
MediaType ByteString
t ByteString
s Double
q (((ByteString, ByteString) -> Bool)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"q") (ByteString -> Bool)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst) [(ByteString, ByteString)]
p)
            Maybe Double
Nothing -> ByteString
-> ByteString -> Double -> [(ByteString, ByteString)] -> MediaType
MediaType ByteString
t ByteString
s Double
1.0 [(ByteString, ByteString)]
p

params :: Parser [(ByteString, ByteString)]
params :: Parser ByteString [(ByteString, ByteString)]
params = (Parser ByteString Char -> Parser ByteString Char
forall a. Parser a -> Parser a
trim (Char -> Parser ByteString Char
char Char
';') Parser ByteString Char
-> Parser ByteString [(ByteString, ByteString)]
-> Parser ByteString [(ByteString, ByteString)]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser ByteString (ByteString, ByteString)
element Parser ByteString (ByteString, ByteString)
-> Parser ByteString Char
-> Parser ByteString [(ByteString, ByteString)]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Parser ByteString Char -> Parser ByteString Char
forall a. Parser a -> Parser a
trim (Char -> Parser ByteString Char
char Char
';'))) Parser ByteString [(ByteString, ByteString)]
-> Parser ByteString [(ByteString, ByteString)]
-> Parser ByteString [(ByteString, ByteString)]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [(ByteString, ByteString)]
-> Parser ByteString [(ByteString, ByteString)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  where
    element :: Parser ByteString (ByteString, ByteString)
element = (,) (ByteString -> ByteString -> (ByteString, ByteString))
-> Parser ByteString ByteString
-> Parser ByteString (ByteString -> (ByteString, ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString -> Parser ByteString ByteString
forall a. Parser a -> Parser a
trim Parser ByteString ByteString
key Parser ByteString (ByteString -> (ByteString, ByteString))
-> Parser ByteString ByteString
-> Parser ByteString (ByteString, ByteString)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Parser ByteString Char
char Char
'=' Parser ByteString Char
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString -> Parser ByteString ByteString
forall a. Parser a -> Parser a
trim Parser ByteString ByteString
val)

typ, subtyp, key, val :: Parser ByteString
typ :: Parser ByteString ByteString
typ    = (Char -> Bool) -> Parser ByteString ByteString
takeTill (ByteString -> Char -> Bool
oneof ByteString
"/ ")
subtyp :: Parser ByteString ByteString
subtyp = (Char -> Bool) -> Parser ByteString ByteString
takeTill (ByteString -> Char -> Bool
oneof ByteString
",; ")

key :: Parser ByteString ByteString
key = do
    Maybe Char
c <- Parser (Maybe Char)
peekChar
    if Maybe Char
c Maybe Char -> Maybe Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Maybe Char
forall a. a -> Maybe a
Just Char
',' then String -> Parser ByteString ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"comma" else (Char -> Bool) -> Parser ByteString ByteString
takeTill (ByteString -> Char -> Bool
oneof ByteString
"= ")

val :: Parser ByteString ByteString
val = (Char -> Bool) -> Parser ByteString ByteString
takeTill (ByteString -> Char -> Bool
oneof ByteString
",; ")

toDouble :: ByteString -> Maybe Double
toDouble :: ByteString -> Maybe Double
toDouble ByteString
bs = Either String Double -> Maybe Double
forall a a. Either a a -> Maybe a
toMaybe (Parser Double -> ByteString -> Either String Double
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser Double
double ByteString
bs)
  where
    toMaybe :: Either a a -> Maybe a
toMaybe (Right a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
    toMaybe (Left  a
_) = Maybe a
forall a. Maybe a
Nothing

spaces :: Parser ()
spaces :: Parser ()
spaces = (Char -> Bool) -> Parser ()
skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')

trim :: Parser a -> Parser a
trim :: Parser a -> Parser a
trim Parser a
p = Parser ()
spaces Parser () -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p Parser a -> Parser () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
spaces

oneof :: ByteString -> Char -> Bool
oneof :: ByteString -> Char -> Bool
oneof ByteString
s Char
c = (Char -> Bool) -> ByteString -> Bool
C.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) ByteString
s