packages feed

http-media (empty) → 0.1.0

raw patch · 15 files changed

+1185/−0 lines, 15 filesdep +Cabaldep +QuickCheckdep +basesetup-changed

Dependencies added: Cabal, QuickCheck, base, bytestring, cabal-test-quickcheck, containers, utf8-string

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2012 Timothy Jones++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies+of the Software, and to permit persons to whom the Software is furnished to do+so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.+
+ Setup.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain+
+ http-media.cabal view
@@ -0,0 +1,81 @@+name:          http-media+version:       0.1.0+license:       MIT+license-file:  LICENSE+author:        Timothy Jones+maintainer:    Timothy Jones <git@zimothy.com>+homepage:      http://github.com/zimothy/http-media+bug-reports:   http://github.com/zimothy/http-media/issues+category:      Web+copyright:     (c) 2013 Timothy Jones+build-type:    Simple+cabal-version: >= 1.10+synopsis:      Processing HTTP Content-Type and Accept headers+description:+  This library is intended to be a comprehensive solution to parsing media+  types, including quality parameters, in HTTP headers. It addresses parsing of+  the Content-Type and Accept headers, and includes general data types for+  matching against the other accept headers as well. It encodes MIME parameters+  into a 'MediaType' data, and allows the matching of the final value by+  comparing quality values from the client.++library+  hs-source-dirs: src++  ghc-options: -Wall++  default-language: Haskell2010+  default-extensions:+    OverloadedStrings++  exposed-modules:+    Network.HTTP.Media+    Network.HTTP.Media.MediaType+  other-modules:+    Network.HTTP.Media.Match+    Network.HTTP.Media.MediaType.Internal+    Network.HTTP.Media.Quality+    Network.HTTP.Media.Utils+  build-depends:+    base        >= 4.6.0  && < 5.0,+    bytestring  >= 0.10.0 && < 0.11,+    containers  >= 0.5.0  && < 0.6,+    utf8-string >= 0.3.7  && < 0.4++test-suite test-http-media+  type:           detailed-0.9+  hs-source-dirs: src test++  default-language: Haskell2010+  default-extensions:+    OverloadedStrings++  test-module: Tests+  other-modules:+    Network.HTTP.Media+    Network.HTTP.Media.Gen+    Network.HTTP.Media.Match+    Network.HTTP.Media.Match.Tests+    Network.HTTP.Media.MediaType+    Network.HTTP.Media.MediaType.Gen+    Network.HTTP.Media.MediaType.Internal+    Network.HTTP.Media.MediaType.Tests+    Network.HTTP.Media.Quality+    Network.HTTP.Media.Tests+    Network.HTTP.Media.Utils++  ghc-options: -Wall -fhpc++  build-depends:+    base                  >= 4.6.0  && < 5.0,+    bytestring            >= 0.10.0 && < 0.11,+    Cabal                 >= 1.18.0 && < 1.19,+    cabal-test-quickcheck >= 0.1.0  && < 0.2,+    containers            >= 0.5.0  && < 0.6,+    QuickCheck            >= 2.6    && < 2.7,+    utf8-string           >= 0.3.7  && < 0.4++source-repository head+  type:     git+  location: git://github.com/zimothy/http-media.git+
+ src/Network/HTTP/Media.hs view
@@ -0,0 +1,140 @@+------------------------------------------------------------------------------+-- | A framework for parsing HTTP media type headers.+module Network.HTTP.Media+    (+      -- * Media types+      MediaType+    , (//)+    , (/:)+    , mainType+    , subType+    , parameters+    , (/?)+    , (/.)+    , matches+    , Quality++      -- * Parsing+    , parseAccept++      -- * Accept matching+    , matchAccept+    , mapAccept++      -- * Content matching+    , matchContent+    , mapContent+    ) where++------------------------------------------------------------------------------+import qualified Data.ByteString as BS++------------------------------------------------------------------------------+import Control.Applicative  (pure, (<*>), (<|>))+import Control.Monad        (guard)+import Data.ByteString      (ByteString, split)+import Data.ByteString.UTF8 (toString)++------------------------------------------------------------------------------+import Network.HTTP.Media.Match     as Match+import Network.HTTP.Media.MediaType as MediaType+import Network.HTTP.Media.Quality+import Network.HTTP.Media.Utils+++------------------------------------------------------------------------------+-- | Parses a full Accept header into a list of quality-valued media types.+parseAccept :: ByteString -> Maybe [Quality MediaType]+parseAccept = (. split comma) . mapM $ \bs ->+        let (accept, q) = BS.breakSubstring ";q=" $ BS.filter (/= space) bs+        in (<*> parse accept) $ if BS.null q+            then pure maxQuality else fmap (flip Quality) $ readQ+                (toString $ BS.takeWhile (/= semi) $ BS.drop 3 q)+++------------------------------------------------------------------------------+-- | Matches a list of server-side resource options against a quality-marked+-- list of client-side preferences. A result of 'Nothing' means that nothing+-- matched (which should indicate a 406 error). If two or more results arise+-- with the same quality level and specificity, then the first one in the+-- server list is chosen.+--+-- The use of the 'Match' type class allows the application of either+-- 'MediaType' for the standard Accept header or 'ByteString' for any other+-- Accept header which can be marked with a quality value. The standard+-- application of this function for 'MediaType' should be in conjunction with+-- 'parseAccepts'.+--+-- > parseAccepts header >>= matchQuality resourceTypeOptions+--+-- For more information on the matching process see RFC 2616, section 14.+matchAccept+    :: Match a+    => [a]          -- ^ The server-side options+    -> [Quality a]  -- ^ The client-side preferences+    -> Maybe a+matchAccept server clientq = guard (hq /= 0) >> specific qs+  where+    merge (Quality c q) = map (`Quality` q) $ filter (`matches` c) server+    matched = concatMap merge clientq+    (hq, qs) = foldr qfold (0, []) matched+    qfold (Quality v q) (mq, vs) = case compare q mq of+        GT -> (q, [v])+        EQ -> (mq, v : vs)+        LT -> (mq, vs)+    specific (a : ms) = Just $ foldl mostSpecific a ms+    specific []       = Nothing+++------------------------------------------------------------------------------+-- | The equivalent of 'matchAccept' above, except the resulting choice is+-- mapped to another value. Convenient for specifying how to translate the+-- resource into each of its available formats.+--+-- > maybe render406Error renderResource $ parseAccepts header >>= mapQuality+-- >     [ ("text/html",        asHtml)+-- >     , ("application/json", asJson)+-- >     ]+mapAccept+    :: Match a+    => [(a, b)]     -- ^ The map of server-side preferences to values+    -> [Quality a]  -- ^ The client-side preferences+    -> Maybe b+mapAccept s c = matchAccept (map fst s) c >>= lookupMatches s+++------------------------------------------------------------------------------+-- | Matches a list of server-side parsing options against a the client-side+-- content value. A result of 'Nothing' means that nothing matched (which+-- should indicate a 415 error).+--+-- As with the Accept parsing, he use of the 'Match' type class allows the+-- application of either 'MediaType' or 'ByteString'.+matchContent+    :: Match a+    => a         -- ^ The client's request value+    -> [a]       -- ^ The server-side response options+    -> Maybe a+matchContent client = foldl choose Nothing+  where choose m server = m <|> (guard (matches client server) >> Just server)+++------------------------------------------------------------------------------+-- | The equivalent of 'matchContent' above, except the resulting choice is+-- mapped to another value.+mapContent+    :: Match a+    => a         -- ^ The client request's header value+    -> [(a, b)]  -- ^ The map of server-side responses+    -> Maybe b+mapContent c s = matchContent c (map fst s) >>= lookupMatches s+++------------------------------------------------------------------------------+-- | The equivalent of 'lookupBy matches'.+lookupMatches :: Match a => [(a, b)] -> a -> Maybe b+lookupMatches ((k, v) : r) a+    | Match.matches k a = Just v+    | otherwise         = lookupMatches r a+lookupMatches [] _ = Nothing+
+ src/Network/HTTP/Media/Match.hs view
@@ -0,0 +1,40 @@+------------------------------------------------------------------------------+-- | Defines the 'Match' type class, designed to unify types on the+-- matching functions in the Media module.+module Network.HTTP.Media.Match+    (+      Match (..)+    , mostSpecific+    ) where++------------------------------------------------------------------------------+import Data.ByteString+++------------------------------------------------------------------------------+-- | Defines methods for a type whose values can be matched against each+-- other in terms of a HTTP media header.+--+-- This allows functions to work on both the standard Accept header and+-- others such as Accept-Language that still may use quality values.+class Match a where++    -- | Evaluates whether either the left argument matches the right one+    -- (order may be important).+    matches :: a -> a -> Bool++    -- | Evaluates whether the left argument is more specific than the right.+    moreSpecificThan :: a -> a -> Bool++instance Match ByteString where+    matches = (==)+    moreSpecificThan _ _ = False+++------------------------------------------------------------------------------+-- | Evaluates to whichever argument is more specific. Left biased.+mostSpecific :: Match a => a -> a -> a+mostSpecific a b+    | b `moreSpecificThan` a = b+    | otherwise              = a+
+ src/Network/HTTP/Media/MediaType.hs view
@@ -0,0 +1,105 @@+------------------------------------------------------------------------------+-- | Defines the media type types and functions.+module Network.HTTP.Media.MediaType+    (+    -- * Type and creation+      MediaType+    , Parameters+    , (//)+    , (/:)+    , parse+    , toByteString++    -- * Querying+    , mainType+    , subType+    , parameters+    , (/?)+    , (/.)+    ) where++------------------------------------------------------------------------------+import qualified Data.ByteString as BS+import qualified Data.Map        as Map++------------------------------------------------------------------------------+import Data.ByteString (ByteString)+import Data.Map        (empty, insert)+import Data.Word       (Word8)++------------------------------------------------------------------------------+import qualified Network.HTTP.Media.MediaType.Internal as Internal++------------------------------------------------------------------------------+import Network.HTTP.Media.MediaType.Internal (MediaType (MediaType))+import Network.HTTP.Media.MediaType.Internal hiding (MediaType (..))+import Network.HTTP.Media.Utils+++------------------------------------------------------------------------------+-- | Retrieves the main type of a 'MediaType'.+mainType :: MediaType -> ByteString+mainType = Internal.mainType+++------------------------------------------------------------------------------+-- | Retrieves the sub type of a 'MediaType'.+subType :: MediaType -> ByteString+subType = Internal.subType+++------------------------------------------------------------------------------+-- | Retrieves the parameters of a 'MediaType'.+parameters :: MediaType -> Parameters+parameters = Internal.parameters+++------------------------------------------------------------------------------+-- | Builds a 'MediaType' without parameters. Can produce an error if+-- either type is invalid.+(//) :: ByteString -> ByteString -> MediaType+a // b = MediaType (ensureR a) (ensureR b) empty+++------------------------------------------------------------------------------+-- | Adds a parameter to a 'MediaType'. Can produce an error if either+-- string is invalid.+(/:) :: MediaType -> (ByteString, ByteString) -> MediaType+(MediaType a b p) /: (k, v) = MediaType a b $ insert (ensureR k) (ensureV v) p+++------------------------------------------------------------------------------+-- | Evaluates if a 'MediaType' has a parameter of the given name.+(/?) :: MediaType -> ByteString -> Bool+(MediaType _ _ p) /? k = Map.member k p+++------------------------------------------------------------------------------+-- | Retrieves a parameter from a 'MediaType'.+(/.) :: MediaType -> ByteString -> Maybe ByteString+(MediaType _ _ p) /. k = Map.lookup k p+++------------------------------------------------------------------------------+-- | Ensures that the 'ByteString' matches the ABNF for `reg-name` in RFC+-- 4288.+ensureR :: ByteString -> ByteString+ensureR bs = if l == 0 || l > 127+    then error $ "Invalid length for " ++ show bs else ensure isValidChar bs+  where l = BS.length 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 -> ByteString+ensureV = ensure (`notElem` [44, 59])+++------------------------------------------------------------------------------+-- | Ensures the predicate matches for every character in the given string.+ensure :: (Word8 -> Bool) -> ByteString -> ByteString+ensure f bs = maybe+    (error $ "Invalid character in " ++ show bs) (const bs) (BS.find f bs)+
+ src/Network/HTTP/Media/MediaType/Internal.hs view
@@ -0,0 +1,91 @@+------------------------------------------------------------------------------+-- | Defined to allow the constructor of 'MediaType' to be exposed to tests.+module Network.HTTP.Media.MediaType.Internal+    ( MediaType (..)+    , Parameters+    , toByteString+    , parse+    ) where++------------------------------------------------------------------------------+import qualified Data.ByteString      as BS+import qualified Data.ByteString.UTF8 as BS+import qualified Data.Map             as Map++------------------------------------------------------------------------------+import Control.Monad        (guard)+import Data.ByteString      (ByteString)+import Data.ByteString.UTF8 (toString)+import Data.String          (IsString (..))+import Data.Map             (Map)+import Data.Maybe           (fromMaybe)+import Data.Monoid          ((<>))++------------------------------------------------------------------------------+import Network.HTTP.Media.Match (Match (..))+import Network.HTTP.Media.Utils+++------------------------------------------------------------------------------+-- | An HTTP media type, consisting of the type, subtype, and parameters.+data MediaType = MediaType+    { mainType   :: ByteString  -- ^ The main type of the MediaType+    , subType    :: ByteString  -- ^ The sub type of the MediaType+    , parameters :: Parameters  -- ^ The parameters of the MediaType+    } deriving (Eq)++instance Show MediaType where+    show (MediaType a b p) =+        Map.foldrWithKey f (toString a ++ '/' : toString b) p+      where+        f k v = (++ ';' : toString k ++ '=' : toString v)++instance IsString MediaType where+    fromString str = flip fromMaybe (parse $ BS.fromString str) $+        error $ "Invalid media type literal " ++ str++instance Match MediaType where+    matches a b+        | mainType b == "*" = params+        | subType b == "*"  = mainType a == mainType b && params+        | otherwise         = main && sub && params+      where+        main = mainType a == mainType b+        sub = subType a == subType b+        params = Map.null (parameters b) || parameters a == parameters b++    moreSpecificThan a b = (a `matches` b &&) $+        mainType a == "*" && anyB && params ||+        subType a == "*" && (anyB || subB && params) ||+        anyB || subB || params+      where+        anyB = mainType b == "*"+        subB = subType b == "*"+        params = not (Map.null $ parameters a) && Map.null (parameters b)+++------------------------------------------------------------------------------+-- | 'MediaType' parameters.+type Parameters = Map ByteString ByteString+++------------------------------------------------------------------------------+-- | Parses a media type header into a 'MediaType'.+parse :: ByteString -> Maybe MediaType+parse bs = do+    let pieces = BS.split semi bs+    guard $ not (null pieces)+    let (m : ps) = pieces+        (a, b)   = breakByte slash m+    guard $ BS.elem slash m && (a /= "*" || b == "*")+    return $ MediaType a b $+        foldr (uncurry Map.insert . breakByte equal) Map.empty ps+++------------------------------------------------------------------------------+-- | Converts 'MediaType' to 'ByteString'.+toByteString :: MediaType -> ByteString+toByteString (MediaType a b p) = Map.foldrWithKey f (a <> "/" <> b) p+  where+    f k v = (<> ";" <> k <> "=" <> v)+
+ src/Network/HTTP/Media/Quality.hs view
@@ -0,0 +1,57 @@+------------------------------------------------------------------------------+-- | Defines the quality value data type.+module Network.HTTP.Media.Quality+    ( Quality (..)+    , maxQuality+    , minQuality+    , readQ+    ) where++------------------------------------------------------------------------------+import Data.Maybe (listToMaybe)+import Data.Word  (Word16)+++------------------------------------------------------------------------------+-- | Attaches a quality value to data.+data Quality a = Quality+    { qualityData  :: a+    , qualityValue :: Word16+    } deriving (Eq)++instance Show a => Show (Quality a) where+    show (Quality a q) = show a ++ ";q=" ++ showQ q+++------------------------------------------------------------------------------+-- | Attaches the quality value '1'.+maxQuality :: a -> Quality a+maxQuality = flip Quality 1000+++------------------------------------------------------------------------------+-- | Attaches the quality value '0'.+minQuality :: a -> Quality a+minQuality = flip Quality 0+++------------------------------------------------------------------------------+showQ :: Word16 -> String+showQ 1000 = "1"+showQ 0    = "0"+showQ q    = '0' : '.' : let s = show q in replicate (3 - length s) '0' ++ s+++------------------------------------------------------------------------------+readQ :: String -> Maybe Word16+readQ "1" = Just 1000+readQ "0" = Just 0+readQ ('1' : '.' : t)+    | length t <= 3 && all (== '0') t = Just 1000+    | otherwise                       = Nothing+readQ ('0' : '.' : t)+    | length t <= 3 = fmap fst . listToMaybe . filter (null . snd) . reads $+        t ++ replicate (3 - length t) '0'+    | otherwise     = Nothing+readQ _   = Nothing+
+ src/Network/HTTP/Media/Utils.hs view
@@ -0,0 +1,60 @@+-----------------------------------------------------------------------------+-- | Common utilities.+module Network.HTTP.Media.Utils+    (+      breakByte+    , trimBS++    , validChars+    , isValidChar++    , slash+    , semi+    , comma+    , space+    , equal+    ) where++------------------------------------------------------------------------------+import qualified Data.ByteString as BS++------------------------------------------------------------------------------+import Data.ByteString (ByteString)+import Data.Word       (Word8)+++------------------------------------------------------------------------------+-- | Equivalent to 'Data.ByteString.breakByte', but leaves out the byte the+-- string is broken on.+breakByte :: Word8 -> ByteString -> (ByteString, ByteString)+breakByte w = fmap BS.tail . BS.breakByte w+++------------------------------------------------------------------------------+-- | Trims space characters from both ends of a ByteString.+trimBS :: ByteString -> ByteString+trimBS = BS.reverse . dropSpace . BS.reverse . dropSpace+  where+    dropSpace = BS.dropWhile (== space)+++------------------------------------------------------------------------------+-- | List of the valid characters for a media-type `reg-name` as per RFC 4288.+validChars :: [Word8]+validChars =+    [33, 35, 36, 37, 43, 45, 46, 94, 95] ++ [48..57] ++ [65..90] ++ [97..122]+++------------------------------------------------------------------------------+-- | Evaluates whether the given character is valid in a media type `reg-name`+-- as per RFC 4288.+isValidChar :: Word8 -> Bool+isValidChar c = c >= 97 && c <= 122 || c >= 48 && c <= 57 ||+    c >= 65 && c <= 90 || c `elem` [33, 35, 36, 37, 43, 45, 46, 94, 95]+++------------------------------------------------------------------------------+-- | 'ByteString' compatible characters.+slash, semi, comma, space, equal :: Word8+[slash, semi, comma, space, equal] = [47, 59, 44, 32, 61]+
+ test/Network/HTTP/Media/Gen.hs view
@@ -0,0 +1,29 @@+------------------------------------------------------------------------------+-- | Contains definitions for generating 'ByteString's.+module Network.HTTP.Media.Gen+    ( genByteString+    , genDiffByteString+    ) where++------------------------------------------------------------------------------+import Control.Monad       (liftM)+import Data.ByteString     (ByteString, pack)+import Test.QuickCheck.Gen (Gen, listOf1, oneof)+++------------------------------------------------------------------------------+-- | Produces a ByteString of random alpha characters.+genByteString :: Gen ByteString+genByteString = liftM pack $ listOf1 (oneof $ map return validChars)+  where+    validChars = [48..57] ++ [65..90] ++ [97..122]+++------------------------------------------------------------------------------+-- | Produces a random ByteString different to the given one.+genDiffByteString :: ByteString -> Gen ByteString+genDiffByteString bs = do+    bs' <- genByteString+    if bs == bs' then genDiffByteString bs else return bs'++
+ test/Network/HTTP/Media/Match/Tests.hs view
@@ -0,0 +1,48 @@+------------------------------------------------------------------------------+module Network.HTTP.Media.Match.Tests (tests) where++------------------------------------------------------------------------------+import Control.Monad                     (join, liftM, liftM2)+import Distribution.TestSuite.QuickCheck++------------------------------------------------------------------------------+import Network.HTTP.Media.Gen+import Network.HTTP.Media.Match+++------------------------------------------------------------------------------+tests :: [Test]+tests =+    [ testMatches+    , testMoreSpecificThan+    , testMostSpecific+    ]+++------------------------------------------------------------------------------+testMatches :: Test+testMatches = testGroup "matches"+    [ testProperty "Does match" $ do+        string <- genByteString+        return $ matches string string+    , testProperty "Doesn't match" $ do+        string  <- genByteString+        string' <- genDiffByteString string+        return . not $ matches string string'+    ]+++------------------------------------------------------------------------------+-- | Note that this test never actually generates any strings, as they are not+-- required for the 'moreSpecificThan' test.+testMoreSpecificThan :: Test+testMoreSpecificThan = testProperty "moreSpecificThan" $+    join (liftM2 ((not .) . moreSpecificThan)) genByteString+++------------------------------------------------------------------------------+testMostSpecific :: Test+testMostSpecific = testProperty "mostSpecific" $ do+    string <- genByteString+    liftM ((== string) . mostSpecific string) genByteString+
+ test/Network/HTTP/Media/MediaType/Gen.hs view
@@ -0,0 +1,174 @@+------------------------------------------------------------------------------+-- | Contains definitions for generating 'MediaType's.+module Network.HTTP.Media.MediaType.Gen+    (+    -- * Generating ByteStrings+      genByteString+    , genDiffByteString++    -- * Generating MediaTypes+    , anything+    , genMediaType+    , genSubStar+    , genMaybeSubStar+    , subStarOf+    , genConcreteMediaType+    , genWithoutParams+    , genWithParams+    , stripParams+    , genDiffMediaTypesWith+    , genDiffMediaTypeWith+    , genDiffMediaTypes+    , genDiffMediaType++    -- * Generating Parameters+    , genParameters+    , genMaybeParameters+    , genDiffParameters+    ) where++------------------------------------------------------------------------------+import qualified Data.Map as Map++------------------------------------------------------------------------------+import Control.Monad       (liftM, liftM2)+import Data.ByteString     (ByteString)+import Data.Map            (fromList)+import Test.QuickCheck.Gen++------------------------------------------------------------------------------+import Network.HTTP.Media.Gen+import Network.HTTP.Media.MediaType.Internal+++------------------------------------------------------------------------------+-- | Parameter entry for testing.+type ParamEntry = (ByteString, ByteString)+++------------------------------------------------------------------------------+-- | The MediaType that matches anything.+anything :: MediaType+anything = MediaType "*" "*" Map.empty+++------------------------------------------------------------------------------+-- | Generates any kind of MediaType.+genMediaType :: Gen MediaType+genMediaType = oneof [return anything, genSubStar, genConcreteMediaType]+++------------------------------------------------------------------------------+-- | Generates a MediaType with just a concrete main type.+genSubStar :: Gen MediaType+genSubStar = do+    main <- genByteString+    return $ MediaType main "*" Map.empty+++------------------------------------------------------------------------------+-- | Generates a MediaType whose sub type might be *.+genMaybeSubStar :: Gen MediaType+genMaybeSubStar = oneof [genSubStar, genConcreteMediaType]+++------------------------------------------------------------------------------+-- | Strips the sub type and parameters from a MediaType.+subStarOf :: MediaType -> MediaType+subStarOf media = media { subType = "*", parameters = Map.empty }+++------------------------------------------------------------------------------+-- | Generates a concrete MediaType which may have parameters.+genConcreteMediaType :: Gen MediaType+genConcreteMediaType = do+    main <- genByteString+    sub  <- genByteString+    params <- oneof [return Map.empty, genParameters]+    return $ MediaType main sub params+++------------------------------------------------------------------------------+-- | Generates a concrete MediaType with no parameters.+genWithoutParams :: Gen MediaType+genWithoutParams = do+    main <- genByteString+    sub  <- genByteString+    return $ MediaType main sub Map.empty+++------------------------------------------------------------------------------+-- | Generates a MediaType with at least one parameter.+genWithParams :: Gen MediaType+genWithParams = do+    main   <- genByteString+    sub    <- genByteString+    params <- genParameters+    return $ MediaType main sub params+++------------------------------------------------------------------------------+-- | Strips the parameters from the given MediaType.+stripParams :: MediaType -> MediaType+stripParams media = media { parameters = Map.empty }+++------------------------------------------------------------------------------+-- | Generates a different MediaType to the ones in the given list, using the+-- given generator.+genDiffMediaTypesWith :: Gen MediaType -> [MediaType] -> Gen MediaType+genDiffMediaTypesWith gen media = do+    media' <- gen+    if media' `elem` media+        then genDiffMediaTypesWith gen media+        else return media'+++------------------------------------------------------------------------------+-- | Generates a different MediaType to the given one, using the given+-- generator.+genDiffMediaTypeWith :: Gen MediaType -> MediaType -> Gen MediaType+genDiffMediaTypeWith gen = genDiffMediaTypesWith gen . (: [])+++------------------------------------------------------------------------------+-- | Generates a  different MediaType to the ones in the given list.+genDiffMediaTypes :: [MediaType] -> Gen MediaType+genDiffMediaTypes = genDiffMediaTypesWith genMediaType+++------------------------------------------------------------------------------+-- | Generates a different MediaType to the given one.+genDiffMediaType :: MediaType -> Gen MediaType+genDiffMediaType = genDiffMediaTypes . (: [])+++------------------------------------------------------------------------------+-- | Reuse for 'mayParams' and 'someParams'.+mkGenParams :: (Gen ParamEntry -> Gen [ParamEntry]) -> Gen Parameters+mkGenParams = liftM fromList .+    ($ liftM2 (,) (genDiffByteString "q") genByteString)+++------------------------------------------------------------------------------+-- | Generates some sort of parameters.+genMaybeParameters :: Gen Parameters+genMaybeParameters = mkGenParams listOf+++------------------------------------------------------------------------------+-- | Generates at least one parameter.+genParameters :: Gen Parameters+genParameters = mkGenParams listOf1+++------------------------------------------------------------------------------+-- | Generates a set of parameters that is not a submap of the given+-- parameters (but not necessarily vice versa).+genDiffParameters :: Parameters -> Gen Parameters+genDiffParameters params = do+    params' <- genParameters+    if params' `Map.isSubmapOf` params+        then genDiffParameters params+        else return params'+
+ test/Network/HTTP/Media/MediaType/Tests.hs view
@@ -0,0 +1,204 @@+------------------------------------------------------------------------------+module Network.HTTP.Media.MediaType.Tests (tests) where++------------------------------------------------------------------------------+import qualified Data.ByteString.UTF8 as BS+import qualified Data.Map             as Map++------------------------------------------------------------------------------+import Control.Monad                     (join, liftM)+import Data.String                       (fromString)+import Data.Maybe                        (isNothing)+import Data.Monoid                       ((<>), mconcat)+import Distribution.TestSuite.QuickCheck++------------------------------------------------------------------------------+import Network.HTTP.Media.Match+import Network.HTTP.Media.MediaType          ((/?), (/.))+import Network.HTTP.Media.MediaType.Internal+import Network.HTTP.Media.MediaType.Gen+++------------------------------------------------------------------------------+tests :: [Test]+tests =+    [ testEq+    , testShow+    , testFromString+    , testHas+    , testGet+    , testMatches+    , testMoreSpecificThan+    , testMostSpecific+    , testParse+    ]+++------------------------------------------------------------------------------+-- Equality is derived, but we test it here to get 100% coverage.+testEq :: Test+testEq = testGroup "Eq"+    [ testProperty "==" $ do+        media <- genMediaType+        return $ media == media+    , testProperty "/=" $ do+        media  <- genMediaType+        media' <- genDiffMediaType media+        return $ media /= media'+    ]+++------------------------------------------------------------------------------+testShow :: Test+testShow = testProperty "show" $ do+    media <- genMediaType+    return $ parse (BS.fromString $ show media) == Just media+++------------------------------------------------------------------------------+testFromString :: Test+testFromString = testProperty "fromString" $ do+    media <- genMediaType+    return $ media == fromString (show media)+++------------------------------------------------------------------------------+testHas :: Test+testHas = testGroup "(/?)"+    [ testProperty "True for property it has" $ do+        media <- genWithParams+        return $ all (media /?) (Map.keys $ parameters media)+    , testProperty "False for property it doesn't have" $ do+        media <- genWithParams+        return $ all (not . (stripParams media /?))+            (Map.keys $ parameters media)+    ]+++------------------------------------------------------------------------------+testGet :: Test+testGet = testGroup "(/.)"+    [ testProperty "Retrieves property it has" $ do+        media  <- genWithParams+        let is n v = (&& media /. n == Just v)+        return $ Map.foldrWithKey is True $ parameters media+    , testProperty "Nothing for property it doesn't have" $ do+        media <- genWithParams+        let is n _ = (&& isNothing (stripParams media /. n))+        return $ Map.foldrWithKey is True $ parameters media+    ]+++------------------------------------------------------------------------------+testMatches :: Test+testMatches = testGroup "matches"+    [ testProperty "Equal values match" $ do+        media <- genMediaType+        return $ matches media media+    , testProperty "Same sub but different main don't match" $ do+        media <- genMaybeSubStar+        main  <- genDiffByteString $ mainType media+        return $ not (matches media media { mainType = main }) &&+            not (matches media { mainType = main } media)+    , testProperty "Same main but different sub don't match" $ do+        media <- genConcreteMediaType+        sub   <- genDiffByteString $ subType media+        return . not $ matches media media { subType = sub } ||+            matches media { subType = sub } media+    , testProperty "Different parameters don't match" $+        liftM (not . dotJoin matches stripParams) genWithParams+    , testProperty "Missing parameters match" $ do+        media <- genWithParams+        let media' = stripParams media+        return $ matches media media' && not (matches media' media)+    , testGroup "*/*"+        [ testProperty "Matches itself" $ matches anything anything+        , testProperty "Matches anything on the right" $+            liftM (`matches` anything) genMediaType+        , testProperty "Doesn't match more specific on the left" $+            liftM (not . matches anything) genMaybeSubStar+        ]+    , testGroup "type/*"+        [ testProperty "Matches itself" $ liftM (join matches) genSubStar+        , testProperty "Matches on the right" $+            liftM (dotJoin (flip matches) subStarOf) genConcreteMediaType+        , testProperty "Doesn't match on the left" $+            liftM (not . dotJoin matches subStarOf) genConcreteMediaType+        ]+    ]+++------------------------------------------------------------------------------+testMoreSpecificThan :: Test+testMoreSpecificThan = testGroup "isMoreSpecific"+    [ testProperty "Against */*" $+        liftM (`moreSpecificThan` anything) genMaybeSubStar+    , testProperty "With */*" $+        liftM (not . moreSpecificThan anything) genMaybeSubStar+    , testProperty "Against type/*" $+        liftM (dotJoin (flip moreSpecificThan) subStarOf) genConcreteMediaType+    , testProperty "With type/*" $+        liftM (not . dotJoin moreSpecificThan subStarOf) genConcreteMediaType+    , testProperty "With parameters" $+        liftM (dotJoin (flip moreSpecificThan) stripParams) genWithParams+    , testProperty "Different types" $ do+        media  <- genWithoutParams+        media' <- genDiffMediaTypeWith genWithoutParams media+        return . not $+            moreSpecificThan media media' || moreSpecificThan media' media+    , testProperty "Different parameters" $ do+        media  <- genWithParams+        params <- genDiffParameters $ parameters media+        return . not $ moreSpecificThan media media { parameters = params }+    ]+++------------------------------------------------------------------------------+testMostSpecific :: Test+testMostSpecific = testGroup "mostSpecific"+    [ testProperty "With */*" $ do+        media <- genConcreteMediaType+        return $ mostSpecific media anything == media &&+            mostSpecific anything media == media+    , testProperty "With type/*" $ do+        media <- genConcreteMediaType+        let m1 = media { parameters = Map.empty }+            m2 = m1 { subType = "*" }+        return $ mostSpecific m1 m2 == m1 && mostSpecific m2 m1 == m1+    , testProperty "With parameters" $ do+        media  <- genMediaType+        params <- genParameters+        let media'  = media { parameters = params }+            media'' = media { parameters = Map.empty }+        return $ mostSpecific media' media'' == media' &&+            mostSpecific media'' media' == media'+    , testProperty "Different types" $ do+        media  <- genConcreteMediaType+        media' <- genDiffMediaTypeWith genConcreteMediaType media+        return $ mostSpecific media media' == media+    , testProperty "Left biased" $ do+        media  <- genConcreteMediaType+        media' <- genConcreteMediaType+        let media'' = media' { parameters = parameters media }+        return $ mostSpecific media media'' == media &&+            mostSpecific media'' media == media''+    ]+++------------------------------------------------------------------------------+testParse :: Test+testParse = testProperty "parse" $ do+    media <- genMediaType+    let main   = mainType media+        sub    = subType media+        params = parameters media+    let (Just parsed) = parse $ main <> "/" <> sub <> mconcat+            (map (uncurry ((<>) . (<> "=") . (";" <>))) $ Map.toList params)+    return $ parsed == media+++------------------------------------------------------------------------------+-- | Like 'join', but applies the given function to the first argument.+dotJoin :: (a -> a -> b) -> (a -> a) -> a -> b+dotJoin f g a = f (g a) a+
+ test/Network/HTTP/Media/Tests.hs view
@@ -0,0 +1,109 @@+------------------------------------------------------------------------------+module Network.HTTP.Media.Tests (tests) where++------------------------------------------------------------------------------+import Control.Monad                     (replicateM)+import Data.ByteString.UTF8              (fromString)+import Data.List                         (intercalate)+import Data.Map                          (empty)+import Data.Maybe                        (isNothing)+import Data.Word                         (Word16)+import Distribution.TestSuite.QuickCheck+import Test.QuickCheck++------------------------------------------------------------------------------+import Network.HTTP.Media                    hiding (parameters, subType)+import Network.HTTP.Media.MediaType.Gen+import Network.HTTP.Media.MediaType.Internal+import Network.HTTP.Media.Quality+++------------------------------------------------------------------------------+tests :: [Test]+tests =+    [ testParse+    , testMatch+    , testMap+    ]+++------------------------------------------------------------------------------+testParse :: Test+testParse = testGroup "parseAccept"+    [ testProperty "Without quality" $ do+        media <- medias+        return $+            parseAccept (group media) == Just (map maxQuality media)+    , testProperty "With quality" $ do+        media <- medias >>= mapM (flip fmap (choose (0, 1000)) . Quality)+        return $ parseAccept (group media) == Just media+    ]+  where+    medias = listOf1 genMediaType+    group media = fromString $ intercalate "," (map show media)+++------------------------------------------------------------------------------+testMatch :: Test+testMatch = testGroup "match"+    [ testProperty "Highest quality" $ do+        server <- genServer+        qs     <- replicateM (length server) $ choose (1, 1000)+        let client = zipWith Quality server qs+            qmax v q = if qualityValue q > qualityValue v then q else v+        return $ matchAccept server client ==+            Just (qualityData $ foldr1 qmax client)+    , testProperty "Most specific" $ do+        media <- genConcreteMediaType+        let client = map maxQuality+                [ MediaType "*" "*" empty+                , media { subType = "*" }+                , media { parameters = empty }+                , media+                ]+        return $ matchAccept [media] client == Just media+    , testProperty "Nothing" $ do+        server <- genServer+        client <- listOf1 $ genDiffMediaTypesWith genConcreteMediaType server+        let client' = filter (not . flip any server . matches) client+        return . isNothing $ matchAccept server (map maxQuality client')+    , testProperty "Never chooses q=0" $ do+        server <- genServer+        return . isNothing $ matchAccept server (map minQuality server)+    , testProperty "Left biased" $ do+        server <- genServer+        let client = map maxQuality server+        return $ matchAccept server client == Just (head server)+    , testProperty "Against */*" $ do+        server <- genServer+        return $ matchAccept server [maxQuality "*/*"] == Just (head server)+    , testProperty "Against type/*" $ do+        server <- genServer+        let client = [maxQuality (subStarOf $ head server)]+        return $ matchAccept server client == Just (head server)+    ]+++------------------------------------------------------------------------------+testMap :: Test+testMap = testGroup "map"+    [ testProperty "Matches" $ do+        server <- genServer+        qs     <- replicateM (length server) $ choose (1, 1000 :: Word16)+        let client = zipWith Quality server qs+            qmax q v = if qualityValue q >= qualityValue v then q else v+            zipped = zip server server+        return $ mapAccept zipped client ==+            Just (qualityData $ foldr1 qmax client)+    , testProperty "Nothing" $ do+        server <- genServer+        client <- listOf1 $ genDiffMediaTypesWith genConcreteMediaType server+        let zipped = zip server $ repeat ()+        return . isNothing $ mapAccept zipped (map maxQuality client)+    ]+++------------------------------------------------------------------------------+genServer :: Gen [MediaType]+genServer = listOf1 genConcreteMediaType+
+ test/Tests.hs view
@@ -0,0 +1,20 @@+------------------------------------------------------------------------------+module Tests (tests) where++------------------------------------------------------------------------------+import Distribution.TestSuite++------------------------------------------------------------------------------+import qualified Network.HTTP.Media.Tests           as Media+import qualified Network.HTTP.Media.Match.Tests     as Match+import qualified Network.HTTP.Media.MediaType.Tests as MediaType+++------------------------------------------------------------------------------+tests :: IO [Test]+tests = return+    [ testGroup "MediaType" MediaType.tests+    , testGroup "Match"     Match.tests+    , testGroup "Media"     Media.tests+    ]+