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