-- | 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 (qualityData),
    quality,
    QualityOrder,
    qualityOrder,
    isAcceptable,
    maxQuality,
    minQuality,
    parseQuality,
    matchQuality,
    mapQuality,

    -- * Accept
    Accept (..),

    -- * Rendering
    RenderHeader (..),
  )
where

import Control.Applicative ((<|>))
import Control.Monad (guard, (>=>))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.Foldable (find, 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) =>
  -- | The server-side options
  [a] ->
  -- | The client-side header value
  ByteString ->
  Maybe a
matchAccept :: forall a. Accept a => [a] -> ByteString -> Maybe a
matchAccept = (forall a. Accept a => ByteString -> Maybe [Quality a]
parseQuality forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =>
  -- | The map of server-side preferences to values
  [(a, b)] ->
  -- | The client-side header value
  ByteString ->
  Maybe b
mapAccept :: forall a b. Accept a => [(a, b)] -> ByteString -> Maybe b
mapAccept = (forall a. Accept a => ByteString -> Maybe [Quality a]
parseQuality forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 ::
  -- | The map of server-side preferences to values
  [(MediaType, b)] ->
  -- | The client-side header value
  ByteString ->
  Maybe b
mapAcceptMedia :: forall b. [(MediaType, b)] -> ByteString -> Maybe b
mapAcceptMedia = 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 ::
  -- | The map of server-side preferences to values
  [(Charset, b)] ->
  -- | The client-side header value
  ByteString ->
  Maybe b
mapAcceptCharset :: forall b. [(Charset, b)] -> ByteString -> Maybe b
mapAcceptCharset = 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 ::
  -- | The map of server-side preferences to values
  [(Encoding, b)] ->
  -- | The client-side header value
  ByteString ->
  Maybe b
mapAcceptEncoding :: forall b. [(Encoding, b)] -> ByteString -> Maybe b
mapAcceptEncoding = 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 ::
  -- | The map of server-side preferences to values
  [(Language, b)] ->
  -- | The client-side header value
  ByteString ->
  Maybe b
mapAcceptLanguage :: forall b. [(Language, b)] -> ByteString -> Maybe b
mapAcceptLanguage = 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 ::
  -- | The map of server-side preferences to values
  [(ByteString, b)] ->
  -- | The client-side header value
  ByteString ->
  Maybe b
mapAcceptBytes :: forall b. [(ByteString, b)] -> ByteString -> Maybe b
mapAcceptBytes = 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) =>
  -- | The server-side response options
  [a] ->
  -- | The client's request value
  ByteString ->
  Maybe a
matchContent :: forall a. Accept a => [a] -> ByteString -> Maybe a
matchContent = forall b a. Accept b => (a -> b) -> [a] -> ByteString -> Maybe a
findMatch forall a. a -> a
id

-- | 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) =>
  -- | The map of server-side responses
  [(a, b)] ->
  -- | The client request's header value
  ByteString ->
  Maybe b
mapContent :: forall a b. Accept a => [(a, b)] -> ByteString -> Maybe b
mapContent [(a, b)]
options = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Accept b => (a -> b) -> [a] -> ByteString -> Maybe a
findMatch forall a b. (a, b) -> a
fst [(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 ::
  -- | The map of server-side responses
  [(MediaType, b)] ->
  -- | The client request's header value
  ByteString ->
  Maybe b
mapContentMedia :: forall b. [(MediaType, b)] -> ByteString -> Maybe b
mapContentMedia = 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 ::
  -- | The map of server-side responses
  [(Charset, b)] ->
  -- | The client request's header value
  ByteString ->
  Maybe b
mapContentCharset :: forall b. [(Charset, b)] -> ByteString -> Maybe b
mapContentCharset = 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 ::
  -- | The map of server-side responses
  [(Encoding, b)] ->
  -- | The client request's header value
  ByteString ->
  Maybe b
mapContentEncoding :: forall b. [(Encoding, b)] -> ByteString -> Maybe b
mapContentEncoding = 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 ::
  -- | The map of server-side responses
  [(Language, b)] ->
  -- | The client request's header value
  ByteString ->
  Maybe b
mapContentLanguage :: forall b. [(Language, b)] -> ByteString -> Maybe b
mapContentLanguage = 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 :: forall a. Accept a => ByteString -> Maybe [Quality a]
parseQuality = forall a. Accept a => Proxy a -> ByteString -> Maybe [Quality a]
parseQuality' forall {k} (t :: k). Proxy t
Proxy

parseQuality' :: (Accept a) => Proxy a -> ByteString -> Maybe [Quality a]
parseQuality' :: forall a. Accept a => Proxy a -> ByteString -> Maybe [Quality a]
parseQuality' Proxy a
p = (forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
trimBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> [ByteString]
BS.split Char
',') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a b. (a -> b) -> a -> b
$ \ByteString
s ->
  let (ByteString
accept, Maybe ByteString
q) = forall a. a -> Maybe a -> a
fromMaybe (ByteString
s, forall a. Maybe a
Nothing) 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 forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> Quality a
maxQuality) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. a -> Word16 -> Quality a
Quality) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe Word16
readQ) Maybe ByteString
q
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Accept a => ByteString -> Maybe a
parseAccept ByteString
accept
  where
    ext :: Bool
