------------------------------------------------------------------------------
-- | Defines the 'MediaType' accept header with an 'Accept' instance for use
-- in content-type negotiation.
module Network.HTTP.Media.MediaType
    (
    -- * Type and creation
      MediaType
    , Parameters
    , (//)
    , (/:)

    -- * Querying
    , mainType
    , subType
    , parameters
    , (/?)
    , (/.)
    ) where

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

import           Data.ByteString                       (ByteString)
import           Data.CaseInsensitive                  (CI)
import           Data.Map                              (empty, insert)

import qualified Network.HTTP.Media.MediaType.Internal as Internal

import           Network.HTTP.Media.MediaType.Internal (MediaType (MediaType))
import           Network.HTTP.Media.MediaType.Internal hiding (MediaType (..))
import           Network.HTTP.Media.Utils


------------------------------------------------------------------------------
-- | Retrieves the main type of a 'MediaType'.
mainType :: MediaType -> CI ByteString
mainType :: MediaType -> CI ByteString
mainType = MediaType -> CI ByteString
Internal.mainType


------------------------------------------------------------------------------
-- | Retrieves the sub type of a 'MediaType'.
subType :: MediaType -> CI ByteString
subType :: MediaType -> CI ByteString
subType = MediaType -> CI ByteString
Internal.subType


------------------------------------------------------------------------------
-- | Retrieves the parameters of a 'MediaType'.
parameters :: MediaType -> Parameters
parameters :: MediaType -> Parameters
parameters = MediaType -> Parameters
Internal.parameters


------------------------------------------------------------------------------
-- | Builds a 'MediaType' without parameters. Can produce an error if
-- either type is invalid.
(//) :: ByteString -> ByteString -> MediaType
ByteString
a // :: ByteString -> ByteString -> MediaType
// ByteString
b
    | ByteString
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"*" Bool -> Bool -> Bool
&& ByteString
b ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"*" = CI ByteString -> CI ByteString -> Parameters -> MediaType
MediaType (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
a) (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
b) Parameters
forall k a. Map k a
empty
    | ByteString
b ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"*"             = CI ByteString -> CI ByteString -> Parameters -> MediaType
MediaType (ByteString -> CI ByteString
ensureR ByteString
a) (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
b) Parameters
forall k a. Map k a
empty
    | Bool
otherwise            = CI ByteString -> CI ByteString -> Parameters -> MediaType
MediaType (ByteString -> CI ByteString
ensureR ByteString
a) (ByteString -> CI ByteString
ensureR ByteString
b) Parameters
forall k a. Map k a
empty


------------------------------------------------------------------------------
-- | Adds a parameter to a 'MediaType'. Can produce an error if either
-- string is invalid.
(/:) :: MediaType -> (ByteString, ByteString) -> MediaType
(MediaType CI ByteString
a CI ByteString
b Parameters
p) /: :: MediaType -> (ByteString, ByteString) -> MediaType
/: (ByteString
k, ByteString
v) = CI ByteString -> CI ByteString -> Parameters -> MediaType
MediaType CI ByteString
a CI ByteString
b (Parameters -> MediaType) -> Parameters -> MediaType
forall a b. (a -> b) -> a -> b
$ CI ByteString -> CI ByteString -> Parameters -> Parameters
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert (ByteString -> CI ByteString
ensureR ByteString
k) (ByteString -> CI ByteString
ensureV ByteString
v) Parameters
p


------------------------------------------------------------------------------
-- | Evaluates if a 'MediaType' has a parameter of the given name.
(/?) :: MediaType -> ByteString -> Bool
(MediaType CI ByteString
_ CI ByteString
_ Parameters
p) /? :: MediaType -> ByteString -> Bool
/? ByteString
k = CI ByteString -> Parameters -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
k) Parameters
p


------------------------------------------------------------------------------
-- | Retrieves a parameter from a 'MediaType'.
(/.) :: MediaType -> ByteString -> Maybe (CI ByteString)
(MediaType CI ByteString
_ CI ByteString
_ Parameters
p) /. :: MediaType -> ByteString -> Maybe (CI ByteString)
/. ByteString
k = CI ByteString -> Parameters -> Maybe (CI ByteString)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
k) Parameters
p


------------------------------------------------------------------------------
-- | Ensures that the 'ByteString' matches the ABNF for `reg-name` in RFC
-- 4288.
ensureR :: ByteString -> CI ByteString
ensureR :: ByteString -> CI ByteString
ensureR ByteString
bs = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ if Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
127
    then [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid length for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
bs else (Char -> Bool) -> ByteString -> ByteString
ensure Char -> Bool
isMediaChar ByteString
bs
  where l :: Int
l = ByteString -> Int
BS.length ByteString
bs


------------------------------------------------------------------------------
-- | Ensures that the 'ByteString' does not contain invalid characters for
-- a parameter value. RFC 4288 does not specify what characters are valid, so
-- here we just disallow parameter and media type breakers, ',' and ';'.
ensureV :: ByteString -> CI ByteString
ensureV :: ByteString -> CI ByteString
ensureV = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString)
-> (ByteString -> ByteString) -> ByteString -> CI ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
ensure (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
',', Char
';'])


------------------------------------------------------------------------------
-- | Ensures the predicate matches for every character in the given string.
ensure :: (Char -> Bool) -> ByteString -> ByteString
ensure :: (Char -> Bool) -> ByteString -> ByteString
ensure Char -> Bool
f ByteString
bs = ByteString -> (Char -> ByteString) -> Maybe Char -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    ([Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid character in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
bs) (ByteString -> Char -> ByteString
forall a b. a -> b -> a
const ByteString
bs) ((Char -> Bool) -> ByteString -> Maybe Char
BS.find Char -> Bool
f ByteString
bs)