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

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

import           Control.Monad                   (foldM, guard)
import           Data.ByteString                 (ByteString)
import           Data.CaseInsensitive            (CI, original)
import           Data.Map                        (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)


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