ext = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS.breakEnd (forall a. Eq a => a -> a -> Bool
== Char
';') ByteString
s
       in if ByteString -> Bool
BS.null ByteString
a
            then forall a. Maybe a
Nothing
            else
              forall a. a -> Maybe a
Just
                ( HasCallStack => ByteString -> ByteString
BS.init ByteString
a,
                  if ByteString -> ByteString -> Bool
BS.isPrefixOf ByteString
"q=" ByteString
b then forall a. a -> Maybe a
Just (Int -> ByteString -> ByteString
BS.drop Int
2 ByteString
b) else 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
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString -> Maybe (ByteString, Maybe ByteString)
findQ ByteString
a) (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) =>
  -- | The server-side options
  [a] ->
  -- | The pre-parsed client-side header value
  [Quality a] ->
  Maybe a
matchQuality :: forall a. Accept a => [a] -> [Quality a] -> Maybe a
matchQuality = forall a b. Accept a => (b -> a) -> [b] -> [Quality a] -> Maybe b
findQuality forall a. a -> a
id

-- | 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) =>
  -- | The map of server-side preferences to values
  [(a, b)] ->
  -- | The client-side header value
  [Quality a] ->
  Maybe b
mapQuality :: forall a b. Accept a => [(a, b)] -> [Quality a] -> Maybe b
mapQuality [(a, b)]
options = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Accept a => (b -> a) -> [b] -> [Quality a] -> Maybe b
findQuality forall a b. (a, b) -> a
fst [(a, b)]
options

-- | Find a match in a list of options against a ByteString using an 'Accept'
-- instance obtained by mapping the options to another type.
findMatch :: (Accept b) => (a -> b) -> [a] -> ByteString -> Maybe a
findMatch :: forall b a. Accept b => (a -> b) -> [a] -> ByteString -> Maybe a
findMatch a -> b
f [a]
options ByteString
bs = do
  b
ctype <- forall a. Accept a => ByteString -> Maybe a
parseAccept ByteString
bs
  forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Accept a => a -> a -> Bool
matches b
ctype forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) [a]
options

-- | Find a quality match between a list of options and a quality-marked list
-- of a different type, by mapping the type of the former to the latter.
findQuality :: (Accept a) => (b -> a) -> [b] -> [Quality a] -> Maybe b
findQuality :: forall a b. Accept a => (b -> a) -> [b] -> [Quality a] -> Maybe b
findQuality b -> a
f [b]
options [Quality a]
acceptq = do
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [b]
options)
  Quality b
q <- forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Quality a -> QualityOrder
qualityOrder) [Maybe (Quality b)]
optionsq
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a. Quality a -> Bool
isAcceptable Quality b
q
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Quality a -> a
qualityData Quality b
q
  where
    optionsq :: [Maybe (Quality b)]
optionsq = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map b -> Maybe (Quality b)
addQuality [b]
options
    addQuality :: b -> Maybe (Quality b)
addQuality b
opt = forall {a} {a}. a -> Quality a -> Quality a
withQValue b
opt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (b -> Maybe (Quality a) -> Quality a -> Maybe (Quality a)
mfold b
opt) forall a. Maybe a
Nothing [Quality a]
acceptq
    withQValue :: a -> Quality a -> Quality a
withQValue a
opt Quality a
q = Quality a
q {qualityData :: a
qualityData = a
opt}
    mfold :: b -> Maybe (Quality a) -> Quality a -> Maybe (Quality a)
mfold b
opt Maybe (Quality a)
cur Quality a
q
      | b -> a
f b
opt forall a. Accept a => a -> a -> Bool
`matches` forall a. Quality a -> a
qualityData Quality a
q = forall a. Accept a => Quality a -> Quality a -> Quality a
mostSpecific Quality a
q forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Quality a)
cur forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Maybe a
Just Quality a
q
      | Bool
otherwise = Maybe (Quality a)
cur