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

import Control.Monad (guard)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.CaseInsensitive (CI, original)
import qualified Data.CaseInsensitive as CI
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
$c== :: Charset -> Charset -> Bool
== :: Charset -> Charset -> Bool
$c/= :: Charset -> Charset -> Bool
/= :: 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
$ccompare :: Charset -> Charset -> Ordering
compare :: Charset -> Charset -> Ordering
$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
>= :: Charset -> Charset -> Bool
$cmax :: Charset -> Charset -> Charset
max :: Charset -> Charset -> Charset
$cmin :: Charset -> Charset -> Charset
min :: Charset -> Charset -> 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 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
$
        String
"Invalid encoding literal " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str

instance Accept Charset where
  parseAccept :: ByteString -> Maybe Charset
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
    Charset -> Maybe Charset
forall a. a -> Maybe a
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
_ (Charset CI ByteString
"*") = Bool
True
  matches Charset
a Charset
b = Charset
a Charset -> Charset -> Bool
forall a. Eq a => a -> a -> Bool
== Charset
b

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

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