------------------------------------------------------------------------------
-- | A framework for parsing HTTP media type headers.
module Network.HTTP.Media
    (
    -- * Media types
      MediaType
    , (//)
    , (/:)
    , mainType
    , subType
    , parameters
    , (/?)
    , (/.)

    -- * Charsets
    , Charset

    -- * Encodings
    , Encoding

    -- * Languages
    , Language
    , toParts

    -- * Accept matching
    , matchAccept
    , mapAccept
    , mapAcceptMedia
    , mapAcceptCharset
    , mapAcceptEncoding
    , mapAcceptLanguage
    , mapAcceptBytes

    -- * Content matching
    , matchContent
    , mapContent
    , mapContentMedia
    , mapContentCharset
    , mapContentEncoding
    , mapContentLanguage

    -- * Quality values
    , Quality
    , quality
    , QualityOrder
    , qualityOrder
    , maxQuality
    , minQuality
    , parseQuality
    , matchQuality
    , mapQuality

    -- * Accept
    , Accept (..)

    -- * Rendering
    , 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)


------------------------------------------------------------------------------
-- | Matches a list of server-side resource options against a quality-marked
-- list of client-side preferences. A result of 'Nothing' means that nothing
-- matched (which should indicate a 406 error). If two or more results arise
-- with the same quality level and specificity, then the first one in the
-- server list is chosen.
--
-- The use of the 'Accept' type class allows the application of either
-- 'MediaType' for the standard Accept header or 'ByteString' for any other
-- Accept header which can be marked with a quality value.
--
-- > matchAccept ["text/html", "application/json"] <$> getHeader
--
-- For more information on the matching process see RFC 2616, section 14.1-4.
matchAccept
    :: Accept a
    => [a]         -- ^ The server-side options
    -> ByteString  -- ^ The client-side header value
    -> 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


------------------------------------------------------------------------------
-- | The equivalent of 'matchAccept' above, except the resulting choice is
-- mapped to another value. Convenient for specifying how to translate the
-- resource into each of its available formats.
--
-- > getHeader >>= maybe render406Error renderResource . mapAccept
-- >     [ ("text" // "html",        asHtml)
-- >     , ("application" // "json", asJson)
-- >     ]
mapAccept
    :: Accept a
    => [(a, b)]    -- ^ The map of server-side preferences to values
    -> ByteString  -- ^ The client-side header value
    -> 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


------------------------------------------------------------------------------
-- | A specialisation of 'mapAccept' that only takes 'MediaType' as its input,
-- to avoid ambiguous-type errors when using string literal overloading.
--
-- > getHeader >>= maybe render406Error renderResource . mapAcceptMedia
-- >     [ ("text/html",        asHtml)
-- >     , ("application/json", asJson)
-- >     ]
mapAcceptMedia ::
    [(MediaType, b)]  -- ^ The map of server-side preferences to values
    -> ByteString     -- ^ The client-side header value
    -> 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


------------------------------------------------------------------------------
-- | A specialisation of 'mapAccept' that only takes 'Charset' as its input,
-- to avoid ambiguous-type errors when using string literal overloading.
--
-- > getHeader >>= maybe render406Error renderResource . mapAcceptCharset
-- >     [ ("utf-8",    inUtf8)
-- >     , ("us-ascii", inAscii)
-- >     ]
mapAcceptCharset ::
    [(Charset, b)]  -- ^ The map of server-side preferences to values
    -> ByteString   -- ^ The client-side header value
    -> 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


------------------------------------------------------------------------------
-- | A specialisation of 'mapAccept' that only takes 'Encoding' as its input,
-- to avoid ambiguous-type errors when using string literal overloading.
--
-- > getHeader >>= maybe render406Error renderResource . mapAcceptEncoding
-- >     [ ("compress", compress)
-- >     , ("identity", id)
-- >     ]
mapAcceptEncoding ::
    [(Encoding, b)]  -- ^ The map of server-side preferences to values
    -> ByteString    -- ^ The client-side header value
    -> 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


------------------------------------------------------------------------------
-- | A specialisation of 'mapAccept' that only takes 'Language' as its input,
-- to avoid ambiguous-type errors when using string literal overloading.
--
-- > getHeader >>= maybe render406Error renderResource . mapAcceptLanguage
-- >     [ ("en-gb", inBritishEnglish)
-- >     , ("fr",    inFrench)
-- >     ]
mapAcceptLanguage ::
    [(Language, b)]  -- ^ The map of server-side preferences to values
    -> ByteString    -- ^ The client-side header value
    -> 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


------------------------------------------------------------------------------
-- | A specialisation of 'mapAccept' that only takes 'ByteString' as its
-- input, to avoid ambiguous-type errors when using string literal
-- overloading.
--
-- > getHeader >>= maybe render406Error encodeResourceWith . mapAcceptBytes
-- >     [ ("abc", abc)
-- >     , ("xyz", xyz)
-- >     ]
mapAcceptBytes ::
    [(ByteString, b)]  -- ^ The map of server-side preferences to values
    -> ByteString      -- ^ The client-side header value
    -> 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


------------------------------------------------------------------------------
-- | Matches a list of server-side parsing options against a the client-side
-- content value. A result of 'Nothing' means that nothing matched (which
-- should indicate a 415 error).
--
-- > matchContent ["application/json", "text/plain"] <$> getContentType
--
-- For more information on the matching process see RFC 2616, section 14.17.
matchContent
    :: Accept a
    => [a]         -- ^ The server-side response options
    -> ByteString  -- ^ The client's request value
    -> Maybe a
matchContent :: [a] -> ByteString -> Maybe a
matchContent [a]
options 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 Maybe a
m 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


------------------------------------------------------------------------------
-- | The equivalent of 'matchContent' above, except the resulting choice is
-- mapped to another value.
--
-- > getContentType >>= maybe send415Error readRequestBodyWith . mapContent
-- >     [ ("application" // "json", parseJson)
-- >     , ("text" // "plain",       parseText)
-- >     ]
mapContent
    :: Accept a
    => [(a, b)]    -- ^ The map of server-side responses
    -> ByteString  -- ^ The client request's header value
    -> Maybe b
mapContent :: [(a, b)] -> ByteString -> Maybe b
mapContent [(a, b)]
options 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


------------------------------------------------------------------------------
-- | A specialisation of 'mapContent' that only takes 'MediaType' as its
-- input, to avoid ambiguous-type errors when using string literal
-- overloading.
--
-- > getContentType >>=
-- >     maybe send415Error readRequestBodyWith . mapContentMedia
-- >         [ ("application/json", parseJson)
-- >         , ("text/plain",       parseText)
-- >         ]
mapContentMedia
    :: [(MediaType, b)]  -- ^ The map of server-side responses
    -> ByteString        -- ^ The client request's header value
    -> 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


------------------------------------------------------------------------------
-- | A specialisation of 'mapContent' that only takes 'Charset' as its input,
-- to avoid ambiguous-type errors when using string literal overloading.
--
-- > getContentCharset >>=
-- >     maybe send415Error readRequestBodyWith . mapContentCharset
-- >         [ ("utf-8",    parseUtf8)
-- >         , ("us-ascii", parseAscii)
-- >         ]
mapContentCharset
    :: [(Charset, b)]  -- ^ The map of server-side responses
    -> ByteString      -- ^ The client request's header value
    -> 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


------------------------------------------------------------------------------
-- | A specialisation of 'mapContent' that only takes 'Encoding' as its input,
-- to avoid ambiguous-type errors when using string literal overloading.
--
-- > getContentEncoding >>=
-- >     maybe send415Error readRequestBodyWith . mapContentEncoding
-- >         [ ("compress", decompress)
-- >         , ("identity", id)
-- >         ]
mapContentEncoding
    :: [(Encoding, b)]  -- ^ The map of server-side responses
    -> ByteString       -- ^ The client request's header value
    -> 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


------------------------------------------------------------------------------
-- | A specialisation of 'mapContent' that only takes 'Language' as its input,
-- to avoid ambiguous-type errors when using string literal overloading.
--
-- > getContentLanguage >>=
-- >     maybe send415Error readRequestBodyWith . mapContentLanguage
-- >         [ ("en-gb", parseBritishEnglish)
-- >         , ("fr",    parseFrench)
-- >         ]
mapContentLanguage
    :: [(Language, b)]  -- ^ The map of server-side responses
    -> ByteString       -- ^ The client request's header value
    -> 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


------------------------------------------------------------------------------
-- | Parses a full Accept header into a list of quality-valued media types.
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' 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 Char
',') (([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
$ \ ByteString
s ->
    let (ByteString
accept, 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

    -- Split on ';', and check if a quality value is there. A value of Nothing
    -- indicates there was no parameter, whereas a value of Nothing in the
    -- pair indicates the parameter was not a quality value.
    getQ :: ByteString -> Maybe (ByteString, Maybe ByteString)
getQ ByteString
s = let (ByteString
a, 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
== Char
';') 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 ByteString
"q=" ByteString
b then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Int -> ByteString -> ByteString
BS.drop Int
2 ByteString
b) else Maybe ByteString
forall a. Maybe a
Nothing)

    -- Trawl backwards through the string, ignoring extension parameters.
    findQ :: ByteString -> Maybe (ByteString, Maybe ByteString)
findQ ByteString
s = do
        let q :: Maybe (ByteString, Maybe ByteString)
q = ByteString -> Maybe (ByteString, Maybe ByteString)
getQ ByteString
s
        (ByteString
a, 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


------------------------------------------------------------------------------
-- | Matches a list of server-side resource options against a pre-parsed
-- quality-marked list of client-side preferences. A result of 'Nothing' means
-- that nothing matched (which should indicate a 406 error). If two or more
-- results arise with the same quality level and specificity, then the first
-- one in the server list is chosen.
--
-- The use of the 'Accept' type class allows the application of either
-- 'MediaType' for the standard Accept header or 'ByteString' for any other
-- Accept header which can be marked with a quality value.
--
-- > matchQuality ["text/html", "application/json"] <$> parseQuality header
--
-- For more information on the matching process see RFC 2616, section 14.1-4.
matchQuality
    :: Accept a
    => [a]          -- ^ The server-side options
    -> [Quality a]  -- ^ The pre-parsed client-side header value
    -> Maybe a
matchQuality :: [a] -> [Quality a] -> Maybe a
matchQuality [a]
options [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 a
m 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
/= Word16
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 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 a
opt Quality a
qv = Quality a
qv { qualityData :: a
qualityData = a
opt }
    mfold :: a -> Maybe (Quality a) -> Quality a -> Maybe (Quality a)
mfold a
opt Maybe (Quality a)
cur acq :: Quality a
acq@(Quality a
acd Word16
_)
        | 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


------------------------------------------------------------------------------
-- | The equivalent of 'matchQuality' above, except the resulting choice is
-- mapped to another value. Convenient for specifying how to translate the
-- resource into each of its available formats.
--
-- > parseQuality header >>= maybe render406Error renderResource . mapQuality
-- >     [ ("text" // "html",        asHtml)
-- >     , ("application" // "json", asJson)
-- >     ]
mapQuality
    :: Accept a
    => [(a, b)]     -- ^ The map of server-side preferences to values
    -> [Quality a]  -- ^ The client-side header value
    -> Maybe b
mapQuality :: [(a, b)] -> [Quality a] -> Maybe b
mapQuality [(a, b)]
options [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


------------------------------------------------------------------------------
-- | The equivalent of 'lookupBy matches'.
lookupMatches :: Accept a => [(a, b)] -> a -> Maybe b
lookupMatches :: [(a, b)] -> a -> Maybe b
lookupMatches ((a
k, b
v) : [(a, b)]
r) 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 [] a
_ = Maybe b
forall a. Maybe a
Nothing