------------------------------------------------------------------------------
-- | 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
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
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
Ord)

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

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

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

    moreSpecificThan :: MediaType -> MediaType -> Bool
moreSpecificThan MediaType
a MediaType
b = (MediaType
a forall a. Accept a => a -> a -> Bool
`matches` MediaType
b Bool -> Bool -> Bool
&&) forall a b. (a -> b) -> a -> b
$
        MediaType -> CI ByteString
mainType MediaType
a 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 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 forall a. Eq a => a -> a -> Bool
== CI ByteString
"*"
        subB :: Bool
subB = MediaType -> CI ByteString
subType MediaType
b forall a. Eq a => a -> a -> Bool
== CI ByteString
"*"
        params :: Bool
params = Bool -> Bool
not (forall k a. Map k a -> Bool
Map.null forall a b. (a -> b) -> a -> b
$ MediaType -> Parameters
parameters MediaType
a) Bool -> Bool -> 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) =
        forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey forall {a}. (Semigroup a, IsString a) => CI a -> CI a -> a -> a
f (forall s. CI s -> s
original CI ByteString
a forall a. Semigroup a => a -> a -> a
<> ByteString
"/" forall a. Semigroup a => a -> a -> a
<> 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 = (forall a. Semigroup a => a -> a -> a
<> a
";" forall a. Semigroup a => a -> a -> a
<> forall s. CI s -> s
original CI a
k forall a. Semigroup a => a -> a -> a
<> a
"=" forall a. Semigroup a => a -> a -> a
<> forall s. CI s -> s
original CI a
v)


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