Internal.hs

-- | Defines the 'Encoding' accept header with an 'Accept' instance for use in
-- language negotiation.
module Network.HTTP.Media.Encoding.Internal
  ( Encoding (..),
  )
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 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 (Eq, Ord)

instance Show Encoding where
  show = BS.unpack . renderHeader

instance IsString Encoding where
  fromString str =
    flip fromMaybe (parseAccept $ BS.pack str) $
      error $
        "Invalid encoding literal " ++ 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 "" = Just $ Encoding "identity"
  parseAccept bs = do
    guard $ isValidToken bs
    return $ Encoding (CI.mk bs)

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

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

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