http-media 0.7.1.3 → 0.8.0.0
raw patch · 24 files changed
+816/−277 lines, 24 filesdep ~QuickCheckdep ~basedep ~bytestring
Dependency ranges changed: QuickCheck, base, bytestring
Files
- CHANGES.md +22/−0
- http-media.cabal +15/−7
- src/Network/HTTP/Media.hs +97/−25
- src/Network/HTTP/Media/Accept.hs +0/−9
- src/Network/HTTP/Media/Charset.hs +7/−0
- src/Network/HTTP/Media/Charset/Internal.hs +51/−0
- src/Network/HTTP/Media/Encoding.hs +7/−0
- src/Network/HTTP/Media/Encoding/Internal.hs +54/−0
- src/Network/HTTP/Media/Language/Internal.hs +6/−10
- src/Network/HTTP/Media/MediaType.hs +1/−1
- src/Network/HTTP/Media/Quality.hs +35/−2
- src/Network/HTTP/Media/Utils.hs +35/−6
- test/Network/HTTP/Media/Accept/Tests.hs +4/−22
- test/Network/HTTP/Media/Charset/Gen.hs +49/−0
- test/Network/HTTP/Media/Charset/Tests.hs +92/−0
- test/Network/HTTP/Media/Encoding/Gen.hs +55/−0
- test/Network/HTTP/Media/Encoding/Tests.hs +91/−0
- test/Network/HTTP/Media/Gen.hs +30/−22
- test/Network/HTTP/Media/Language/Gen.hs +7/−14
- test/Network/HTTP/Media/Language/Tests.hs +11/−40
- test/Network/HTTP/Media/MediaType/Gen.hs +46/−21
- test/Network/HTTP/Media/MediaType/Tests.hs +17/−60
- test/Network/HTTP/Media/Tests.hs +79/−35
- test/Test.hs +5/−3
CHANGES.md view
@@ -1,6 +1,28 @@ Changelog ========= +- [Version 0.8.0.0](https://github.com/zmthy/http-media/releases/tag/v0.8.0.0)++ Removed official support for GHC 7.8.++ A separate `QualityOrder` type can now be extracted from a `Quality`+ value for performing comparisons without the attached data value.++ The most specific match will now be used to assign a quality value to+ each server option, ensuring that less specific matches cannot+ override lower quality values on more specific matches. In particular,+ if a type is considered unacceptable by the client, then a separate+ match with a non-zero quality value cannot make it acceptable.++ Numeric characters are now permitted in the tail of a Language value.++ Added support for Accept-Encoding and Content-Encoding.++ Added support for Accept-Charset and Content-Charset.++ The bounds for QuickCheck have been updated to include the latest+ version.+ - [Version 0.7.1.3](https://github.com/zmthy/http-media/releases/tag/v0.7.1.3) Package bounds have been updated for GHC 8.6.
http-media.cabal view
@@ -1,12 +1,12 @@ name: http-media-version: 0.7.1.3+version: 0.8.0.0 license: MIT license-file: LICENSE author: Timothy Jones maintainer: Timothy Jones <tim@zmthy.net> homepage: https://github.com/zmthy/http-media bug-reports: https://github.com/zmthy/http-media/issues-copyright: (c) 2012-2017 Timothy Jones+copyright: (c) 2012-2019 Timothy Jones category: Web build-type: Simple cabal-version: >= 1.10@@ -53,17 +53,18 @@ default-extensions: OverloadedStrings - other-extensions:- CPP- exposed-modules: Network.HTTP.Media Network.HTTP.Media.Accept+ Network.HTTP.Media.Charset+ Network.HTTP.Media.Encoding Network.HTTP.Media.Language Network.HTTP.Media.MediaType Network.HTTP.Media.RenderHeader other-modules:+ Network.HTTP.Media.Charset.Internal+ Network.HTTP.Media.Encoding.Internal Network.HTTP.Media.Language.Internal Network.HTTP.Media.MediaType.Internal Network.HTTP.Media.Quality@@ -92,14 +93,21 @@ OverloadedStrings other-extensions:- CPP TupleSections other-modules: Network.HTTP.Media Network.HTTP.Media.Accept Network.HTTP.Media.Accept.Tests+ Network.HTTP.Media.Charset+ Network.HTTP.Media.Charset.Gen+ Network.HTTP.Media.Charset.Internal+ Network.HTTP.Media.Charset.Tests Network.HTTP.Media.Gen+ Network.HTTP.Media.Encoding+ Network.HTTP.Media.Encoding.Gen+ Network.HTTP.Media.Encoding.Internal+ Network.HTTP.Media.Encoding.Tests Network.HTTP.Media.Language Network.HTTP.Media.Language.Gen Network.HTTP.Media.Language.Internal@@ -119,7 +127,7 @@ case-insensitive >= 1.0 && < 1.3, containers >= 0.5 && < 0.7, utf8-string >= 0.3 && < 1.1,- QuickCheck >= 2.6 && < 2.13,+ QuickCheck >= 2.8 && < 2.14, test-framework >= 0.8 && < 0.9, test-framework-quickcheck2 >= 0.3 && < 0.4
src/Network/HTTP/Media.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- ------------------------------------------------------------------------------ -- | A framework for parsing HTTP media type headers. module Network.HTTP.Media@@ -14,6 +12,12 @@ , (/?) , (/.) + -- * Charsets+ , Charset++ -- * Encodings+ , Encoding+ -- * Languages , Language , toParts@@ -22,6 +26,8 @@ , matchAccept , mapAccept , mapAcceptMedia+ , mapAcceptCharset+ , mapAcceptEncoding , mapAcceptLanguage , mapAcceptBytes @@ -29,11 +35,15 @@ , matchContent , mapContent , mapContentMedia+ , mapContentCharset+ , mapContentEncoding , mapContentLanguage -- * Quality values , Quality , quality+ , QualityOrder+ , qualityOrder , maxQuality , minQuality , parseQuality@@ -47,20 +57,20 @@ , RenderHeader (..) ) where -#if MIN_VERSION_base(4, 8, 0) import Control.Applicative ((<|>))-#else-import Control.Applicative (pure, (<$>), (<*>), (<|>))-#endif import qualified Data.ByteString.Char8 as BS import Control.Monad (guard, (>=>)) import Data.ByteString (ByteString)+import Data.Foldable (foldl', maximumBy)+import Data.Function (on) import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (Proxy)) import Network.HTTP.Media.Accept as Accept+import Network.HTTP.Media.Charset as Charset+import Network.HTTP.Media.Encoding as Encoding import Network.HTTP.Media.Language as Language import Network.HTTP.Media.MediaType as MediaType import Network.HTTP.Media.Quality@@ -123,12 +133,42 @@ ------------------------------------------------------------------------------+-- | A specialisation of 'mapAccept' that only takes 'Charset' as its input,+-- to avoid ambiguous-type errors when using string literal overloading.+--+-- > getHeader >>= maybe render406Error renderResource . mapAcceptCharset+-- > [ ("utf-8", inUtf8)+-- > , ("us-ascii", inAscii)+-- > ]+mapAcceptCharset ::+ [(Charset, b)] -- ^ The map of server-side preferences to values+ -> ByteString -- ^ The client-side header value+ -> Maybe b+mapAcceptCharset = mapAccept+++------------------------------------------------------------------------------+-- | A specialisation of 'mapAccept' that only takes 'Encoding' as its input,+-- to avoid ambiguous-type errors when using string literal overloading.+--+-- > getHeader >>= maybe render406Error renderResource . mapAcceptEncoding+-- > [ ("compress", compress)+-- > , ("identity", id)+-- > ]+mapAcceptEncoding ::+ [(Encoding, b)] -- ^ The map of server-side preferences to values+ -> ByteString -- ^ The client-side header value+ -> Maybe b+mapAcceptEncoding = mapAccept+++------------------------------------------------------------------------------ -- | A specialisation of 'mapAccept' that only takes 'Language' as its input, -- to avoid ambiguous-type errors when using string literal overloading. -- -- > getHeader >>= maybe render406Error renderResource . mapAcceptLanguage--- > [ ("text/html", asHtml)--- > , ("application/json", asJson)+-- > [ ("en-gb", inBritishEnglish)+-- > , ("fr", inFrench) -- > ] mapAcceptLanguage :: [(Language, b)] -- ^ The map of server-side preferences to values@@ -143,8 +183,8 @@ -- overloading. -- -- > getHeader >>= maybe render406Error encodeResourceWith . mapAcceptBytes--- > [ ("compress", compress)--- > , ("gzip", gzip)+-- > [ ("abc", abc)+-- > , ("xyz", xyz) -- > ] mapAcceptBytes :: [(ByteString, b)] -- ^ The map of server-side preferences to values@@ -208,17 +248,49 @@ ------------------------------------------------------------------------------+-- | A specialisation of 'mapContent' that only takes 'Charset' as its input,+-- to avoid ambiguous-type errors when using string literal overloading.+--+-- > getContentCharset >>=+-- > maybe send415Error readRequestBodyWith . mapContentCharset+-- > [ ("utf-8", parseUtf8)+-- > , ("us-ascii", parseAscii)+-- > ]+mapContentCharset+ :: [(Charset, b)] -- ^ The map of server-side responses+ -> ByteString -- ^ The client request's header value+ -> Maybe b+mapContentCharset = mapContent+++------------------------------------------------------------------------------+-- | A specialisation of 'mapContent' that only takes 'Encoding' as its input,+-- to avoid ambiguous-type errors when using string literal overloading.+--+-- > getContentEncoding >>=+-- > maybe send415Error readRequestBodyWith . mapContentEncoding+-- > [ ("compress", decompress)+-- > , ("identity", id)+-- > ]+mapContentEncoding+ :: [(Encoding, b)] -- ^ The map of server-side responses+ -> ByteString -- ^ The client request's header value+ -> Maybe b+mapContentEncoding = mapContent+++------------------------------------------------------------------------------ -- | A specialisation of 'mapContent' that only takes 'Language' as its input, -- to avoid ambiguous-type errors when using string literal overloading. ----- > getContentType >>=+-- > getContentLanguage >>= -- > maybe send415Error readRequestBodyWith . mapContentLanguage--- > [ ("application/json", parseJson)--- > , ("text/plain", parseText)+-- > [ ("en-gb", parseBritishEnglish)+-- > , ("fr", parseFrench) -- > ] mapContentLanguage :: [(Language, b)] -- ^ The map of server-side responses- -> ByteString -- ^ The client request's header value+ -> ByteString -- ^ The client request's header value -> Maybe b mapContentLanguage = mapContent @@ -270,17 +342,17 @@ -> [Quality a] -- ^ The pre-parsed client-side header value -> Maybe a matchQuality options acceptq = do- let merge (Quality c q) = map (`Quality` q) $ filter (`matches` c) options- matched = concatMap merge acceptq- (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- guard (hq /= 0)- specific qs+ guard $ not (null options)+ Quality m q <- maximumBy (compare `on` fmap qualityOrder) optionsq+ guard $ q /= 0+ return m+ where+ optionsq = reverse $ map addQuality options+ addQuality opt = withQValue opt <$> foldl' (mfold opt) Nothing acceptq+ withQValue opt qv = qv { qualityData = opt }+ mfold opt cur acq@(Quality acd _)+ | opt `matches` acd = mostSpecific acq <$> cur <|> Just acq+ | otherwise = cur ------------------------------------------------------------------------------
src/Network/HTTP/Media/Accept.hs view
@@ -3,7 +3,6 @@ -- functions in the Media module. module Network.HTTP.Media.Accept ( Accept (..)- , mostSpecific ) where import qualified Data.CaseInsensitive as CI@@ -55,11 +54,3 @@ parseAccept = Just matches a b = CI.mk a == CI.mk b moreSpecificThan _ _ = False------------------------------------------------------------------------------------ | Evaluates to whichever argument is more specific. Left biased.-mostSpecific :: Accept a => a -> a -> a-mostSpecific a b- | b `moreSpecificThan` a = b- | otherwise = a
+ src/Network/HTTP/Media/Charset.hs view
@@ -0,0 +1,7 @@+------------------------------------------------------------------------------+-- | Defines the 'Charset' accept header with an 'Accept' instance for use in+-- encoding negotiation.+module Network.HTTP.Media.Charset+ ( Charset ) where++import Network.HTTP.Media.Charset.Internal
+ src/Network/HTTP/Media/Charset/Internal.hs view
@@ -0,0 +1,51 @@+------------------------------------------------------------------------------+-- | Defines the 'Charset' accept header with an 'Accept' instance for use in+-- language negotiation.+module Network.HTTP.Media.Charset.Internal+ ( Charset (..)+ ) where++import qualified Data.ByteString.Char8 as BS+import qualified Data.CaseInsensitive as CI++import Control.Monad (guard)+import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI, original)+import Data.Maybe (fromMaybe)+import Data.String (IsString (..))++import Network.HTTP.Media.Accept (Accept (..))+import Network.HTTP.Media.RenderHeader (RenderHeader (..))+import Network.HTTP.Media.Utils (isValidToken)+++------------------------------------------------------------------------------+-- | Suitable for HTTP charset as defined in+-- <https://tools.ietf.org/html/rfc7231#section-5.3.3 RFC7231>.+--+-- Specifically:+--+-- > charset = token / "*"+newtype Charset = Charset (CI ByteString)+ deriving (Eq, Ord)++instance Show Charset where+ show = BS.unpack . renderHeader++instance IsString Charset where+ fromString str = flip fromMaybe (parseAccept $ BS.pack str) $+ error $ "Invalid encoding literal " ++ str++instance Accept Charset where+ parseAccept bs = do+ guard $ isValidToken bs+ return $ Charset (CI.mk bs)++ matches _ (Charset "*") = True+ matches a b = a == b++ moreSpecificThan _ (Charset "*") = True+ moreSpecificThan _ _ = False++instance RenderHeader Charset where+ renderHeader (Charset e) = original e
+ src/Network/HTTP/Media/Encoding.hs view
@@ -0,0 +1,7 @@+------------------------------------------------------------------------------+-- | Defines the 'Encoding' accept header with an 'Accept' instance for use in+-- encoding negotiation.+module Network.HTTP.Media.Encoding+ ( Encoding ) where++import Network.HTTP.Media.Encoding.Internal
+ src/Network/HTTP/Media/Encoding/Internal.hs view
@@ -0,0 +1,54 @@+------------------------------------------------------------------------------+-- | Defines the 'Encoding' accept header with an 'Accept' instance for use in+-- language negotiation.+module Network.HTTP.Media.Encoding.Internal+ ( Encoding (..)+ ) where++import qualified Data.ByteString.Char8 as BS+import qualified Data.CaseInsensitive as CI++import Control.Monad (guard)+import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI, original)+import Data.Maybe (fromMaybe)+import Data.String (IsString (..))++import Network.HTTP.Media.Accept (Accept (..))+import Network.HTTP.Media.RenderHeader (RenderHeader (..))+import Network.HTTP.Media.Utils (isValidToken)+++------------------------------------------------------------------------------+-- | Suitable for HTTP encoding as defined in+-- <https://tools.ietf.org/html/rfc7231#section-5.3.4 RFC7231>.+--+-- Specifically:+--+-- > codings = content-coding / "identity" / "*"+newtype Encoding = Encoding (CI ByteString)+ deriving (Eq, Ord)++instance Show Encoding where+ show = BS.unpack . renderHeader++instance IsString Encoding where+ fromString str = flip fromMaybe (parseAccept $ BS.pack str) $+ error $ "Invalid encoding literal " ++ str++instance Accept Encoding where+ -- This handles the case where the header value is empty, but it also+ -- allows technically invalid values such as "compress;q=0.8,;q=0.5".+ parseAccept "" = Just $ Encoding "identity"+ parseAccept bs = do+ guard $ isValidToken bs+ return $ Encoding (CI.mk bs)++ matches _ (Encoding "*") = True+ matches a b = a == b++ moreSpecificThan _ (Encoding "*") = True+ moreSpecificThan _ _ = False++instance RenderHeader Encoding where+ renderHeader (Encoding e) = original e
src/Network/HTTP/Media/Language/Internal.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- ------------------------------------------------------------------------------ -- | Defines the 'Language' accept header with an 'Accept' instance for use in -- language negotiation.@@ -7,17 +5,13 @@ ( Language (..) ) where -#if !MIN_VERSION_base(4, 8, 0)-import Data.Functor ((<$>))-#endif- import qualified Data.ByteString.Char8 as BS import qualified Data.CaseInsensitive as CI import Control.Monad (guard) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI, original)-import Data.Char (isAlpha)+import Data.Char (isAlpha, isAlphaNum) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe) import Data.String (IsString (..))@@ -28,11 +22,11 @@ ------------------------------------------------------------------------------ -- | Suitable for HTTP language-ranges as defined in--- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.4 RFC2616>.+-- <https://tools.ietf.org/html/rfc4647#section-2.1 RFC4647>. -- -- Specifically: ----- > language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" )+-- > language-range = (1*8ALPHA *("-" 1*8alphanum)) / "*" newtype Language = Language [CI ByteString] deriving (Eq, Ord) @@ -55,7 +49,9 @@ where check part = do let len = BS.length part- guard $ len >= 1 && len <= 8 && BS.all isAlpha part+ guard $ len >= 1 && len <= 8 &&+ isAlpha (BS.head part) &&+ BS.all isAlphaNum (BS.tail part) return (CI.mk part) -- Languages match if the right argument is a prefix of the left.
src/Network/HTTP/Media/MediaType.hs view
@@ -84,7 +84,7 @@ -- 4288. ensureR :: ByteString -> CI ByteString ensureR bs = CI.mk $ if l == 0 || l > 127- then error $ "Invalid length for " ++ show bs else ensure isValidChar bs+ then error $ "Invalid length for " ++ show bs else ensure isMediaChar bs where l = BS.length bs
src/Network/HTTP/Media/Quality.hs view
@@ -1,10 +1,15 @@+{-# LANGUAGE DeriveFunctor #-}+ ------------------------------------------------------------------------------ -- | Defines the quality value data type. module Network.HTTP.Media.Quality ( Quality (..) , quality+ , QualityOrder+ , qualityOrder , maxQuality , minQuality+ , mostSpecific , showQ , readQ ) where@@ -17,16 +22,18 @@ import Data.List (dropWhileEnd) import Data.Maybe (fromMaybe) import Data.Monoid ((<>))-import Data.Word (Word16)+import Data.Word (Word16, Word32) +import Network.HTTP.Media.Accept (Accept, moreSpecificThan) import Network.HTTP.Media.RenderHeader (RenderHeader (..)) + ------------------------------------------------------------------------------ -- | Attaches a quality value to data. data Quality a = Quality { qualityData :: a , qualityValue :: Word16- } deriving (Eq, Ord)+ } deriving (Eq, Functor, Ord) instance RenderHeader a => Show (Quality a) where show = BS.unpack . renderHeader@@ -43,6 +50,19 @@ ------------------------------------------------------------------------------+-- | An opaque ordered representation of quality values without attached data.+newtype QualityOrder = QualityOrder Word16+ deriving (Eq, Ord)+++------------------------------------------------------------------------------+-- | Remove the attached data from a quality value, retaining only the+-- priority of the quality parameter.+qualityOrder :: Quality a -> QualityOrder+qualityOrder = QualityOrder . qualityValue+++------------------------------------------------------------------------------ -- | Attaches the quality value '1'. maxQuality :: a -> Quality a maxQuality = flip Quality 1000@@ -52,6 +72,19 @@ -- | Attaches the quality value '0'. minQuality :: a -> Quality a minQuality = flip Quality 0+++------------------------------------------------------------------------------+-- | Combines quality values by specificity. Selects the more specific of the+-- two arguments, but if they are the same returns the data of the left+-- argument with the two quality values of both arguments combined.+mostSpecific :: Accept a => Quality a -> Quality a -> Quality a+mostSpecific (Quality a q) (Quality b r)+ | a `moreSpecificThan` b = Quality a q+ | b `moreSpecificThan` a = Quality b r+ | otherwise = Quality a q'+ where+ q' = fromIntegral (fromIntegral q * fromIntegral r `div` 1000 :: Word32) ------------------------------------------------------------------------------
src/Network/HTTP/Media/Utils.hs view
@@ -4,13 +4,18 @@ ( breakChar , trimBS - , validChars- , isValidChar+ , mediaChars+ , isMediaChar++ , tokenChars+ , isTokenChar+ , isValidToken ) where import qualified Data.ByteString.Char8 as BS import Data.ByteString (ByteString)+import Data.Char (isControl) ------------------------------------------------------------------------------@@ -34,12 +39,36 @@ ------------------------------------------------------------------------------ -- | List of the valid characters for a media-type `reg-name` as per RFC 4288.-validChars :: [Char]-validChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "!#$&.+-^_"+mediaChars :: [Char]+mediaChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "!#$&.+-^_" ------------------------------------------------------------------------------ -- | Evaluates whether the given character is valid in a media type `reg-name` -- as per RFC 4288.-isValidChar :: Char -> Bool-isValidChar = (`elem` validChars)+isMediaChar :: Char -> Bool+isMediaChar = (`elem` mediaChars)+++------------------------------------------------------------------------------+-- | Evaluates whether the given character is valid in an HTTP header token as+-- per RFC 2616.+isTokenChar :: Char -> Bool+isTokenChar = (||) <$> not . isControl <*> (`notElem` separators)+ where+ separators = [ '(', ')', '<', '>', '@', ',', ';', ':', '\\'+ , '"', '/', '[', ']', '?', '=', '{', '}', ' '+ ]+++------------------------------------------------------------------------------+-- | HTTP header token characters as per RFC 2616.+tokenChars :: [Char]+tokenChars = filter isTokenChar ['\0'..'\127']+++------------------------------------------------------------------------------+-- | Evaluates whether the given ASCII string is valid as an HTTP header token+-- as per RFC 2616.+isValidToken :: ByteString -> Bool+isValidToken = (&&) <$> not . BS.null <*> BS.all isTokenChar
test/Network/HTTP/Media/Accept/Tests.hs view
@@ -1,21 +1,11 @@-{-# LANGUAGE CPP #-}- ------------------------------------------------------------------------------ module Network.HTTP.Media.Accept.Tests (tests) where --------------------------------------------------------------------------------#if !MIN_VERSION_base(4, 8, 0)-import Control.Applicative ((<$>), (<*>))-#endif---------------------------------------------------------------------------------import Test.Framework (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck ((===))+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty) --------------------------------------------------------------------------------import Network.HTTP.Media.Accept-import Network.HTTP.Media.Gen+import Network.HTTP.Media.Accept+import Network.HTTP.Media.Gen ------------------------------------------------------------------------------@@ -23,7 +13,6 @@ tests = [ testMatches , testMoreSpecificThan- , testMostSpecific ] @@ -46,10 +35,3 @@ testMoreSpecificThan :: Test testMoreSpecificThan = testProperty "moreSpecificThan" $ (not .) . moreSpecificThan <$> genByteString <*> genByteString----------------------------------------------------------------------------------testMostSpecific :: Test-testMostSpecific = testProperty "mostSpecific" $ do- string <- genByteString- (=== string) . mostSpecific string <$> genByteString
+ test/Network/HTTP/Media/Charset/Gen.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE TupleSections #-}++------------------------------------------------------------------------------+-- | Contains definitions for generating 'Charset's.+module Network.HTTP.Media.Charset.Gen+ ( anything+ , genCharset+ , genConcreteCharset+ , genDiffCharset+ , genDiffConcreteCharsets+ ) where++import Test.QuickCheck.Gen++import Network.HTTP.Media.Gen (genDiffWith, genToken)++import Network.HTTP.Media.Charset.Internal+++------------------------------------------------------------------------------+-- | The Charset that matches anything.+anything :: Charset+anything = Charset "*"+++------------------------------------------------------------------------------+-- | Generates any kind of Charset.+genCharset :: Gen Charset+genCharset = Charset <$> genToken+++------------------------------------------------------------------------------+-- | Generates an Charset that does not match everything.+genConcreteCharset :: Gen Charset+genConcreteCharset = genDiffWith genCharset anything+++------------------------------------------------------------------------------+-- | Generates a different Charset to the given one.+genDiffCharset :: Charset -> Gen Charset+genDiffCharset = genDiffWith genCharset+++------------------------------------------------------------------------------+-- | Generates two different concrete Charsets.+genDiffConcreteCharsets :: Gen (Charset, Charset)+genDiffConcreteCharsets = do+ enc <- genConcreteCharset+ (enc,) <$> genDiffWith genConcreteCharset enc
+ test/Network/HTTP/Media/Charset/Tests.hs view
@@ -0,0 +1,92 @@+------------------------------------------------------------------------------+module Network.HTTP.Media.Charset.Tests (tests) where++import qualified Data.ByteString.Char8 as BS++import Control.Monad (join)+import Data.String (fromString)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck ((===))++import Network.HTTP.Media.Accept+import Network.HTTP.Media.Charset (Charset)+import Network.HTTP.Media.Charset.Gen+import Network.HTTP.Media.RenderHeader+++------------------------------------------------------------------------------+tests :: [Test]+tests =+ [ testEq+ , testShow+ , testFromString+ , testMatches+ , testMoreSpecific+ , testParseAccept+ ]+++------------------------------------------------------------------------------+-- Equality is derived, but we test it here to get 100% coverage.+testEq :: Test+testEq = testGroup "Eq"+ [ testProperty "==" $ do+ enc <- genCharset+ return $ enc === enc+ , testProperty "/=" $ do+ enc <- genCharset+ enc' <- genDiffCharset enc+ return $ enc /= enc'+ ]+++------------------------------------------------------------------------------+testShow :: Test+testShow = testProperty "show" $ do+ enc <- genCharset+ return $ parseAccept (BS.pack $ show enc) === Just enc+++------------------------------------------------------------------------------+testFromString :: Test+testFromString = testProperty "fromString" $ do+ enc <- genCharset+ return $ enc === fromString (show enc)+++------------------------------------------------------------------------------+testMatches :: Test+testMatches = testGroup "matches"+ [ testProperty "Equal values match" $+ join matches <$> genCharset+ , testProperty "* matches anything" $+ flip matches anything <$> genCharset+ , testProperty "No concrete encoding matches *" $+ not . matches anything <$> genConcreteCharset+ ]+++------------------------------------------------------------------------------+testMoreSpecific :: Test+testMoreSpecific = testGroup "moreSpecificThan"+ [ testProperty "Against *" $+ flip moreSpecificThan anything <$> genConcreteCharset+ , testProperty "With *" $+ not . moreSpecificThan anything <$> genConcreteCharset+ , testProperty "Unrelated encodings" $+ not . uncurry moreSpecificThan <$> genDiffConcreteCharsets+ ]+++------------------------------------------------------------------------------+testParseAccept :: Test+testParseAccept = testGroup "parseAccept"+ [ testProperty "Empty" $+ parseAccept "" === (Nothing :: Maybe Charset)+ , testProperty "Wildcard" $+ parseAccept "*" === Just anything+ , testProperty "Valid parse" $ do+ enc <- genCharset+ return $ parseAccept (renderHeader enc) === Just enc+ ]
+ test/Network/HTTP/Media/Encoding/Gen.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE TupleSections #-}++------------------------------------------------------------------------------+-- | Contains definitions for generating 'Encoding's.+module Network.HTTP.Media.Encoding.Gen+ ( anything+ , identity+ , genEncoding+ , genConcreteEncoding+ , genDiffEncoding+ , genDiffConcreteEncodings+ ) where++import Test.QuickCheck.Gen++import Network.HTTP.Media.Encoding.Internal+import Network.HTTP.Media.Gen (genDiffWith, genToken)+++------------------------------------------------------------------------------+-- | The Encoding that matches anything.+anything :: Encoding+anything = Encoding "*"+++------------------------------------------------------------------------------+-- | The default Encoding.+identity :: Encoding+identity = Encoding "identity"+++------------------------------------------------------------------------------+-- | Generates any kind of Encoding.+genEncoding :: Gen Encoding+genEncoding = Encoding <$> genToken+++------------------------------------------------------------------------------+-- | Generates an Encoding that does not match everything.+genConcreteEncoding :: Gen Encoding+genConcreteEncoding = genDiffWith genEncoding anything+++------------------------------------------------------------------------------+-- | Generates a different Encoding to the given one.+genDiffEncoding :: Encoding -> Gen Encoding+genDiffEncoding = genDiffWith genEncoding+++------------------------------------------------------------------------------+-- | Generates two different concrete Encodings.+genDiffConcreteEncodings :: Gen (Encoding, Encoding)+genDiffConcreteEncodings = do+ enc <- genConcreteEncoding+ (enc,) <$> genDiffWith genConcreteEncoding enc
+ test/Network/HTTP/Media/Encoding/Tests.hs view
@@ -0,0 +1,91 @@+------------------------------------------------------------------------------+module Network.HTTP.Media.Encoding.Tests (tests) where++import qualified Data.ByteString.Char8 as BS++import Control.Monad (join)+import Data.String (fromString)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck ((===))++import Network.HTTP.Media.Accept+import Network.HTTP.Media.Encoding.Gen+import Network.HTTP.Media.RenderHeader+++------------------------------------------------------------------------------+tests :: [Test]+tests =+ [ testEq+ , testShow+ , testFromString+ , testMatches+ , testMoreSpecific+ , testParseAccept+ ]+++------------------------------------------------------------------------------+-- Equality is derived, but we test it here to get 100% coverage.+testEq :: Test+testEq = testGroup "Eq"+ [ testProperty "==" $ do+ enc <- genEncoding+ return $ enc === enc+ , testProperty "/=" $ do+ enc <- genEncoding+ enc' <- genDiffEncoding enc+ return $ enc /= enc'+ ]+++------------------------------------------------------------------------------+testShow :: Test+testShow = testProperty "show" $ do+ enc <- genEncoding+ return $ parseAccept (BS.pack $ show enc) === Just enc+++------------------------------------------------------------------------------+testFromString :: Test+testFromString = testProperty "fromString" $ do+ enc <- genEncoding+ return $ enc === fromString (show enc)+++------------------------------------------------------------------------------+testMatches :: Test+testMatches = testGroup "matches"+ [ testProperty "Equal values match" $+ join matches <$> genEncoding+ , testProperty "* matches anything" $+ flip matches anything <$> genEncoding+ , testProperty "No concrete encoding matches *" $+ not . matches anything <$> genConcreteEncoding+ ]+++------------------------------------------------------------------------------+testMoreSpecific :: Test+testMoreSpecific = testGroup "moreSpecificThan"+ [ testProperty "Against *" $+ flip moreSpecificThan anything <$> genConcreteEncoding+ , testProperty "With *" $+ not . moreSpecificThan anything <$> genConcreteEncoding+ , testProperty "Unrelated encodings" $+ not . uncurry moreSpecificThan <$> genDiffConcreteEncodings+ ]+++------------------------------------------------------------------------------+testParseAccept :: Test+testParseAccept = testGroup "parseAccept"+ [ testProperty "Empty" $+ parseAccept "" === Just identity+ , testProperty "Wildcard" $+ parseAccept "*" === Just anything+ , testProperty "Valid parse" $ do+ enc <- genEncoding+ return $ parseAccept (renderHeader enc) === Just enc+ ]
test/Network/HTTP/Media/Gen.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE CPP #-}- ------------------------------------------------------------------------------ -- | Contains definitions for generating 'ByteString's. module Network.HTTP.Media.Gen- ( genByteStringFrom+ ( genToken++ , genByteStringFrom , genCIByteStringFrom , genByteString , genCIByteString@@ -14,27 +14,29 @@ , padString ) where --------------------------------------------------------------------------------#if !MIN_VERSION_base(4, 8, 0)-import Data.Functor ((<$>))-#endif+import qualified Data.ByteString.Char8 as BS+import qualified Data.CaseInsensitive as CI+import qualified Test.QuickCheck.Gen as Gen --------------------------------------------------------------------------------import qualified Data.ByteString.Char8 as BS-import qualified Data.CaseInsensitive as CI+import qualified Network.HTTP.Media.Utils as Utils +import Control.Monad (join, liftM2)+import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI, original)+import Data.Monoid ((<>))+import Test.QuickCheck.Gen (Gen)++ -------------------------------------------------------------------------------import Control.Monad (join, liftM2)-import Data.ByteString (ByteString)-import Data.CaseInsensitive (CI, original)-import Data.Monoid ((<>))-import Test.QuickCheck.Gen (Gen, elements, listOf, listOf1)+-- | Generates a valid header token.+genToken :: Gen (CI ByteString)+genToken = genCIByteStringFrom Utils.tokenChars ------------------------------------------------------------------------------ -- | Produces a non-empty ByteString of random characters from the given set. genByteStringFrom :: String -> Gen ByteString-genByteStringFrom = fmap BS.pack . listOf1 . elements+genByteStringFrom = fmap BS.pack . Gen.listOf1 . Gen.elements ------------------------------------------------------------------------------@@ -43,12 +45,20 @@ --------------------------------------------------------------------------------- | Produces a non-empty ByteString of random alphanumeric characters.+-- | Produces a non-empty ByteString of random alphanumeric characters with a+-- non-numeric head. genByteString :: Gen ByteString-genByteString = genByteStringFrom (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'])+genByteString = fmap BS.pack . (:)+ <$> Gen.elements alpha+ <*> Gen.scale (max 0 . pred) (Gen.listOf (Gen.elements alphaNum))+ where+ alpha = ['a'..'z'] ++ ['A'..'Z']+ alphaNum = alpha ++ ['0'..'9'] ------------------------------------------------------------------------------+-- | Produces a non-empty case-insensitive ByteString of random alphanumeric+-- characters with a non-numeric head. genCIByteString :: Gen (CI ByteString) genCIByteString = fmap CI.mk genByteString @@ -57,9 +67,7 @@ -- | Produces a non-empty ByteString different to the given one using the -- given generator. genDiffWith :: Eq a => Gen a -> a -> Gen a-genDiffWith gen a = do- b <- gen- if a == b then genDiffWith gen a else return b+genDiffWith gen = Gen.suchThat gen . (/=) ------------------------------------------------------------------------------@@ -79,5 +87,5 @@ ------------------------------------------------------------------------------ -- | Pad a 'ByteString' with a random amount of tab and space characters. padString :: ByteString -> Gen ByteString-padString c = join (liftM2 pad) (BS.pack <$> listOf (elements " \t"))+padString c = join (liftM2 pad) (BS.pack <$> Gen.listOf (Gen.elements " \t")) where pad a b = a <> c <> b
test/Network/HTTP/Media/Language/Gen.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, TupleSections #-}+{-# LANGUAGE TupleSections #-} ------------------------------------------------------------------------------ -- | Contains definitions for generating 'Language's.@@ -17,19 +17,13 @@ , genNonMatchingLanguages ) where --------------------------------------------------------------------------------#if !MIN_VERSION_base(4, 8, 0)-import Control.Applicative ((<$>))-#endif-import Data.ByteString (ByteString)-import Data.CaseInsensitive (CI)-import Test.QuickCheck.Gen+import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI)+import Test.QuickCheck.Gen --------------------------------------------------------------------------------import qualified Network.HTTP.Media.Gen as Gen+import qualified Network.HTTP.Media.Gen as Gen --------------------------------------------------------------------------------import Network.HTTP.Media.Language.Internal+import Network.HTTP.Media.Language.Internal ------------------------------------------------------------------------------@@ -111,8 +105,7 @@ ------------------------------------------------------------------------------ genCIByteString :: Gen (CI ByteString)-genCIByteString =- resize 8 $ Gen.genCIByteStringFrom (['a'..'z'] ++ ['A'..'Z'])+genCIByteString = resize 8 $ Gen.genCIByteString ------------------------------------------------------------------------------
test/Network/HTTP/Media/Language/Tests.hs view
@@ -1,29 +1,19 @@-{-# LANGUAGE CPP #-}- ------------------------------------------------------------------------------ module Network.HTTP.Media.Language.Tests (tests) where --------------------------------------------------------------------------------#if !MIN_VERSION_base(4, 8, 0)-import Data.Functor ((<$>))-#endif---------------------------------------------------------------------------------import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Char8 as BS --------------------------------------------------------------------------------import Control.Monad (join)-import Data.Monoid ((<>))-import Data.String (fromString)-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck ((.&&.), (===))+import Control.Monad (join)+import Data.Monoid ((<>))+import Data.String (fromString)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck ((===)) --------------------------------------------------------------------------------import Network.HTTP.Media.Accept-import Network.HTTP.Media.Language-import Network.HTTP.Media.Language.Gen-import Network.HTTP.Media.RenderHeader+import Network.HTTP.Media.Accept+import Network.HTTP.Media.Language+import Network.HTTP.Media.Language.Gen+import Network.HTTP.Media.RenderHeader ------------------------------------------------------------------------------@@ -34,7 +24,6 @@ , testFromString , testMatches , testMoreSpecific- , testMostSpecific , testParseAccept ] @@ -96,24 +85,6 @@ uncurry (flip moreSpecificThan) <$> genDiffMatchingLanguages , testProperty "Unrelated languages" $ not . uncurry moreSpecificThan <$> genNonMatchingLanguages- ]----------------------------------------------------------------------------------testMostSpecific :: Test-testMostSpecific = testGroup "mostSpecific"- [ testProperty "With *" $ do- lang <- genLanguage- return $ mostSpecific lang anything === lang .&&.- mostSpecific anything lang === lang- , testProperty "Proper prefix" $ do- (pre, lang) <- genMatchingLanguages- return $ mostSpecific lang pre === lang .&&.- mostSpecific pre lang === lang- , testProperty "Left biased" $ do- (lang, lang') <- genNonMatchingLanguages- return $ mostSpecific lang lang' === lang .&&.- mostSpecific lang' lang === lang' ]
test/Network/HTTP/Media/MediaType/Gen.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- ------------------------------------------------------------------------------ -- | Contains definitions for generating 'MediaType's. module Network.HTTP.Media.MediaType.Gen@@ -18,6 +16,7 @@ , genDiffMediaTypeWith , genDiffMediaTypes , genDiffMediaType+ , genMatchingPair -- * Generating Parameters , genParameters@@ -28,26 +27,18 @@ , renderParameters ) where --------------------------------------------------------------------------------#if !MIN_VERSION_base(4, 8, 0)-import Data.Functor ((<$>))-#endif---------------------------------------------------------------------------------import qualified Data.Map as Map+import qualified Data.Map as Map --------------------------------------------------------------------------------import Control.Monad (liftM, liftM2)-import Data.ByteString (ByteString)-import Data.CaseInsensitive (CI, original)-import Data.Foldable (foldlM)-import Data.Map (fromList)-import Data.Monoid ((<>))-import Test.QuickCheck.Gen+import Control.Monad (filterM, liftM, liftM2)+import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI, original)+import Data.Foldable (foldlM)+import Data.Map (fromList)+import Data.Monoid ((<>))+import Test.QuickCheck.Gen --------------------------------------------------------------------------------import Network.HTTP.Media.Gen-import Network.HTTP.Media.MediaType.Internal+import Network.HTTP.Media.Gen+import Network.HTTP.Media.MediaType.Internal ------------------------------------------------------------------------------@@ -141,7 +132,7 @@ --------------------------------------------------------------------------------- | Generates a different MediaType to the ones in the given list.+-- | Generates a different MediaType to the ones in the given list. genDiffMediaTypes :: [MediaType] -> Gen MediaType genDiffMediaTypes = genDiffMediaTypesWith genMediaType @@ -180,6 +171,40 @@ if params' `Map.isSubmapOf` params then genDiffParameters params else return params'+++------------------------------------------------------------------------------+-- | Generates a set of parameters that is a strict submap of the given+-- parameters.+genSubParameters :: Parameters -> Gen (Maybe Parameters)+genSubParameters params+ | Map.null params = return Nothing+ | otherwise = Just . Map.fromList <$> genStrictSublist+ where+ list = Map.toList params+ genStrictSublist = do+ sublist <- filterM (const $ choose (False, True)) list+ if sublist == list+ then genStrictSublist+ else return sublist+++------------------------------------------------------------------------------+-- | Generates a pair of non-equal MediaType values that are in a 'matches'+-- relation, with the more specific value on the left.+genMatchingPair :: Gen (MediaType, MediaType)+genMatchingPair = do+ a <- oneof [genSubStar, genConcreteMediaType]+ b <- if subType a == "*"+ then return anything+ else oneof $ withSubParameters a : map return [subStarOf a, anything]+ return (a, b)+ where+ withSubParameters a = do+ params <- genSubParameters (parameters a)+ return $ case params of+ Just sub -> a { parameters = sub }+ Nothing -> subStarOf a ------------------------------------------------------------------------------
test/Network/HTTP/Media/MediaType/Tests.hs view
@@ -1,35 +1,25 @@-{-# LANGUAGE CPP #-}- ------------------------------------------------------------------------------ module Network.HTTP.Media.MediaType.Tests (tests) where --------------------------------------------------------------------------------#if !MIN_VERSION_base(4, 8, 0)-import Data.Functor ((<$>))-#endif---------------------------------------------------------------------------------import qualified Data.ByteString.Char8 as BS-import qualified Data.Map as Map+import qualified Data.ByteString.Char8 as BS+import qualified Data.Map as Map --------------------------------------------------------------------------------import Control.Monad (join, liftM)-import Data.ByteString (ByteString)-import Data.CaseInsensitive (foldedCase)-import Data.Monoid ((<>))-import Data.String (fromString)-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck (property, (.&&.), (===))-import Test.QuickCheck.Gen (Gen)+import Control.Monad (join, liftM)+import Data.ByteString (ByteString)+import Data.CaseInsensitive (foldedCase)+import Data.Monoid ((<>))+import Data.String (fromString)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (property, (.&&.), (===))+import Test.QuickCheck.Gen (Gen) --------------------------------------------------------------------------------import Network.HTTP.Media.Accept-import Network.HTTP.Media.Gen-import Network.HTTP.Media.MediaType ((/.), (/?))-import Network.HTTP.Media.MediaType.Gen-import Network.HTTP.Media.MediaType.Internal-import Network.HTTP.Media.RenderHeader (renderHeader)+import Network.HTTP.Media.Accept+import Network.HTTP.Media.Gen+import Network.HTTP.Media.MediaType ((/.), (/?))+import Network.HTTP.Media.MediaType.Gen+import Network.HTTP.Media.MediaType.Internal+import Network.HTTP.Media.RenderHeader (renderHeader) ------------------------------------------------------------------------------@@ -42,7 +32,6 @@ , testGet , testMatches , testMoreSpecificThan- , testMostSpecific , testParseAccept ] @@ -163,38 +152,6 @@ 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'' ]
test/Network/HTTP/Media/Tests.hs view
@@ -1,29 +1,24 @@-{-# LANGUAGE CPP #-}- ------------------------------------------------------------------------------ module Network.HTTP.Media.Tests (tests) where --------------------------------------------------------------------------------#if !MIN_VERSION_base(4, 8, 0)-import Control.Applicative ((<$>), (<*>))-#endif+import Control.Monad (join, replicateM, (>=>))+import Data.Foldable (foldlM)+import Data.Function (on)+import Data.List (nubBy)+import Data.Map (empty)+import Data.Monoid ((<>))+import Data.Word (Word16)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck --------------------------------------------------------------------------------import Control.Monad (join, replicateM, (>=>))-import Data.Foldable (foldlM)-import Data.Map (empty)-import Data.Monoid ((<>))-import Data.Word (Word16)-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck+import Network.HTTP.Media hiding (parameters,+ subType)+import Network.HTTP.Media.Gen (padString)+import Network.HTTP.Media.MediaType.Gen+import Network.HTTP.Media.MediaType.Internal+import Network.HTTP.Media.Quality --------------------------------------------------------------------------------import Network.HTTP.Media hiding (parameters, subType)-import Network.HTTP.Media.Gen (padString)-import Network.HTTP.Media.MediaType.Gen-import Network.HTTP.Media.MediaType.Internal-import Network.HTTP.Media.Quality ------------------------------------------------------------------------------ tests :: [Test]@@ -129,14 +124,7 @@ -> ([Quality MediaType] -> a) -> Test testMatch name match qToI = testGroup ("match" ++ name)- [ 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 $ match server (qToI client) ===- Just (qualityData $ foldr1 qmax client)- , testProperty "Most specific" $ do+ [ testProperty "Most specific" $ do media <- genConcreteMediaType let client = qToI $ map maxQuality [ MediaType "*" "*" empty@@ -149,26 +137,77 @@ client <- listOf1 genConcreteMediaType server <- filter (not . flip any client . matches) <$> genServer return $ match server (qToI $ map maxQuality client) === Nothing- , testProperty "Never chooses q=0" $ do- server <- genServer- return $ match server (qToI $ map minQuality server) === Nothing , testProperty "Left biased" $ do- server <- genServer+ server <- genNubServer let client = qToI $ map maxQuality server return $ match server client === Just (head server) , testProperty "Against */*" $ do- server <- genServer+ server <- genNubServer let stars = "*/*" :: MediaType return $ match server (qToI [maxQuality stars]) === Just (head server) , testProperty "Against type/*" $ do- server <- genServer+ server <- genNubServer let client = qToI [maxQuality (subStarOf $ head server)] return $ match server client === Just (head server)+ , testQuality match qToI ] ------------------------------------------------------------------------------+testQuality+ :: ([MediaType] -> a -> Maybe MediaType)+ -> ([Quality MediaType] -> a)+ -> Test+testQuality match qToI = testGroup "Quality"+ [ 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 $ match server (qToI client) ===+ Just (qualityData $ foldr1 qmax client)+ , testProperty "Most specific quality" $ do+ (a, b) <- genMatchingPair+ c <- genDiffMediaType a+ let client = qToI [quality a "0.5", maxQuality b, maxQuality c]+ return $ match [a, c] client === Just c+ , testQ0 match qToI+ ]+++------------------------------------------------------------------------------+testQ0+ :: ([MediaType] -> a -> Maybe MediaType)+ -> ([Quality MediaType] -> a)+ -> Test+testQ0 match qToI = testGroup "q=0"+ [ testProperty "Does not choose a q=0" $ do+ server <- genConcreteMediaType+ return $ match [server] (qToI [minQuality server]) === Nothing+ , testProperty "Does not choose any q=0" $ do+ server <- genServer+ return $ match server (qToI $ map minQuality server) === Nothing+ , testProperty "Does not choose q=0 with less specific type" $ do+ (a, b) <- genMatchingPair+ let client = qToI [minQuality a, maxQuality b]+ return $ match [a] client === Nothing+ , testProperty "Does choose type with q=0 on less specific type" $ do+ (a, b) <- genMatchingPair+ let client = qToI [minQuality b, maxQuality a]+ return $ match [a] client === Just a+ , testProperty "Does not choose q=0 when followed by same type" $ do+ server <- genConcreteMediaType+ let client = qToI [minQuality server, maxQuality server]+ return $ match [server] client === Nothing+ , testProperty "Does not choose q=0 when preceded by same type" $ do+ server <- genConcreteMediaType+ let client = qToI [maxQuality server, minQuality server]+ return $ match [server] client === Nothing+ ]+++------------------------------------------------------------------------------ testMap :: String -> ([(MediaType, MediaType)] -> a -> Maybe MediaType)@@ -193,6 +232,11 @@ ------------------------------------------------------------------------------ genServer :: Gen [MediaType] genServer = listOf1 genConcreteMediaType+++------------------------------------------------------------------------------+genNubServer :: Gen [MediaType]+genNubServer = nubBy (on (==) stripParams) <$> genServer ------------------------------------------------------------------------------
test/Test.hs view
@@ -1,11 +1,11 @@ ------------------------------------------------------------------------------ module Main (main) where --------------------------------------------------------------------------------import Test.Framework (defaultMain, testGroup)+import Test.Framework (defaultMain, testGroup) ------------------------------------------------------------------------------- import qualified Network.HTTP.Media.Accept.Tests as Accept+import qualified Network.HTTP.Media.Charset.Tests as Charset+import qualified Network.HTTP.Media.Encoding.Tests as Encoding import qualified Network.HTTP.Media.Language.Tests as Language import qualified Network.HTTP.Media.MediaType.Tests as MediaType import qualified Network.HTTP.Media.Tests as Media@@ -15,6 +15,8 @@ main :: IO () main = defaultMain [ testGroup "Accept" Accept.tests+ , testGroup "Charset" Charset.tests+ , testGroup "Encoding" Encoding.tests , testGroup "Language" Language.tests , testGroup "MediaType" MediaType.tests , testGroup "Media" Media.tests