-- | 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 Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.Map (empty, insert)
import qualified Data.Map as Map
import Network.HTTP.Media.MediaType.Internal (MediaType (MediaType))
import Network.HTTP.Media.MediaType.Internal hiding (MediaType (..))
import qualified Network.HTTP.Media.MediaType.Internal as Internal
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 forall a. Eq a => a -> a -> Bool
== ByteString
"*" Bool -> Bool -> Bool
&& ByteString
b forall a. Eq a => a -> a -> Bool
== ByteString
"*" = CI ByteString -> CI ByteString -> Parameters -> MediaType
MediaType (forall s. FoldCase s => s -> CI s
CI.mk ByteString
a) (forall s. FoldCase s => s -> CI s
CI.mk ByteString
b) forall k a. Map k a
empty
  | ByteString
b forall a. Eq a => a -> a -> Bool
== ByteString
"*" = CI ByteString -> CI ByteString -> Parameters -> MediaType
MediaType (ByteString -> CI ByteString
ensureR ByteString
a) (forall s. FoldCase s => s -> CI s
CI.mk ByteString
b) 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) 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 forall a b. (a -> b) -> a -> b
$ 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 = forall k a. Ord k => k -> Map k a -> Bool
Map.member (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 = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (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 =
  forall s. FoldCase s => s -> CI s
CI.mk forall a b. (a -> b) -> a -> b
$
    if Int
l forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
l forall a. Ord a => a -> a -> Bool
> Int
127
      then forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid length for " forall a. [a] -> [a] -> [a]
++ 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 = forall s. FoldCase s => s -> CI s
CI.mk forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
ensure (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 =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid character in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ByteString
bs)
    (forall a b. a -> b -> a
const ByteString
bs)
    ((Char -> Bool) -> ByteString -> Maybe Char
BS.find Char -> Bool
f ByteString
bs)