module Network.HTTP.Media
(
MediaType
, (//)
, (/:)
, mainType
, subType
, parameters
, (/?)
, (/.)
, Charset
, Encoding
, Language
, toParts
, matchAccept
, mapAccept
, mapAcceptMedia
, mapAcceptCharset
, mapAcceptEncoding
, mapAcceptLanguage
, mapAcceptBytes
, matchContent
, mapContent
, mapContentMedia
, mapContentCharset
, mapContentEncoding
, mapContentLanguage
, Quality
, quality
, QualityOrder
, qualityOrder
, maxQuality
, minQuality
, parseQuality
, matchQuality
, mapQuality
, Accept (..)
, RenderHeader (..)
) where
import Control.Applicative ((<|>))
import qualified Data.ByteString.Char8 as BS
import Control.Monad (guard, (>=>))
import Data.ByteString (ByteString)
import Data.Foldable (foldl', maximumBy)
import Data.Function (on)
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (Proxy))
import Network.HTTP.Media.Accept as Accept
import Network.HTTP.Media.Charset as Charset
import Network.HTTP.Media.Encoding as Encoding
import Network.HTTP.Media.Language as Language
import Network.HTTP.Media.MediaType as MediaType
import Network.HTTP.Media.Quality
import Network.HTTP.Media.RenderHeader
import Network.HTTP.Media.Utils (trimBS)
matchAccept
:: Accept a
=> [a]
-> ByteString
-> Maybe a
matchAccept :: [a] -> ByteString -> Maybe a
matchAccept = (ByteString -> Maybe [Quality a]
forall a. Accept a => ByteString -> Maybe [Quality a]
parseQuality (ByteString -> Maybe [Quality a])
-> ([Quality a] -> Maybe a) -> ByteString -> Maybe a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>) (([Quality a] -> Maybe a) -> ByteString -> Maybe a)
-> ([a] -> [Quality a] -> Maybe a) -> [a] -> ByteString -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [Quality a] -> Maybe a
forall a. Accept a => [a] -> [Quality a] -> Maybe a
matchQuality
mapAccept
:: Accept a
=> [(a, b)]
-> ByteString
-> Maybe b
mapAccept :: [(a, b)] -> ByteString -> Maybe b
mapAccept = (ByteString -> Maybe [Quality a]
forall a. Accept a => ByteString -> Maybe [Quality a]
parseQuality (ByteString -> Maybe [Quality a])
-> ([Quality a] -> Maybe b) -> ByteString -> Maybe b
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>) (([Quality a] -> Maybe b) -> ByteString -> Maybe b)
-> ([(a, b)] -> [Quality a] -> Maybe b)
-> [(a, b)]
-> ByteString
-> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, b)] -> [Quality a] -> Maybe b
forall a b. Accept a => [(a, b)] -> [Quality a] -> Maybe b
mapQuality
mapAcceptMedia ::
[(MediaType, b)]
-> ByteString
-> Maybe b
mapAcceptMedia :: [(MediaType, b)] -> ByteString -> Maybe b
mapAcceptMedia = [(MediaType, b)] -> ByteString -> Maybe b
forall a b. Accept a => [(a, b)] -> ByteString -> Maybe b
mapAccept
mapAcceptCharset ::
[(Charset, b)]
-> ByteString
-> Maybe b
mapAcceptCharset :: [(Charset, b)] -> ByteString -> Maybe b
mapAcceptCharset = [(Charset, b)] -> ByteString -> Maybe b
forall a b. Accept a => [(a, b)] -> ByteString -> Maybe b
mapAccept
mapAcceptEncoding ::
[(Encoding, b)]
-> ByteString
-> Maybe b
mapAcceptEncoding :: [(Encoding, b)] -> ByteString -> Maybe b
mapAcceptEncoding = [(Encoding, b)] -> ByteString -> Maybe b
forall a b. Accept a => [(a, b)] -> ByteString -> Maybe b
mapAccept
mapAcceptLanguage ::
[(Language, b)]
-> ByteString
-> Maybe b
mapAcceptLanguage :: [(Language, b)] -> ByteString -> Maybe b
mapAcceptLanguage = [(Language, b)] -> ByteString -> Maybe b
forall a b. Accept a => [(a, b)] -> ByteString -> Maybe b
mapAccept
mapAcceptBytes ::
[(ByteString, b)]
-> ByteString
-> Maybe b
mapAcceptBytes :: [(ByteString, b)] -> ByteString -> Maybe b
mapAcceptBytes = [(ByteString, b)] -> ByteString -> Maybe b
forall a b. Accept a => [(a, b)] -> ByteString -> Maybe b
mapAccept
matchContent
:: Accept a
=> [a]
-> ByteString
-> Maybe a
matchContent :: [a] -> ByteString -> Maybe a
matchContent options :: [a]
options ctype :: ByteString
ctype = (Maybe a -> a -> Maybe a) -> Maybe a -> [a] -> Maybe a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Maybe a -> a -> Maybe a
forall a. Accept a => Maybe a -> a -> Maybe a
choose Maybe a
forall a. Maybe a
Nothing [a]
options
where
choose :: Maybe a -> a -> Maybe a
choose m :: Maybe a
m server :: a
server = Maybe a
m Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
ByteString -> Maybe a
forall a. Accept a => ByteString -> Maybe a
parseAccept ByteString
ctype Maybe a -> (a -> Maybe ()) -> Maybe ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (a -> Bool) -> a -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> Bool
forall a. Accept a => a -> a -> Bool
`matches` a
server)
a -> Maybe a
forall a. a -> Maybe a
Just a
server
mapContent
:: Accept a
=> [(a, b)]
-> ByteString
-> Maybe b
mapContent :: [(a, b)] -> ByteString -> Maybe b
mapContent options :: [(a, b)]
options ctype :: ByteString
ctype =
[a] -> ByteString -> Maybe a
forall a. Accept a => [a] -> ByteString -> Maybe a
matchContent (((a, b) -> a) -> [(a, b)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> a
forall a b. (a, b) -> a
fst [(a, b)]
options) ByteString
ctype Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(a, b)] -> a -> Maybe b
forall a b. Accept a => [(a, b)] -> a -> Maybe b
lookupMatches [(a, b)]
options
mapContentMedia
:: [(MediaType, b)]
-> ByteString
-> Maybe b
mapContentMedia :: [(MediaType, b)] -> ByteString -> Maybe b
mapContentMedia = [(MediaType, b)] -> ByteString -> Maybe b
forall a b. Accept a => [(a, b)] -> ByteString -> Maybe b
mapContent
mapContentCharset
:: [(Charset, b)]
-> ByteString
-> Maybe b
mapContentCharset :: [(Charset, b)] -> ByteString -> Maybe b
mapContentCharset = [(Charset, b)] -> ByteString -> Maybe b
forall a b. Accept a => [(a, b)] -> ByteString -> Maybe b
mapContent
mapContentEncoding
:: [(Encoding, b)]
-> ByteString
-> Maybe b
mapContentEncoding :: [(Encoding, b)] -> ByteString -> Maybe b
mapContentEncoding = [(Encoding, b)] -> ByteString -> Maybe b
forall a b. Accept a => [(a, b)] -> ByteString -> Maybe b
mapContent
mapContentLanguage
:: [(Language, b)]
-> ByteString
-> Maybe b
mapContentLanguage :: [(Language, b)] -> ByteString -> Maybe b
mapContentLanguage = [(Language, b)] -> ByteString -> Maybe b
forall a b. Accept a => [(a, b)] -> ByteString -> Maybe b
mapContent
parseQuality :: Accept a => ByteString -> Maybe [Quality a]
parseQuality :: ByteString -> Maybe [Quality a]
parseQuality = Proxy a -> ByteString -> Maybe [Quality a]
forall a. Accept a => Proxy a -> ByteString -> Maybe [Quality a]
parseQuality' Proxy a
forall k (t :: k). Proxy t
Proxy
parseQuality' :: Accept a => Proxy a -> ByteString -> Maybe [Quality a]
parseQuality' :: Proxy a -> ByteString -> Maybe [Quality a]
parseQuality' p :: Proxy a
p = (([ByteString] -> Maybe [Quality a])
-> (ByteString -> [ByteString]) -> ByteString -> Maybe [Quality a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
trimBS ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> [ByteString]
BS.split ',') (([ByteString] -> Maybe [Quality a])
-> ByteString -> Maybe [Quality a])
-> ((ByteString -> Maybe (Quality a))
-> [ByteString] -> Maybe [Quality a])
-> (ByteString -> Maybe (Quality a))
-> ByteString
-> Maybe [Quality a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Maybe (Quality a))
-> [ByteString] -> Maybe [Quality a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((ByteString -> Maybe (Quality a))
-> ByteString -> Maybe [Quality a])
-> (ByteString -> Maybe (Quality a))
-> ByteString
-> Maybe [Quality a]
forall a b. (a -> b) -> a -> b
$ \ s :: ByteString
s ->
let (accept :: ByteString
accept, q :: Maybe ByteString
q) = (ByteString, Maybe ByteString)
-> Maybe (ByteString, Maybe ByteString)
-> (ByteString, Maybe ByteString)
forall a. a -> Maybe a -> a
fromMaybe (ByteString
s, Maybe ByteString
forall a. Maybe a
Nothing) (Maybe (ByteString, Maybe ByteString)
-> (ByteString, Maybe ByteString))
-> Maybe (ByteString, Maybe ByteString)
-> (ByteString, Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ if Bool
ext then ByteString -> Maybe (ByteString, Maybe ByteString)
findQ ByteString
s else ByteString -> Maybe (ByteString, Maybe ByteString)
getQ ByteString
s
in Maybe (a -> Quality a)
-> (ByteString -> Maybe (a -> Quality a))
-> Maybe ByteString
-> Maybe (a -> Quality a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((a -> Quality a) -> Maybe (a -> Quality a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> Quality a
forall a. a -> Quality a
maxQuality) ((Word16 -> a -> Quality a)
-> Maybe Word16 -> Maybe (a -> Quality a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> Word16 -> Quality a) -> Word16 -> a -> Quality a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Word16 -> Quality a
forall a. a -> Word16 -> Quality a
Quality) (Maybe Word16 -> Maybe (a -> Quality a))
-> (ByteString -> Maybe Word16)
-> ByteString
-> Maybe (a -> Quality a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe Word16
readQ) Maybe ByteString
q Maybe (a -> Quality a) -> Maybe a -> Maybe (Quality a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
ByteString -> Maybe a
forall a. Accept a => ByteString -> Maybe a
parseAccept ByteString
accept
where
ext :: Bool
ext = Proxy a -> Bool
forall a. Accept a => Proxy a -> Bool
hasExtensionParameters Proxy a
p
getQ :: ByteString -> Maybe (ByteString, Maybe ByteString)
getQ s :: ByteString
s = let (a :: ByteString
a, b :: ByteString
b) = ByteString -> ByteString
trimBS (ByteString -> ByteString)
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS.breakEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ';') ByteString
s in
if ByteString -> Bool
BS.null ByteString
a then Maybe (ByteString, Maybe ByteString)
forall a. Maybe a
Nothing else (ByteString, Maybe ByteString)
-> Maybe (ByteString, Maybe ByteString)
forall a. a -> Maybe a
Just (ByteString -> ByteString
BS.init ByteString
a,
if ByteString -> ByteString -> Bool
BS.isPrefixOf "q=" ByteString
b then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Int -> ByteString -> ByteString
BS.drop 2 ByteString
b) else Maybe ByteString
forall a. Maybe a
Nothing)
findQ :: ByteString -> Maybe (ByteString, Maybe ByteString)
findQ s :: ByteString
s = do
let q :: Maybe (ByteString, Maybe ByteString)
q = ByteString -> Maybe (ByteString, Maybe ByteString)
getQ ByteString
s
(a :: ByteString
a, m :: Maybe ByteString
m) <- Maybe (ByteString, Maybe ByteString)
q
Maybe (ByteString, Maybe ByteString)
-> (ByteString -> Maybe (ByteString, Maybe ByteString))
-> Maybe ByteString
-> Maybe (ByteString, Maybe ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString -> Maybe (ByteString, Maybe ByteString)
findQ ByteString
a) (Maybe (ByteString, Maybe ByteString)
-> ByteString -> Maybe (ByteString, Maybe ByteString)
forall a b. a -> b -> a
const Maybe (ByteString, Maybe ByteString)
q) Maybe ByteString
m
matchQuality
:: Accept a
=> [a]
-> [Quality a]
-> Maybe a
matchQuality :: [a] -> [Quality a] -> Maybe a
matchQuality options :: [a]
options acceptq :: [Quality a]
acceptq = do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
options)
Quality m :: a
m q :: Word16
q <- (Maybe (Quality a) -> Maybe (Quality a) -> Ordering)
-> [Maybe (Quality a)] -> Maybe (Quality a)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (Maybe QualityOrder -> Maybe QualityOrder -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Maybe QualityOrder -> Maybe QualityOrder -> Ordering)
-> (Maybe (Quality a) -> Maybe QualityOrder)
-> Maybe (Quality a)
-> Maybe (Quality a)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Quality a -> QualityOrder)
-> Maybe (Quality a) -> Maybe QualityOrder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Quality a -> QualityOrder
forall a. Quality a -> QualityOrder
qualityOrder) [Maybe (Quality a)]
optionsq
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Word16
q Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0
a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return a
m
where
optionsq :: [Maybe (Quality a)]
optionsq = [Maybe (Quality a)] -> [Maybe (Quality a)]
forall a. [a] -> [a]
reverse ([Maybe (Quality a)] -> [Maybe (Quality a)])
-> [Maybe (Quality a)] -> [Maybe (Quality a)]
forall a b. (a -> b) -> a -> b
$ (a -> Maybe (Quality a)) -> [a] -> [Maybe (Quality a)]
forall a b. (a -> b) -> [a] -> [b]
map a -> Maybe (Quality a)
addQuality [a]
options
addQuality :: a -> Maybe (Quality a)
addQuality opt :: a
opt = a -> Quality a -> Quality a
forall a a. a -> Quality a -> Quality a
withQValue a
opt (Quality a -> Quality a) -> Maybe (Quality a) -> Maybe (Quality a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (Quality a) -> Quality a -> Maybe (Quality a))
-> Maybe (Quality a) -> [Quality a] -> Maybe (Quality a)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (a -> Maybe (Quality a) -> Quality a -> Maybe (Quality a)
forall a.
Accept a =>
a -> Maybe (Quality a) -> Quality a -> Maybe (Quality a)
mfold a
opt) Maybe (Quality a)
forall a. Maybe a
Nothing [Quality a]
acceptq
withQValue :: a -> Quality a -> Quality a
withQValue opt :: a
opt qv :: Quality a
qv = Quality a
qv { qualityData :: a
qualityData = a
opt }
mfold :: a -> Maybe (Quality a) -> Quality a -> Maybe (Quality a)
mfold opt :: a
opt cur :: Maybe (Quality a)
cur acq :: Quality a
acq@(Quality acd :: a
acd _)
| a
opt a -> a -> Bool
forall a. Accept a => a -> a -> Bool
`matches` a
acd = Quality a -> Quality a -> Quality a
forall a. Accept a => Quality a -> Quality a -> Quality a
mostSpecific Quality a
acq (Quality a -> Quality a) -> Maybe (Quality a) -> Maybe (Quality a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Quality a)
cur Maybe (Quality a) -> Maybe (Quality a) -> Maybe (Quality a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Quality a -> Maybe (Quality a)
forall a. a -> Maybe a
Just Quality a
acq
| Bool
otherwise = Maybe (Quality a)
cur
mapQuality
:: Accept a
=> [(a, b)]
-> [Quality a]
-> Maybe b
mapQuality :: [(a, b)] -> [Quality a] -> Maybe b
mapQuality options :: [(a, b)]
options accept :: [Quality a]
accept =
[a] -> [Quality a] -> Maybe a
forall a. Accept a => [a] -> [Quality a] -> Maybe a
matchQuality (((a, b) -> a) -> [(a, b)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> a
forall a b. (a, b) -> a
fst [(a, b)]
options) [Quality a]
accept Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(a, b)] -> a -> Maybe b
forall a b. Accept a => [(a, b)] -> a -> Maybe b
lookupMatches [(a, b)]
options
lookupMatches :: Accept a => [(a, b)] -> a -> Maybe b
lookupMatches :: [(a, b)] -> a -> Maybe b
lookupMatches ((k :: a
k, v :: b
v) : r :: [(a, b)]
r) a :: a
a
| a -> a -> Bool
forall a. Accept a => a -> a -> Bool
Accept.matches a
k a
a = b -> Maybe b
forall a. a -> Maybe a
Just b
v
| Bool
otherwise = [(a, b)] -> a -> Maybe b
forall a b. Accept a => [(a, b)] -> a -> Maybe b
lookupMatches [(a, b)]
r a
a
lookupMatches [] _ = Maybe b
forall a. Maybe a
Nothing