------------------------------------------------------------------------------
-- | Defines the 'Charset' accept header with an 'Accept' instance for use in
-- language negotiation.
module Network.HTTP.Media.Charset.Internal
    ( Charset (..)
    ) 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 charset as defined in
-- <https://tools.ietf.org/html/rfc7231#section-5.3.3 RFC7231>.
--
-- Specifically:
--
-- > charset = token / "*"
newtype Charset = Charset (CI ByteString)
    deriving (Charset -> Charset -> Bool
(Charset -> Charset -> Bool)
-> (Charset -> Charset -> Bool) -> Eq Charset
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Charset -> Charset -> Bool
$c/= :: Charset -> Charset -> Bool
== :: Charset -> Charset -> Bool
$c== :: Charset -> Charset -> Bool
Eq, Eq Charset
Eq Charset =>
(Charset -> Charset -> Ordering)
-> (Charset -> Charset -> Bool)
-> (Charset -> Charset -> Bool)
-> (Charset -> Charset -> Bool)
-> (Charset -> Charset -> Bool)
-> (Charset -> Charset -> Charset)
-> (Charset -> Charset -> Charset)
-> Ord Charset
Charset -> Charset -> Bool
Charset -> Charset -> Ordering
Charset -> Charset -> Charset
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 :: Charset -> Charset -> Charset
$cmin :: Charset -> Charset -> Charset
max :: Charset -> Charset -> Charset
$cmax :: Charset -> Charset -> Charset
>= :: Charset -> Charset -> Bool
$c>= :: Charset -> Charset -> Bool
> :: Charset -> Charset -> Bool
$c> :: Charset -> Charset -> Bool
<= :: Charset -> Charset -> Bool
$c<= :: Charset -> Charset -> Bool
< :: Charset -> Charset -> Bool
$c< :: Charset -> Charset -> Bool
compare :: Charset -> Charset -> Ordering
$ccompare :: Charset -> Charset -> Ordering
$cp1Ord :: Eq Charset
Ord)

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

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

instance Accept Charset where
    parseAccept :: ByteString -> Maybe Charset
parseAccept bs :: 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
        Charset -> Maybe Charset
forall (m :: * -> *) a. Monad m => a -> m a
return (Charset -> Maybe Charset) -> Charset -> Maybe Charset
forall a b. (a -> b) -> a -> b
$ CI ByteString -> Charset
Charset (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
bs)

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

    moreSpecificThan :: Charset -> Charset -> Bool
moreSpecificThan _ (Charset "*") = Bool
True
    moreSpecificThan _ _             = Bool
False

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