module Network.CGI.Accept (
Acceptable
, Accept
, Charset(..), ContentEncoding(..), Language(..)
, negotiate
) where
import Data.Function
import Data.List
import Data.Maybe
import Numeric
import Text.ParserCombinators.Parsec
import Network.Multipart
import Network.Multipart.Header
newtype Accept a = Accept [(a, Quality)]
deriving (Int -> Accept a -> ShowS
forall a. Show a => Int -> Accept a -> ShowS
forall a. Show a => [Accept a] -> ShowS
forall a. Show a => Accept a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Accept a] -> ShowS
$cshowList :: forall a. Show a => [Accept a] -> ShowS
show :: Accept a -> String
$cshow :: forall a. Show a => Accept a -> String
showsPrec :: Int -> Accept a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Accept a -> ShowS
Show)
type Quality = Double
class Eq a => Acceptable a where
includes :: a -> a -> Bool
instance HeaderValue a => HeaderValue (Accept a) where
parseHeaderValue :: Parser (Accept a)
parseHeaderValue = forall a. [(a, Quality)] -> Accept a
Accept forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy ParsecT String () Identity (a, Quality)
p (forall a. Parser a -> Parser a
lexeme (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
','))
where p :: ParsecT String () Identity (a, Quality)
p = do a
a <- forall a. HeaderValue a => Parser a
parseHeaderValue
Quality
q <- forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Quality
1 forall a b. (a -> b) -> a -> b
$ do Char
_ <- forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
';'
Char
_ <- forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'q'
Char
_ <- forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'='
forall a. Parser a -> Parser a
lexeme forall {u}. ParsecT String u Identity Quality
pQuality
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,Quality
q)
pQuality :: ParsecT String u Identity Quality
pQuality = (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'0' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option String
"0" (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
ds -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Read a => String -> a
read (String
"0." forall a. [a] -> [a] -> [a]
++ String
ds forall a. [a] -> [a] -> [a]
++ String
"0")))
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'1' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'0')) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Quality
1)
prettyHeaderValue :: Accept a -> String
prettyHeaderValue (Accept [(a, Quality)]
xs) = forall a. [a] -> [[a]] -> [a]
intercalate String
", " [forall a. HeaderValue a => a -> String
prettyHeaderValue a
a forall a. [a] -> [a] -> [a]
++ String
"; q=" forall a. [a] -> [a] -> [a]
++ forall {a}. RealFloat a => a -> String
showQuality Quality
q | (a
a,Quality
q) <- [(a, Quality)]
xs]
where showQuality :: a -> String
showQuality a
q = forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloat (forall a. a -> Maybe a
Just Int
3) a
q String
""
starOrEqualTo :: String -> String -> Bool
starOrEqualTo :: String -> String -> Bool
starOrEqualTo String
x String
y = String
x forall a. Eq a => a -> a -> Bool
== String
"*" Bool -> Bool -> Bool
|| String
x forall a. Eq a => a -> a -> Bool
== String
y
negotiate :: Acceptable a => [a] -> Maybe (Accept a) -> [a]
negotiate :: forall a. Acceptable a => [a] -> Maybe (Accept a) -> [a]
negotiate [a]
ys Maybe (Accept a)
Nothing = [a]
ys
negotiate [a]
ys (Just Accept a
xs) = forall a. [a] -> [a]
reverse [ a
z | (Quality
q,a
z) <- forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) [ (forall a. Acceptable a => Accept a -> a -> Quality
quality Accept a
xs a
y,a
y) | a
y <- [a]
ys], Quality
q forall a. Ord a => a -> a -> Bool
> Quality
0]
quality :: Acceptable a => Accept a -> a -> Quality
quality :: forall a. Acceptable a => Accept a -> a -> Quality
quality (Accept [(a, Quality)]
xs) a
y = forall a. a -> Maybe a -> a
fromMaybe Quality
0 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Acceptable a => a -> a -> Ordering
compareSpecificity forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Acceptable a => a -> a -> Bool
`includes` a
y) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(a, Quality)]
xs
compareSpecificity :: Acceptable a => a -> a -> Ordering
compareSpecificity :: forall a. Acceptable a => a -> a -> Ordering
compareSpecificity a
x a
y
| a
x forall a. Acceptable a => a -> a -> Bool
`includes` a
y Bool -> Bool -> Bool
&& a
y forall a. Acceptable a => a -> a -> Bool
`includes` a
x = Ordering
EQ
| a
x forall a. Acceptable a => a -> a -> Bool
`includes` a
y = Ordering
GT
| a
y forall a. Acceptable a => a -> a -> Bool
`includes` a
x = Ordering
LT
| Bool
otherwise = forall a. HasCallStack => String -> a
error String
"Non-comparable Acceptables"
instance Acceptable ContentType where
includes :: ContentType -> ContentType -> Bool
includes ContentType
x ContentType
y = ContentType -> String
ctType ContentType
x String -> String -> Bool
`starOrEqualTo` ContentType -> String
ctType ContentType
y
Bool -> Bool -> Bool
&& ContentType -> String
ctSubtype ContentType
x String -> String -> Bool
`starOrEqualTo` ContentType -> String
ctSubtype ContentType
y
Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ContentType -> (String, String) -> Bool
hasParameter ContentType
y) (ContentType -> [(String, String)]
ctParameters ContentType
x)
hasParameter :: ContentType -> (String, String) -> Bool
hasParameter :: ContentType -> (String, String) -> Bool
hasParameter ContentType
t (String
k,String
v) = (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just String
v) forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
k (ContentType -> [(String, String)]
ctParameters ContentType
t)
newtype Charset = Charset String
deriving (Int -> Charset -> ShowS
[Charset] -> ShowS
Charset -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Charset] -> ShowS
$cshowList :: [Charset] -> ShowS
show :: Charset -> String
$cshow :: Charset -> String
showsPrec :: Int -> Charset -> ShowS
$cshowsPrec :: Int -> Charset -> ShowS
Show)
instance Eq Charset where
Charset String
x == :: Charset -> Charset -> Bool
== Charset String
y = String -> String -> Bool
caseInsensitiveEq String
x String
y
instance Ord Charset where
Charset String
x compare :: Charset -> Charset -> Ordering
`compare` Charset String
y = String -> String -> Ordering
caseInsensitiveCompare String
x String
y
instance HeaderValue Charset where
parseHeaderValue :: Parser Charset
parseHeaderValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Charset
Charset forall a b. (a -> b) -> a -> b
$ forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser Char
ws1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Parser a -> Parser a
lexeme ParsecT String () Identity String
p_token
prettyHeaderValue :: Charset -> String
prettyHeaderValue (Charset String
s) = String
s
instance Acceptable Charset where
Charset String
x includes :: Charset -> Charset -> Bool
`includes` Charset String
y = String -> String -> Bool
starOrEqualTo String
x String
y
newtype ContentEncoding = ContentEncoding String
deriving (Int -> ContentEncoding -> ShowS
[ContentEncoding] -> ShowS
ContentEncoding -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContentEncoding] -> ShowS
$cshowList :: [ContentEncoding] -> ShowS
show :: ContentEncoding -> String
$cshow :: ContentEncoding -> String
showsPrec :: Int -> ContentEncoding -> ShowS
$cshowsPrec :: Int -> ContentEncoding -> ShowS
Show)
instance Eq ContentEncoding where
ContentEncoding String
x == :: ContentEncoding -> ContentEncoding -> Bool
== ContentEncoding String
y = String -> String -> Bool
caseInsensitiveEq String
x String
y
instance Ord ContentEncoding where
ContentEncoding String
x compare :: ContentEncoding -> ContentEncoding -> Ordering
`compare` ContentEncoding String
y = String -> String -> Ordering
caseInsensitiveCompare String
x String
y
instance HeaderValue ContentEncoding where
parseHeaderValue :: Parser ContentEncoding
parseHeaderValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> ContentEncoding
ContentEncoding forall a b. (a -> b) -> a -> b
$ forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser Char
ws1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Parser a -> Parser a
lexeme ParsecT String () Identity String
p_token
prettyHeaderValue :: ContentEncoding -> String
prettyHeaderValue (ContentEncoding String
s) = String
s
instance Acceptable ContentEncoding where
ContentEncoding String
x includes :: ContentEncoding -> ContentEncoding -> Bool
`includes` ContentEncoding String
y = String -> String -> Bool
starOrEqualTo String
x String
y
newtype Language = Language String
deriving (Int -> Language -> ShowS
[Language] -> ShowS
Language -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Language] -> ShowS
$cshowList :: [Language] -> ShowS
show :: Language -> String
$cshow :: Language -> String
showsPrec :: Int -> Language -> ShowS
$cshowsPrec :: Int -> Language -> ShowS
Show)
instance Eq Language where
Language String
x == :: Language -> Language -> Bool
== Language String
y = String -> String -> Bool
caseInsensitiveEq String
x String
y
instance Ord Language where
Language String
x compare :: Language -> Language -> Ordering
`compare` Language String
y = String -> String -> Ordering
caseInsensitiveCompare String
x String
y
instance HeaderValue Language where
parseHeaderValue :: Parser Language
parseHeaderValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Language
Language forall a b. (a -> b) -> a -> b
$ forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser Char
ws1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Parser a -> Parser a
lexeme ParsecT String () Identity String
p_token
prettyHeaderValue :: Language -> String
prettyHeaderValue (Language String
s) = String
s
instance Acceptable Language where
Language String
x includes :: Language -> Language -> Bool
`includes` Language String
y =
String
x forall a. Eq a => a -> a -> Bool
== String
"*" Bool -> Bool -> Bool
|| String
x forall a. Eq a => a -> a -> Bool
== String
y Bool -> Bool -> Bool
|| (String
x forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
y Bool -> Bool -> Bool
&& String
"-" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x) String
y)