Internal.hs

------------------------------------------------------------------------------
-- | 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 (Eq, Ord)

instance Show Charset where
    show = BS.unpack . renderHeader

instance IsString Charset where
    fromString str = flip fromMaybe (parseAccept $ BS.pack str) $
        error $ "Invalid encoding literal " ++ str

instance Accept Charset where
    parseAccept bs = do
        guard $ isValidToken bs
        return $ Charset (CI.mk bs)

    matches _ (Charset "*") = True
    matches a b             = a == b

    moreSpecificThan _ (Charset "*") = True
    moreSpecificThan _ _             = False

instance RenderHeader Charset where
    renderHeader (Charset e) = original e