-- | Defined to allow the constructor of 'MediaType' to be exposed to tests.
module Network.HTTP.Media.MediaType.Internal
  ( MediaType (..),
    Parameters,
  )
where

import Control.Monad (foldM, 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.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.String (IsString (..))
import Network.HTTP.Media.Accept (Accept (..))
import Network.HTTP.Media.RenderHeader (RenderHeader (..))
import Network.HTTP.Media.Utils (breakChar, trimBS)
import Prelude hiding ((<>))

-- | An HTTP media type, consisting of the type, subtype, and parameters.
data MediaType = MediaType
  { -- | The main type of the MediaType
    MediaType -> CI ByteString
mainType :: CI ByteString,
    -- | The sub type of the MediaType
    MediaType -> CI ByteString
subType :: CI ByteString,
    -- | The parameters of the MediaType
    MediaType -> Parameters
parameters :: Parameters
  }
  deriving (MediaType -> MediaType -> Bool
(MediaType -> MediaType -> Bool)
-> (MediaType -> MediaType -> Bool) -> Eq MediaType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MediaType -> MediaType -> Bool
== :: MediaType -> MediaType -> Bool
$c/= :: MediaType -> MediaType -> Bool
/= :: MediaType -> MediaType -> Bool
Eq, Eq MediaType
Eq MediaType =>
(MediaType -> MediaType -> Ordering)
-> (MediaType -> MediaType -> Bool)
-> (MediaType -> MediaType -> Bool)
-> (MediaType -> MediaType -> Bool)
-> (MediaType -> MediaType -> Bool)
-> (MediaType -> MediaType -> MediaType)
-> (MediaType -> MediaType -> MediaType)
-> Ord MediaType
MediaType -> MediaType -> Bool
MediaType -> MediaType -> Ordering
MediaType -> MediaType -> MediaType
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 :: MediaType -> MediaType -> Ordering
compare :: MediaType -> MediaType -> Ordering
$c< :: MediaType -> MediaType -> Bool
< :: MediaType -> MediaType -> Bool
$c<= :: MediaType -> MediaType -> Bool
<= :: MediaType -> MediaType -> Bool
$c> :: MediaType -> MediaType -> Bool
> :: MediaType -> MediaType -> Bool
$c>= :: MediaType -> MediaType -> Bool
>= :: MediaType -> MediaType -> Bool
$cmax :: MediaType -> MediaType -> MediaType
max :: MediaType -> MediaType -> MediaType
$cmin :: MediaType -> MediaType -> MediaType
min :: MediaType -> MediaType -> MediaType
Ord)

instance Show MediaType where
  show :: MediaType -> String
show = ByteString -> String
BS.unpack (ByteString -> String)
-> (MediaType -> ByteString) -> MediaType -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader

instance IsString MediaType where
  fromString :: String -> MediaType
fromString String
str =
    (MediaType -> Maybe MediaType -> MediaType)
-> Maybe MediaType -> MediaType -> MediaType
forall a b c. (a -> b -> c) -> b -> a -> c
flip MediaType -> Maybe MediaType -> MediaType
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> Maybe MediaType
forall a. Accept a => ByteString -> Maybe a
parseAccept (ByteString -> Maybe MediaType) -> ByteString -> Maybe MediaType
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BS.pack String
str) (MediaType -> MediaType) -> MediaType -> MediaType
forall a b. (a -> b) -> a -> b
$
      String -> MediaType
forall a. HasCallStack => String -> a
error (String -> MediaType) -> String -> MediaType
forall a b. (a -> b) -> a -> b
$
        String
"Invalid media type literal " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str

instance Accept MediaType where
  parseAccept :: ByteString -> Maybe MediaType
parseAccept ByteString
bs = do
    (ByteString
s, [ByteString]
ps) <- [ByteString] -> Maybe (ByteString, [ByteString])
forall {a}. [a] -> Maybe (a, [a])
uncons ((ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
trimBS (Char -> ByteString -> [ByteString]
BS.split Char
';' ByteString
bs))
    (ByteString
a, ByteString
b) <- Char -> ByteString -> Maybe (ByteString, ByteString)
breakChar Char
'/' ByteString
s
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (ByteString -> Bool
BS.null ByteString
a Bool -> Bool -> Bool
|| ByteString -> Bool
BS.null ByteString
b) Bool -> Bool -> Bool
&& (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
"*")
    Parameters
ps' <- (Parameters -> ByteString -> Maybe Parameters)
-> Parameters -> [ByteString] -> Maybe Parameters
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Parameters -> ByteString -> Maybe Parameters
insert Parameters
forall k a. Map k a
Map.empty [ByteString]
ps
    MediaType -> Maybe MediaType
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (MediaType -> Maybe MediaType) -> MediaType -> Maybe MediaType
forall a b. (a -> b) -> a -> b
$ 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
ps'
    where
      uncons :: [a] -> Maybe (a, [a])
uncons [] = Maybe (a, [a])
forall a. Maybe a
Nothing
      uncons (a
a : [a]
b) = (a, [a]) -> Maybe (a, [a])
forall a. a -> Maybe a
Just (a
a, [a]
b)
      both :: (t -> b) -> (t, t) -> (b, b)
both t -> b
f (t
a, t
b) = (t -> b
f t
a, t -> b
f t
b)
      insert :: Parameters -> ByteString -> Maybe Parameters
insert Parameters
ps =
        ((ByteString, ByteString) -> Parameters)
-> Maybe (ByteString, ByteString) -> Maybe Parameters
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((CI ByteString, CI ByteString) -> Parameters -> Parameters)
-> Parameters -> (CI ByteString, CI ByteString) -> Parameters
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((CI ByteString -> CI ByteString -> Parameters -> Parameters)
-> (CI ByteString, CI ByteString) -> Parameters -> Parameters
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CI ByteString -> CI ByteString -> Parameters -> Parameters
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert) Parameters
ps ((CI ByteString, CI ByteString) -> Parameters)
-> ((ByteString, ByteString) -> (CI ByteString, CI ByteString))
-> (ByteString, ByteString)
-> Parameters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> CI ByteString)
-> (ByteString, ByteString) -> (CI ByteString, CI ByteString)
forall {t} {b}. (t -> b) -> (t, t) -> (b, b)
both ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk) (Maybe (ByteString, ByteString) -> Maybe Parameters)
-> (ByteString -> Maybe (ByteString, ByteString))
-> ByteString
-> Maybe Parameters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> Maybe (ByteString, ByteString)
breakChar Char
'='

  matches :: MediaType -> MediaType -> Bool
