------------------------------------------------------------------------------
-- | Defines the 'Encoding' accept header with an 'Accept' instance for use in
-- language negotiation.
module Network.HTTP.Media.Encoding.Internal
    ( Encoding (..)
    ) where

import qualified Data.ByteString.Char8           as BS
import qualified Data.CaseInsensitive            as CI

import           Control.Monad                   (guard)
import           Data.ByteString                 (ByteString)
import           Data.CaseInsensitive            (CI, original)
import           Data.Maybe                      (fromMaybe)
import           Data.String                     (IsString (..))

import           Network.HTTP.Media.Accept       (Accept (..))
import           Network.HTTP.Media.RenderHeader (RenderHeader (..))
import           Network.HTTP.Media.Utils        (isValidToken)


------------------------------------------------------------------------------
-- | Suitable for HTTP encoding as defined in
-- <https://tools.ietf.org/html/rfc7231#section-5.3.4 RFC7231>.
--
-- Specifically:
--
-- > codings = content-coding / "identity" / "*"
newtype Encoding = Encoding (CI ByteString)
    deriving (Encoding -> Encoding -> Bool
(Encoding -> Encoding -> Bool)
-> (Encoding -> Encoding -> Bool) -> Eq Encoding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Encoding -> Encoding -> Bool
$c/= :: Encoding -> Encoding -> Bool
== :: Encoding -> Encoding -> Bool
$c== :: Encoding -> Encoding -> Bool
Eq, Eq Encoding
Eq Encoding
-> (Encoding -> Encoding -> Ordering)
-> (Encoding -> Encoding -> Bool)
-> (Encoding -> Encoding -> Bool)
-> (Encoding -> Encoding -> Bool)
-> (Encoding -> Encoding -> Bool)
-> (Encoding -> Encoding -> Encoding)
-> (Encoding -> Encoding -> Encoding)
-> Ord Encoding
Encoding -> Encoding -> Bool
Encoding -> Encoding -> Ordering
Encoding -> Encoding -> Encoding
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Encoding -> Encoding -> Encoding
$cmin :: Encoding -> Encoding -> Encoding
max :: Encoding -> Encoding -> Encoding
$cmax :: Encoding -> Encoding -> Encoding
>= :: Encoding -> Encoding -> Bool
$c>= :: Encoding -> Encoding -> Bool
> :: Encoding -> Encoding -> Bool
$c> :: Encoding -> Encoding -> Bool
<= :: Encoding -> Encoding -> Bool
$c<= :: Encoding -> Encoding -> Bool
< :: Encoding -> Encoding -> Bool
$c< :: Encoding -> Encoding -> Bool
compare :: Encoding -> Encoding -> Ordering
$ccompare :: Encoding -> Encoding -> Ordering
$cp1Ord :: Eq Encoding
Ord)

instance Show Encoding where
    show :: Encoding -> String
show = ByteString -> String
BS.unpack (ByteString -> String)
-> (Encoding -> ByteString) -> Encoding -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader

instance IsString Encoding where
    fromString :: String -> Encoding
fromString String
str = (Encoding -> Maybe Encoding -> Encoding)
-> Maybe Encoding -> Encoding -> Encoding
forall a b c. (a -> b -> c) -> b -> a -> c
flip Encoding -> Maybe Encoding -> Encoding
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> Maybe Encoding
forall a. Accept a => ByteString -> Maybe a
parseAccept (ByteString -> Maybe Encoding) -> ByteString -> Maybe Encoding
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BS.pack String
str) (Encoding -> Encoding) -> Encoding -> Encoding
forall a b. (a -> b) -> a -> b
$
        String -> Encoding
forall a. HasCallStack => String -> a
error (String -> Encoding) -> String -> Encoding
forall a b. (a -> b) -> a -> b
$ String
"Invalid encoding literal " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str

instance Accept Encoding where
    -- This handles the case where the header value is empty, but it also
    -- allows technically invalid values such as "compress;q=0.8,;q=0.5".
    parseAccept :: ByteString -> Maybe Encoding
parseAccept ByteString
"" = Encoding -> Maybe Encoding
forall a. a -> Maybe a
Just (Encoding -> Maybe Encoding) -> Encoding -> Maybe Encoding
forall a b. (a -> b) -> a -> b
$ CI ByteString -> Encoding
Encoding CI ByteString
"identity"
    parseAccept ByteString
bs = do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
isValidToken ByteString
bs
        Encoding -> Maybe Encoding
forall (m :: * -> *) a. Monad m => a -> m a
return (Encoding -> Maybe Encoding) -> Encoding -> Maybe Encoding
forall a b. (a -> b) -> a -> b
$ CI ByteString -> Encoding
Encoding (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
bs)

    matches :: Encoding -> Encoding -> Bool
matches Encoding
_ (Encoding CI ByteString
"*") = Bool
True
    matches Encoding
a Encoding
b              = Encoding
a Encoding -> Encoding -> Bool
forall a. Eq a => a -> a -> Bool
== Encoding
b

    moreSpecificThan :: Encoding -> Encoding -> Bool
moreSpecificThan Encoding
_ (Encoding CI ByteString
"*") = Bool
True
    moreSpecificThan Encoding
_ Encoding
_              = Bool
False

instance RenderHeader Encoding where
    renderHeader :: Encoding -> ByteString
renderHeader (Encoding CI ByteString
e) = CI ByteString -> ByteString
forall s. CI s -> s
original CI ByteString
e