matches MediaType
a MediaType
b
    | MediaType -> CI ByteString
mainType MediaType
b CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== CI ByteString
"*" = Bool
params
    | MediaType -> CI ByteString
subType MediaType
b CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== CI ByteString
"*" = MediaType -> CI ByteString
mainType MediaType
a CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== MediaType -> CI ByteString
mainType MediaType
b Bool -> Bool -> Bool
&& Bool
params
    | Bool
otherwise = Bool
main Bool -> Bool -> Bool
&& Bool
sub Bool -> Bool -> Bool
&& Bool
params
    where
      main :: Bool
main = MediaType -> CI ByteString
mainType MediaType
a CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== MediaType -> CI ByteString
mainType MediaType
b
      sub :: Bool
sub = MediaType -> CI ByteString
subType MediaType
a CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== MediaType -> CI ByteString
subType MediaType
b
      params :: Bool
params = Parameters -> Bool
forall k a. Map k a -> Bool
Map.null (MediaType -> Parameters
parameters MediaType
b) Bool -> Bool -> Bool
|| MediaType -> Parameters
parameters MediaType
a Parameters -> Parameters -> Bool
forall a. Eq a => a -> a -> Bool
== MediaType -> Parameters
parameters MediaType
b

  moreSpecificThan :: MediaType -> MediaType -> Bool
moreSpecificThan MediaType
a MediaType
b =
    (MediaType
a MediaType -> MediaType -> Bool
forall a. Accept a => a -> a -> Bool
`matches` MediaType
b Bool -> Bool -> Bool
&&) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      MediaType -> CI ByteString
mainType MediaType
a CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== CI ByteString
"*" Bool -> Bool -> Bool
&& Bool
anyB Bool -> Bool -> Bool
&& Bool
params
        Bool -> Bool -> Bool
|| MediaType -> CI ByteString
subType MediaType
a CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== CI ByteString
"*" Bool -> Bool -> Bool
&& (Bool
anyB Bool -> Bool -> Bool
|| Bool
subB Bool -> Bool -> Bool
&& Bool
params)
        Bool -> Bool -> Bool
|| Bool
anyB
        Bool -> Bool -> Bool
|| Bool
subB
        Bool -> Bool -> Bool
|| Bool
params
    where
      anyB :: Bool
anyB = MediaType -> CI ByteString
mainType MediaType
b CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== CI ByteString
"*"
      subB :: Bool
subB = MediaType -> CI ByteString
subType MediaType
b CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== CI ByteString
"*"
      params :: Bool
params = Bool -> Bool
not (Parameters -> Bool
forall k a. Map k a -> Bool
Map.null (Parameters -> Bool) -> Parameters -> Bool
forall a b. (a -> b) -> a -> b
$ MediaType -> Parameters
parameters MediaType
a) Bool -> Bool -> Bool
&& Parameters -> Bool
forall k a. Map k a -> Bool
Map.null (MediaType -> Parameters
parameters MediaType
b)

  hasExtensionParameters :: Proxy MediaType -> Bool
hasExtensionParameters Proxy MediaType
_ = Bool
True

instance RenderHeader MediaType where
  renderHeader :: MediaType -> ByteString
renderHeader (MediaType CI ByteString
a CI ByteString
b Parameters
p) =
    (CI ByteString -> CI ByteString -> ByteString -> ByteString)
-> ByteString -> Parameters -> ByteString
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey CI ByteString -> CI ByteString -> ByteString -> ByteString
forall {a}. (Semigroup a, IsString a) => CI a -> CI a -> a -> a
f (CI ByteString -> ByteString
forall s. CI s -> s
original CI ByteString
a ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> CI ByteString -> ByteString
forall s. CI s -> s
original CI ByteString
b) Parameters
p
    where
      f :: CI a -> CI a -> a -> a
f CI a
k CI a
v = (a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
";" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> CI a -> a
forall s. CI s -> s
original CI a
k a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"=" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> CI a -> a
forall s. CI s -> s
original CI a
v)

-- | 'MediaType' parameters.
type Parameters = Map (CI ByteString) (CI ByteString)