diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,102 @@ +Changelog +========= + +- [Version 0.8.1.1](https://github.com/zmthy/http-media/releases/tag/v0.8.1.1) + + Fixed a bug when mapping againt a client-side content header where a + match would be overridden by a more specific key earlier in the map. + + The bounds for tasty have been updated to include the latest version. + +- [Version 0.8.1.0](https://github.com/zmthy/http-media/releases/tag/v0.8.1.0) + + Exposed `qualityData` accessor. + + Added `isAcceptable` to allow filtering out unacceptable items. + +- [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. + +- [Version 0.7.1.2](https://github.com/zmthy/http-media/releases/tag/v0.7.1.2) + + The bounds for QuickCheck have been updated to include the latest + version. + +- [Version 0.7.1.1](https://github.com/zmthy/http-media/releases/tag/v0.7.1.1) + + The bounds for base have been updated to include support for GHC 8.2. + +- [Version 0.7.1](https://github.com/zmthy/http-media/releases/tag/v0.7.1) + + Travis now tests against a range of Stackage LTS environments, instead + of using multi-ghc. + + Support for base-4.6 has now been correctly removed in the Cabal file. + +- [Version 0.7.0](https://github.com/zmthy/http-media/releases/tag/v0.7.0) + + The Travis configuration has dropped support for GHC 7.6 and added + support for 8.0. + + More direct constructors for quality values are now available, to + avoid having to deal with `Maybe` results when you are certain parsing + a quality string will not fail. + + The bounds for QuickCheck have been updated to include the latest + version. + +- [Version 0.6.4](https://github.com/zmthy/http-media/releases/tag/v0.6.4) + + The bounds for QuickCheck have been updated to include the latest + version. + +- [Version 0.6.3](https://github.com/zmthy/http-media/releases/tag/v0.6.3) + + Parse failures more regularly return a `Maybe` value instead of + raising an exception. + + The `(//)` smart constructor now accepts wildcard arguments, but only + in the correct order. + + Most tests will now emit a counter example if their relevant + properties are violated. Some tests which were not correctly covering + their properties have been fixed. + + The `-Werror` flag has been removed from the test suite. + +- [Version 0.6.2](https://github.com/zmthy/http-media/releases/tag/v0.6.2) + + The test suite now uses the test-framework library instead of + cabal-test-quickcheck, and the package no longer depends on Cabal. + +- [Version 0.6.1](https://github.com/zmthy/http-media/releases/tag/v0.6.1) + + The type errors and build warnings caused by the BBP have been fixed + for GHC 7.10. + +- [Version 0.6.0](https://github.com/zmthy/http-media/releases/tag/v0.6.0) + + All of the publicly exposed data types now derive an `Ord` instance. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,19 +1,20 @@ Copyright (c) 2012-2015 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: +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 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. +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. diff --git a/http-media.cabal b/http-media.cabal --- a/http-media.cabal +++ b/http-media.cabal @@ -1,26 +1,35 @@ name: http-media -version: 0.6.4 +version: 0.8.1.1 license: MIT license-file: LICENSE author: Timothy Jones maintainer: Timothy Jones homepage: https://github.com/zmthy/http-media bug-reports: https://github.com/zmthy/http-media/issues -copyright: (c) 2012-2016 Timothy Jones +copyright: (c) 2012-2023 Timothy Jones category: Web build-type: Simple cabal-version: >= 1.10 +tested-with: + GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.5 + , GHC == 9.6.2 synopsis: Processing HTTP Content-Type and Accept headers description: This library is intended to be a comprehensive solution to parsing and - selecting quality-indexed values in HTTP headers. It is capable of parsing - both media types and language parameters from the Accept and Content header - families, and can be extended to match against other accept headers as well. - Selecting the appropriate header value is achieved by comparing a list of - server options against the quality-indexed values supplied by the client. + selecting quality-indexed values in HTTP headers. It is capable of + parsing both media types and language parameters from the Accept and + Content header families, and can be extended to match against other + accept headers as well. Selecting the appropriate header value is + achieved by comparing a list of server options against the + quality-indexed values supplied by the client. . - In the following example, the Accept header is parsed and then matched against - a list of server options to serve the appropriate media using + In the following example, the Accept header is parsed and then matched + against a list of server options to serve the appropriate media using 'mapAcceptMedia': . > getHeader >>= maybe send406Error sendResourceWith . mapAcceptMedia @@ -28,8 +37,8 @@ > , ("application/json", asJson) > ] . - Similarly, the Content-Type header can be used to produce a parser for request - bodies based on the given content type with 'mapContentMedia': + Similarly, the Content-Type header can be used to produce a parser for + request bodies based on the given content type with 'mapContentMedia': . > getContentType >>= maybe send415Error readRequestBodyWith . mapContentMedia > [ ("application/json", parseJson) @@ -38,6 +47,9 @@ . The API is agnostic to your choice of server. +extra-source-files: + CHANGES.md + library default-language: Haskell2010 @@ -49,27 +61,29 @@ 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 Network.HTTP.Media.Utils build-depends: - base >= 4.6 && < 5.0, - bytestring >= 0.10 && < 0.11, + base >= 4.8 && < 5, + bytestring >= 0.10 && < 0.12, case-insensitive >= 1.0 && < 1.3, - containers >= 0.5 && < 0.6 + containers >= 0.5 && < 0.7, + utf8-string >= 0.3 && < 1.1 test-suite test-http-media type: exitcode-stdio-1.0 @@ -87,14 +101,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 @@ -109,14 +130,15 @@ Network.HTTP.Media.Utils build-depends: - base >= 4.6 && < 5.0, - bytestring >= 0.10 && < 0.11, - case-insensitive >= 1.0 && < 1.3, - containers >= 0.5 && < 0.6, - QuickCheck >= 2.6 && < 2.10, - test-framework >= 0.8 && < 0.9, - test-framework-quickcheck2 >= 0.3 && < 0.4 + base >= 4.8 && < 5, + bytestring >= 0.10 && < 0.12, + case-insensitive >= 1.0 && < 1.3, + containers >= 0.5 && < 0.7, + utf8-string >= 0.3 && < 1.1, + QuickCheck >= 2.8 && < 2.15, + tasty >= 0.11 && < 1.6, + tasty-quickcheck >= 0.8 && < 0.11 source-repository head type: git - location: git://github.com/zmthy/http-media.git + location: https://github.com/zmthy/http-media diff --git a/src/Network/HTTP/Media.hs b/src/Network/HTTP/Media.hs --- a/src/Network/HTTP/Media.hs +++ b/src/Network/HTTP/Media.hs @@ -1,74 +1,79 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------- -- | A framework for parsing HTTP media type headers. module Network.HTTP.Media - ( - -- * Media types - MediaType - , (//) - , (/:) - , mainType - , subType - , parameters - , (/?) - , (/.) + ( -- * Media types + MediaType, + (//), + (/:), + mainType, + subType, + parameters, + (/?), + (/.), + -- * Charsets + Charset, + + -- * Encodings + Encoding, + -- * Languages - , Language - , toParts + Language, + toParts, -- * Accept matching - , matchAccept - , mapAccept - , mapAcceptMedia - , mapAcceptLanguage - , mapAcceptBytes + matchAccept, + mapAccept, + mapAcceptMedia, + mapAcceptCharset, + mapAcceptEncoding, + mapAcceptLanguage, + mapAcceptBytes, -- * Content matching - , matchContent - , mapContent - , mapContentMedia - , mapContentLanguage + matchContent, + mapContent, + mapContentMedia, + mapContentCharset, + mapContentEncoding, + mapContentLanguage, -- * Quality values - , Quality - , parseQuality - , matchQuality - , mapQuality + Quality (qualityData), + quality, + QualityOrder, + qualityOrder, + isAcceptable, + maxQuality, + minQuality, + parseQuality, + matchQuality, + mapQuality, -- * Accept - , Accept (..) + Accept (..), -- * Rendering - , RenderHeader (..) - ) where + 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 Control.Monad (guard, (>=>)) import Data.ByteString (ByteString) -import Data.Maybe (fromMaybe) - ------------------------------------------------------------------------------- -import Network.HTTP.Media.Accept as Accept -import Network.HTTP.Media.Language as Language -import Network.HTTP.Media.MediaType as MediaType +import qualified Data.ByteString.Char8 as BS +import Data.Foldable (find, 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 import Network.HTTP.Media.RenderHeader -import Network.HTTP.Media.Utils (trimBS) - +import Network.HTTP.Media.Utils (trimBS) ------------------------------------------------------------------------------- -- | 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 @@ -82,15 +87,15 @@ -- > matchAccept ["text/html", "application/json"] <$> getHeader -- -- For more information on the matching process see RFC 2616, section 14.1-4. -matchAccept - :: Accept a - => [a] -- ^ The server-side options - -> ByteString -- ^ The client-side header value - -> Maybe a +matchAccept :: + (Accept a) => + -- | The server-side options + [a] -> + -- | The client-side header value + ByteString -> + Maybe a matchAccept = (parseQuality >=>) . matchQuality - ------------------------------------------------------------------------------- -- | 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. @@ -99,15 +104,15 @@ -- > [ ("text" // "html", asHtml) -- > , ("application" // "json", asJson) -- > ] -mapAccept - :: Accept a - => [(a, b)] -- ^ The map of server-side preferences to values - -> ByteString -- ^ The client-side header value - -> Maybe b +mapAccept :: + (Accept a) => + -- | The map of server-side preferences to values + [(a, b)] -> + -- | The client-side header value + ByteString -> + Maybe b mapAccept = (parseQuality >=>) . mapQuality - ------------------------------------------------------------------------------- -- | A specialisation of 'mapAccept' that only takes 'MediaType' as its input, -- to avoid ambiguous-type errors when using string literal overloading. -- @@ -116,44 +121,74 @@ -- > , ("application/json", asJson) -- > ] mapAcceptMedia :: - [(MediaType, b)] -- ^ The map of server-side preferences to values - -> ByteString -- ^ The client-side header value - -> Maybe b + -- | The map of server-side preferences to values + [(MediaType, b)] -> + -- | The client-side header value + ByteString -> + Maybe b mapAcceptMedia = mapAccept +-- | 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 :: + -- | The map of server-side preferences to values + [(Charset, b)] -> + -- | The client-side header value + ByteString -> + 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 :: + -- | The map of server-side preferences to values + [(Encoding, b)] -> + -- | The client-side header value + ByteString -> + 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 - -> ByteString -- ^ The client-side header value - -> Maybe b + -- | The map of server-side preferences to values + [(Language, b)] -> + -- | The client-side header value + ByteString -> + Maybe b mapAcceptLanguage = mapAccept - ------------------------------------------------------------------------------- -- | A specialisation of 'mapAccept' that only takes 'ByteString' as its -- input, to avoid ambiguous-type errors when using string literal -- 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 - -> ByteString -- ^ The client-side header value - -> Maybe b + -- | The map of server-side preferences to values + [(ByteString, b)] -> + -- | The client-side header value + ByteString -> + Maybe b mapAcceptBytes = mapAccept - ------------------------------------------------------------------------------- -- | 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). @@ -161,19 +196,15 @@ -- > matchContent ["application/json", "text/plain"] <$> getContentType -- -- For more information on the matching process see RFC 2616, section 14.17. -matchContent - :: Accept a - => [a] -- ^ The server-side response options - -> ByteString -- ^ The client's request value - -> Maybe a -matchContent options ctype = foldl choose Nothing options - where - choose m server = m <|> do - parseAccept ctype >>= guard . (`matches` server) - Just server - +matchContent :: + (Accept a) => + -- | The server-side response options + [a] -> + -- | The client's request value + ByteString -> + Maybe a +matchContent = findMatch id ------------------------------------------------------------------------------- -- | The equivalent of 'matchContent' above, except the resulting choice is -- mapped to another value. -- @@ -181,16 +212,15 @@ -- > [ ("application" // "json", parseJson) -- > , ("text" // "plain", parseText) -- > ] -mapContent - :: Accept a - => [(a, b)] -- ^ The map of server-side responses - -> ByteString -- ^ The client request's header value - -> Maybe b -mapContent options ctype = - matchContent (map fst options) ctype >>= lookupMatches options - +mapContent :: + (Accept a) => + -- | The map of server-side responses + [(a, b)] -> + -- | The client request's header value + ByteString -> + Maybe b +mapContent options = fmap snd . findMatch fst options ------------------------------------------------------------------------------- -- | A specialisation of 'mapContent' that only takes 'MediaType' as its -- input, to avoid ambiguous-type errors when using string literal -- overloading. @@ -200,57 +230,93 @@ -- > [ ("application/json", parseJson) -- > , ("text/plain", parseText) -- > ] -mapContentMedia - :: [(MediaType, b)] -- ^ The map of server-side responses - -> ByteString -- ^ The client request's header value - -> Maybe b +mapContentMedia :: + -- | The map of server-side responses + [(MediaType, b)] -> + -- | The client request's header value + ByteString -> + Maybe b mapContentMedia = mapContent +-- | 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 :: + -- | The map of server-side responses + [(Charset, b)] -> + -- | The client request's header value + ByteString -> + 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 :: + -- | The map of server-side responses + [(Encoding, b)] -> + -- | The client request's header value + ByteString -> + 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 - -> Maybe b +mapContentLanguage :: + -- | The map of server-side responses + [(Language, b)] -> + -- | The client request's header value + ByteString -> + Maybe b mapContentLanguage = mapContent - ------------------------------------------------------------------------------- -- | Parses a full Accept header into a list of quality-valued media types. -parseQuality :: Accept a => ByteString -> Maybe [Quality a] +parseQuality :: (Accept a) => ByteString -> Maybe [Quality a] parseQuality = parseQuality' Proxy -parseQuality' :: Accept a => Proxy a -> ByteString -> Maybe [Quality a] -parseQuality' p = (. map trimBS . BS.split ',') . mapM $ \ s -> - let (accept, q) = fromMaybe (s, Nothing) $ if ext then findQ s else getQ s - in maybe (pure maxQuality) (fmap (flip Quality) . readQ) q <*> - parseAccept accept +parseQuality' :: (Accept a) => Proxy a -> ByteString -> Maybe [Quality a] +parseQuality' p = (. map trimBS . BS.split ',') . mapM $ \s -> + let (accept, q) = fromMaybe (s, Nothing) $ if ext then findQ s else getQ s + in maybe (pure maxQuality) (fmap (flip Quality) . readQ) q + <*> parseAccept accept where ext = hasExtensionParameters p -- Split on ';', and check if a quality value is there. A value of Nothing -- indicates there was no parameter, whereas a value of Nothing in the -- pair indicates the parameter was not a quality value. - getQ s = let (a, b) = trimBS <$> BS.breakEnd (== ';') s in - if BS.null a then Nothing else Just (BS.init a, - if BS.isPrefixOf "q=" b then Just (BS.drop 2 b) else Nothing) + getQ s = + let (a, b) = trimBS <$> BS.breakEnd (== ';') s + in if BS.null a + then Nothing + else + Just + ( BS.init a, + if BS.isPrefixOf "q=" b then Just (BS.drop 2 b) else Nothing + ) -- Trawl backwards through the string, ignoring extension parameters. findQ s = do - let q = getQ s - (a, m) <- q - maybe (findQ a) (const q) m - + let q = getQ s + (a, m) <- q + maybe (findQ a) (const q) m ------------------------------------------------------------------------------- -- | Matches a list of server-side resource options against a pre-parsed -- 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 @@ -264,26 +330,15 @@ -- > matchQuality ["text/html", "application/json"] <$> parseQuality header -- -- For more information on the matching process see RFC 2616, section 14.1-4. -matchQuality - :: Accept a - => [a] -- ^ The server-side options - -> [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 - +matchQuality :: + (Accept a) => + -- | The server-side options + [a] -> + -- | The pre-parsed client-side header value + [Quality a] -> + Maybe a +matchQuality = findQuality id ------------------------------------------------------------------------------- -- | The equivalent of 'matchQuality' above, except the resulting choice is -- mapped to another value. Convenient for specifying how to translate the -- resource into each of its available formats. @@ -292,19 +347,34 @@ -- > [ ("text" // "html", asHtml) -- > , ("application" // "json", asJson) -- > ] -mapQuality - :: Accept a - => [(a, b)] -- ^ The map of server-side preferences to values - -> [Quality a] -- ^ The client-side header value - -> Maybe b -mapQuality options accept = - matchQuality (map fst options) accept >>= lookupMatches options +mapQuality :: + (Accept a) => + -- | The map of server-side preferences to values + [(a, b)] -> + -- | The client-side header value + [Quality a] -> + Maybe b +mapQuality options = fmap snd . findQuality fst options +-- | Find a match in a list of options against a ByteString using an 'Accept' +-- instance obtained by mapping the options to another type. +findMatch :: (Accept b) => (a -> b) -> [a] -> ByteString -> Maybe a +findMatch f options bs = do + ctype <- parseAccept bs + find (matches ctype . f) options ------------------------------------------------------------------------------- --- | The equivalent of 'lookupBy matches'. -lookupMatches :: Accept a => [(a, b)] -> a -> Maybe b -lookupMatches ((k, v) : r) a - | Accept.matches k a = Just v - | otherwise = lookupMatches r a -lookupMatches [] _ = Nothing +-- | Find a quality match between a list of options and a quality-marked list +-- of a different type, by mapping the type of the former to the latter. +findQuality :: (Accept a) => (b -> a) -> [b] -> [Quality a] -> Maybe b +findQuality f options acceptq = do + guard $ not (null options) + q <- maximumBy (compare `on` fmap qualityOrder) optionsq + guard $ isAcceptable q + return $ qualityData q + where + optionsq = reverse $ map addQuality options + addQuality opt = withQValue opt <$> foldl' (mfold opt) Nothing acceptq + withQValue opt q = q {qualityData = opt} + mfold opt cur q + | f opt `matches` qualityData q = mostSpecific q <$> cur <|> Just q + | otherwise = cur diff --git a/src/Network/HTTP/Media/Accept.hs b/src/Network/HTTP/Media/Accept.hs --- a/src/Network/HTTP/Media/Accept.hs +++ b/src/Network/HTTP/Media/Accept.hs @@ -1,73 +1,52 @@ ------------------------------------------------------------------------------- -- | Defines the 'Accept' type class, designed to unify types on the matching -- functions in the Media module. module Network.HTTP.Media.Accept - ( Accept (..) - , mostSpecific - , Proxy (..) - ) where - ------------------------------------------------------------------------------- -import qualified Data.CaseInsensitive as CI + ( Accept (..), + ) +where ------------------------------------------------------------------------------- import Data.ByteString (ByteString) - +import qualified Data.CaseInsensitive as CI +import Data.Proxy (Proxy) ------------------------------------------------------------------------------- -- | Defines methods for a type whose values can be matched against each -- other in terms of an HTTP Accept-* 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 Show a => Accept a where - - -- | Specifies how to parse an Accept-* header after quality has been - -- handled. - parseAccept :: ByteString -> Maybe a +class (Show a) => Accept a where + -- | Specifies how to parse an Accept-* header after quality has been + -- handled. + parseAccept :: ByteString -> Maybe a - -- | Evaluates whether either the left argument matches the right one. - -- - -- This relation must be a total order, where more specific terms on the - -- left can produce a match, but a less specific term on the left can - -- never produce a match. For instance, when matching against media types - -- it is important that if the client asks for a general type then we can - -- choose a more specific offering from the server, but if a client asks - -- for a specific type and the server only offers a more general form, - -- then we cannot generalise. In this case, the server types will be the - -- left argument, and the client types the right. - -- - -- For types with no concept of specificity, this operation is just - -- equality. - matches :: a -> a -> Bool + -- | Evaluates whether either the left argument matches the right one. + -- + -- This relation must be a total order, where more specific terms on the + -- left can produce a match, but a less specific term on the left can + -- never produce a match. For instance, when matching against media types + -- it is important that if the client asks for a general type then we can + -- choose a more specific offering from the server, but if a client asks + -- for a specific type and the server only offers a more general form, + -- then we cannot generalise. In this case, the server types will be the + -- left argument, and the client types the right. + -- + -- For types with no concept of specificity, this operation is just + -- equality. + matches :: a -> a -> Bool - -- | Evaluates whether the left argument is more specific than the right. - -- - -- This relation must be irreflexive and transitive. For types with no - -- concept of specificity, this is the empty relation (always false). - moreSpecificThan :: a -> a -> Bool + -- | Evaluates whether the left argument is more specific than the right. + -- + -- This relation must be irreflexive and transitive. For types with no + -- concept of specificity, this is the empty relation (always false). + moreSpecificThan :: a -> a -> Bool - -- | Indicates whether extension parameters are permitted after the weight - -- parameter when this type appears in an Accept header. Defaults to - -- false. - hasExtensionParameters :: Proxy a -> Bool - hasExtensionParameters _ = False + -- | Indicates whether extension parameters are permitted after the weight + -- parameter when this type appears in an Accept header. Defaults to + -- false. + hasExtensionParameters :: Proxy a -> Bool + hasExtensionParameters _ = False instance Accept ByteString where - 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 - - ------------------------------------------------------------------------------- --- | Serves the same purpose as the Proxy type in base, but redefined here in --- a basic form for older versions of base that do not include it. -data Proxy a = Proxy + parseAccept = Just + matches a b = CI.mk a == CI.mk b + moreSpecificThan _ _ = False diff --git a/src/Network/HTTP/Media/Charset.hs b/src/Network/HTTP/Media/Charset.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Media/Charset.hs @@ -0,0 +1,5 @@ +-- | 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 diff --git a/src/Network/HTTP/Media/Charset/Internal.hs b/src/Network/HTTP/Media/Charset/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Media/Charset/Internal.hs @@ -0,0 +1,49 @@ +-- | Defines the 'Charset' accept header with an 'Accept' instance for use in +-- language negotiation. +module Network.HTTP.Media.Charset.Internal + ( Charset (..), + ) +where + +import Control.Monad (guard) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.CaseInsensitive (CI, original) +import qualified Data.CaseInsensitive as CI +import Data.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 +-- . +-- +-- 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 diff --git a/src/Network/HTTP/Media/Encoding.hs b/src/Network/HTTP/Media/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Media/Encoding.hs @@ -0,0 +1,5 @@ +-- | 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 diff --git a/src/Network/HTTP/Media/Encoding/Internal.hs b/src/Network/HTTP/Media/Encoding/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Media/Encoding/Internal.hs @@ -0,0 +1,52 @@ +-- | Defines the 'Encoding' accept header with an 'Accept' instance for use in +-- language negotiation. +module Network.HTTP.Media.Encoding.Internal + ( Encoding (..), + ) +where + +import Control.Monad (guard) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.CaseInsensitive (CI, original) +import qualified Data.CaseInsensitive as CI +import Data.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 +-- . +-- +-- 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 diff --git a/src/Network/HTTP/Media/Language.hs b/src/Network/HTTP/Media/Language.hs --- a/src/Network/HTTP/Media/Language.hs +++ b/src/Network/HTTP/Media/Language.hs @@ -1,20 +1,15 @@ ------------------------------------------------------------------------------- -- | Defines the 'Language' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Language - ( Language - , toParts - ) where + ( Language, + toParts, + ) +where ------------------------------------------------------------------------------- -import Data.ByteString (ByteString) +import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) - ------------------------------------------------------------------------------- import Network.HTTP.Media.Language.Internal - ------------------------------------------------------------------------------- -- | Converts 'Language' to a list of its language parts. The wildcard -- produces an empty list. toParts :: Language -> [CI ByteString] diff --git a/src/Network/HTTP/Media/Language/Internal.hs b/src/Network/HTTP/Media/Language/Internal.hs --- a/src/Network/HTTP/Media/Language/Internal.hs +++ b/src/Network/HTTP/Media/Language/Internal.hs @@ -1,75 +1,67 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------- -- | Defines the 'Language' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Language.Internal - ( Language (..) - ) where - ------------------------------------------------------------------------------- -#if !MIN_VERSION_base(4, 8, 0) -import Data.Functor ((<$>)) -#endif + ( Language (..), + ) +where ------------------------------------------------------------------------------- +import Control.Monad (guard) +import Data.ByteString (ByteString) 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.List (isPrefixOf) -import Data.Maybe (fromMaybe) -import Data.String (IsString (..)) - ------------------------------------------------------------------------------- -import Network.HTTP.Media.Accept (Accept (..)) +import qualified Data.CaseInsensitive as CI +import Data.Char (isAlpha, isAlphaNum) +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) +import Data.String (IsString (..)) +import Network.HTTP.Media.Accept (Accept (..)) import Network.HTTP.Media.RenderHeader (RenderHeader (..)) - ------------------------------------------------------------------------------- -- | Suitable for HTTP language-ranges as defined in --- . +-- . -- -- Specifically: -- --- > language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" ) +-- > language-range = (1*8ALPHA *("-" 1*8alphanum)) / "*" newtype Language = Language [CI ByteString] - deriving (Eq, Ord) + deriving (Eq, Ord) -- Note that internally, Language [] equates to *. instance Show Language where - show = BS.unpack . renderHeader + show = BS.unpack . renderHeader instance IsString Language where - fromString "*" = Language [] - fromString str = flip fromMaybe (parseAccept $ BS.pack str) $ - error $ "Invalid language literal " ++ str + fromString "*" = Language [] + fromString str = + flip fromMaybe (parseAccept $ BS.pack str) $ + error $ + "Invalid language literal " ++ str instance Accept Language where - parseAccept "*" = Just $ Language [] - parseAccept bs = do - let pieces = BS.split '-' bs - guard $ not (null pieces) - Language <$> mapM check pieces - where - check part = do - let len = BS.length part - guard $ len >= 1 && len <= 8 && BS.all isAlpha part - return (CI.mk part) + parseAccept "*" = Just $ Language [] + parseAccept bs = do + let pieces = BS.split '-' bs + guard $ not (null pieces) + Language <$> mapM check pieces + where + check part = do + let len = BS.length 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. - matches (Language a) (Language b) = b `isPrefixOf` a + -- Languages match if the right argument is a prefix of the left. + matches (Language a) (Language b) = b `isPrefixOf` a - -- The left language is more specific than the right if the right - -- arguments is a strict prefix of the left. - moreSpecificThan (Language a) (Language b) = - b `isPrefixOf` a && length a > length b + -- The left language is more specific than the right if the right + -- arguments is a strict prefix of the left. + moreSpecificThan (Language a) (Language b) = + b `isPrefixOf` a && length a > length b instance RenderHeader Language where - renderHeader (Language []) = "*" - renderHeader (Language l) = BS.intercalate "-" (map original l) + renderHeader (Language []) = "*" + renderHeader (Language l) = BS.intercalate "-" (map original l) diff --git a/src/Network/HTTP/Media/MediaType.hs b/src/Network/HTTP/Media/MediaType.hs --- a/src/Network/HTTP/Media/MediaType.hs +++ b/src/Network/HTTP/Media/MediaType.hs @@ -1,107 +1,86 @@ ------------------------------------------------------------------------------- -- | Defines the 'MediaType' accept header with an 'Accept' instance for use -- in content-type negotiation. module Network.HTTP.Media.MediaType - ( - -- * Type and creation - MediaType - , Parameters - , (//) - , (/:) + ( -- * Type and creation + MediaType, + Parameters, + (//), + (/:), -- * Querying - , mainType - , subType - , parameters - , (/?) - , (/.) - ) where + mainType, + subType, + parameters, + (/?), + (/.), + ) +where ------------------------------------------------------------------------------- +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS -import qualified Data.CaseInsensitive as CI -import qualified Data.Map as Map - ------------------------------------------------------------------------------- -import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) -import Data.Map (empty, insert) - ------------------------------------------------------------------------------- -import qualified Network.HTTP.Media.MediaType.Internal as Internal - ------------------------------------------------------------------------------- +import qualified Data.CaseInsensitive as CI +import Data.Map (empty, insert) +import qualified Data.Map as Map import Network.HTTP.Media.MediaType.Internal (MediaType (MediaType)) import Network.HTTP.Media.MediaType.Internal hiding (MediaType (..)) +import qualified Network.HTTP.Media.MediaType.Internal as Internal import Network.HTTP.Media.Utils - ------------------------------------------------------------------------------- -- | Retrieves the main type of a 'MediaType'. mainType :: MediaType -> CI ByteString mainType = Internal.mainType - ------------------------------------------------------------------------------- -- | Retrieves the sub type of a 'MediaType'. subType :: MediaType -> CI 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 - | a == "*" && b == "*" = MediaType (CI.mk a) (CI.mk b) empty - | b == "*" = MediaType (ensureR a) (CI.mk b) empty - | otherwise = MediaType (ensureR a) (ensureR b) empty - + | a == "*" && b == "*" = MediaType (CI.mk a) (CI.mk b) empty + | b == "*" = MediaType (ensureR a) (CI.mk b) empty + | otherwise = 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 (CI.mk k) p - ------------------------------------------------------------------------------- -- | Retrieves a parameter from a 'MediaType'. (/.) :: MediaType -> ByteString -> Maybe (CI ByteString) (MediaType _ _ p) /. k = Map.lookup (CI.mk k) p - ------------------------------------------------------------------------------- -- | Ensures that the 'ByteString' matches the ABNF for `reg-name` in RFC -- 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 - where l = BS.length bs - +ensureR bs = + CI.mk $ + if l == 0 || l > 127 + then error $ "Invalid length for " ++ show bs + else ensure isMediaChar 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 -> CI ByteString ensureV = CI.mk . ensure (`notElem` [',', ';']) - ------------------------------------------------------------------------------- -- | Ensures the predicate matches for every character in the given string. ensure :: (Char -> Bool) -> ByteString -> ByteString -ensure f bs = maybe - (error $ "Invalid character in " ++ show bs) (const bs) (BS.find f bs) +ensure f bs = + maybe + (error $ "Invalid character in " ++ show bs) + (const bs) + (BS.find f bs) diff --git a/src/Network/HTTP/Media/MediaType/Internal.hs b/src/Network/HTTP/Media/MediaType/Internal.hs --- a/src/Network/HTTP/Media/MediaType/Internal.hs +++ b/src/Network/HTTP/Media/MediaType/Internal.hs @@ -1,86 +1,87 @@ ------------------------------------------------------------------------------- -- | Defined to allow the constructor of 'MediaType' to be exposed to tests. module Network.HTTP.Media.MediaType.Internal - ( MediaType (..) - , Parameters - ) where + ( MediaType (..), + Parameters, + ) +where ------------------------------------------------------------------------------- +import Control.Monad (foldM, guard) +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS -import qualified Data.CaseInsensitive as CI -import qualified Data.Map as Map - ------------------------------------------------------------------------------- -import Control.Monad (foldM, guard) -import Data.ByteString (ByteString) import Data.CaseInsensitive (CI, original) -import Data.Map (Map) -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) -import Data.String (IsString (..)) - ------------------------------------------------------------------------------- -import Network.HTTP.Media.Accept (Accept (..)) +import qualified Data.CaseInsensitive as CI +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.String (IsString (..)) +import Network.HTTP.Media.Accept (Accept (..)) import Network.HTTP.Media.RenderHeader (RenderHeader (..)) -import Network.HTTP.Media.Utils (breakChar, trimBS) - +import Network.HTTP.Media.Utils (breakChar, trimBS) +import Prelude hiding ((<>)) ------------------------------------------------------------------------------- -- | An HTTP media type, consisting of the type, subtype, and parameters. data MediaType = MediaType - { mainType :: CI ByteString -- ^ The main type of the MediaType - , subType :: CI ByteString -- ^ The sub type of the MediaType - , parameters :: Parameters -- ^ The parameters of the MediaType - } deriving (Eq, Ord) + { -- | The main type of the MediaType + mainType :: CI ByteString, + -- | The sub type of the MediaType + subType :: CI ByteString, + -- | The parameters of the MediaType + parameters :: Parameters + } + deriving (Eq, Ord) instance Show MediaType where - show = BS.unpack . renderHeader + show = BS.unpack . renderHeader instance IsString MediaType where - fromString str = flip fromMaybe (parseAccept $ BS.pack str) $ - error $ "Invalid media type literal " ++ str + fromString str = + flip fromMaybe (parseAccept $ BS.pack str) $ + error $ + "Invalid media type literal " ++ str instance Accept MediaType where - parseAccept bs = do - (s, ps) <- uncons (map trimBS (BS.split ';' bs)) - (a, b) <- breakChar '/' s - guard $ not (BS.null a || BS.null b) && (a /= "*" || b == "*") - ps' <- foldM insert Map.empty ps - return $ MediaType (CI.mk a) (CI.mk b) ps' - where - uncons [] = Nothing - uncons (a : b) = Just (a, b) - both f (a, b) = (f a, f b) - insert ps = - fmap (flip (uncurry Map.insert) ps . both CI.mk) . breakChar '=' + parseAccept bs = do + (s, ps) <- uncons (map trimBS (BS.split ';' bs)) + (a, b) <- breakChar '/' s + guard $ not (BS.null a || BS.null b) && (a /= "*" || b == "*") + ps' <- foldM insert Map.empty ps + return $ MediaType (CI.mk a) (CI.mk b) ps' + where + uncons [] = Nothing + uncons (a : b) = Just (a, b) + both f (a, b) = (f a, f b) + insert ps = + fmap (flip (uncurry Map.insert) ps . both CI.mk) . breakChar '=' - 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 + 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) + 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) - hasExtensionParameters _ = True + hasExtensionParameters _ = True instance RenderHeader MediaType where - renderHeader (MediaType a b p) = - Map.foldrWithKey f (original a <> "/" <> original b) p - where - f k v = (<> ";" <> original k <> "=" <> original v) - + renderHeader (MediaType a b p) = + Map.foldrWithKey f (original a <> "/" <> original b) p + where + f k v = (<> ";" <> original k <> "=" <> original v) ------------------------------------------------------------------------------- -- | 'MediaType' parameters. type Parameters = Map (CI ByteString) (CI ByteString) diff --git a/src/Network/HTTP/Media/Quality.hs b/src/Network/HTTP/Media/Quality.hs --- a/src/Network/HTTP/Media/Quality.hs +++ b/src/Network/HTTP/Media/Quality.hs @@ -1,90 +1,121 @@ ------------------------------------------------------------------------------- +{-# LANGUAGE DeriveFunctor #-} + -- | Defines the quality value data type. module Network.HTTP.Media.Quality - ( Quality (..) - , maxQuality - , minQuality - , showQ - , readQ - ) where - ------------------------------------------------------------------------------- -import qualified Data.ByteString.Char8 as BS + ( Quality (..), + quality, + QualityOrder, + qualityOrder, + isAcceptable, + maxQuality, + minQuality, + mostSpecific, + showQ, + readQ, + ) +where ------------------------------------------------------------------------------- import Data.ByteString (ByteString) -import Data.Char (isDigit) -import Data.List (dropWhileEnd) -import Data.Monoid ((<>)) -import Data.Word (Word16) - ------------------------------------------------------------------------------- +import qualified Data.ByteString.Char8 as BS +import Data.ByteString.UTF8 (toString) +import Data.Char (isDigit) +import Data.List (dropWhileEnd) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Word (Word16, Word32) +import Network.HTTP.Media.Accept (Accept, moreSpecificThan) import Network.HTTP.Media.RenderHeader (RenderHeader (..)) +import Prelude hiding ((<>)) ------------------------------------------------------------------------------- -- | Attaches a quality value to data. data Quality a = Quality - { qualityData :: a - , qualityValue :: Word16 - } deriving (Eq, Ord) + { qualityData :: a, + qualityValue :: Word16 + } + deriving (Eq, Functor, Ord) -instance RenderHeader a => Show (Quality a) where - show = BS.unpack . renderHeader +instance (RenderHeader a) => Show (Quality a) where + show = BS.unpack . renderHeader -instance RenderHeader h => RenderHeader (Quality h) where - renderHeader (Quality a q) = renderHeader a <> ";q=" <> showQ q +instance (RenderHeader h) => RenderHeader (Quality h) where + renderHeader (Quality a q) = renderHeader a <> ";q=" <> showQ q +-- | Manually construct a quality value. +quality :: a -> ByteString -> Quality a +quality x q = + Quality x $ + flip fromMaybe (readQ q) $ + error ("Invalid quality value " ++ toString q) ------------------------------------------------------------------------------- +-- | An opaque ordered representation of quality values without attached data. +newtype QualityOrder = QualityOrder Word16 + deriving (Eq, Ord) + +-- | Whether the quality value is greater than zero; otherwise the value +-- should never be accepted, even when no other options are available. +isAcceptable :: Quality a -> Bool +isAcceptable (Quality _ 0) = False +isAcceptable (Quality _ _) = True + +-- | 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 - ------------------------------------------------------------------------------- -- | 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) ------------------------------------------------------------------------------- -- | Converts the integral value into its standard quality representation. showQ :: Word16 -> ByteString showQ 1000 = "1" -showQ 0 = "0" -showQ q = "0." <> BS.replicate (3 - length s) '0' <> b +showQ 0 = "0" +showQ q = "0." <> BS.replicate (3 - length s) '0' <> b where s = show q b = BS.pack (dropWhileEnd (== '0') s) - ------------------------------------------------------------------------------- -- | Reads the standard quality representation into an integral value. readQ :: ByteString -> Maybe Word16 readQ bs - | BS.null bs = Nothing - | h == '1' = read1 t - | h == '0' = read0 t - | otherwise = Nothing + | BS.null bs = Nothing + | h == '1' = read1 t + | h == '0' = read0 t + | otherwise = Nothing where h = BS.head bs t = BS.tail bs read1 :: ByteString -> Maybe Word16 read1 bs - | BS.null bs || h == '.' && BS.length t < 4 && BS.all (== '0') t - = Just 1000 - | otherwise = Nothing + | BS.null bs || h == '.' && BS.length t < 4 && BS.all (== '0') t = + Just 1000 + | otherwise = Nothing where h = BS.head bs t = BS.tail bs read0 :: ByteString -> Maybe Word16 read0 bs - | BS.null bs = Just 0 - | h == '.' && BS.length t < 4 && BS.all isDigit t - = Just (toWord (t <> BS.replicate (3 - BS.length t) '0')) - | otherwise = Nothing + | BS.null bs = Just 0 + | h == '.' && BS.length t < 4 && BS.all isDigit t = + Just (toWord (t <> BS.replicate (3 - BS.length t) '0')) + | otherwise = Nothing where h = BS.head bs t = BS.tail bs diff --git a/src/Network/HTTP/Media/RenderHeader.hs b/src/Network/HTTP/Media/RenderHeader.hs --- a/src/Network/HTTP/Media/RenderHeader.hs +++ b/src/Network/HTTP/Media/RenderHeader.hs @@ -1,28 +1,24 @@ ------------------------------------------------------------------------------- -- | Defines the 'RenderHeader' type class, with the 'renderHeader' method. -- 'renderHeader' can be used to render basic header values (acting as -- identity on 'ByteString's), but it will also work on lists of quality -- values, which provides the necessary interface for rendering the full -- possibilities of Accept headers. module Network.HTTP.Media.RenderHeader - ( RenderHeader (..) - ) where + ( RenderHeader (..), + ) +where ------------------------------------------------------------------------------- import Data.ByteString (ByteString, intercalate) - ------------------------------------------------------------------------------- -- | A class for header values, so they may be rendered to their 'ByteString' -- representation. Lists of header values and quality-marked header values -- will render appropriately. class RenderHeader h where - - -- | Render a header value to a UTF-8 'ByteString'. - renderHeader :: h -> ByteString + -- | Render a header value to a UTF-8 'ByteString'. + renderHeader :: h -> ByteString instance RenderHeader ByteString where - renderHeader = id + renderHeader = id -instance RenderHeader h => RenderHeader [h] where - renderHeader = intercalate "," . map renderHeader +instance (RenderHeader h) => RenderHeader [h] where + renderHeader = intercalate "," . map renderHeader diff --git a/src/Network/HTTP/Media/Utils.hs b/src/Network/HTTP/Media/Utils.hs --- a/src/Network/HTTP/Media/Utils.hs +++ b/src/Network/HTTP/Media/Utils.hs @@ -1,47 +1,74 @@ ------------------------------------------------------------------------------ -- | Common utilities. module Network.HTTP.Media.Utils - ( breakChar - , trimBS - - , validChars - , isValidChar - ) where - ------------------------------------------------------------------------------- -import qualified Data.ByteString.Char8 as BS + ( breakChar, + trimBS, + mediaChars, + isMediaChar, + tokenChars, + isTokenChar, + isValidToken, + ) +where ------------------------------------------------------------------------------- import Data.ByteString (ByteString) - +import qualified Data.ByteString.Char8 as BS +import Data.Char (isControl) ------------------------------------------------------------------------------- -- | Equivalent to 'Data.ByteString.break' (on equality against the given -- character), but leaves out the byte that the string is broken on. breakChar :: Char -> ByteString -> Maybe (ByteString, ByteString) breakChar c = safeTail . BS.break (== c) where safeTail (a, b) - | BS.null b = Nothing - | otherwise = Just (a, BS.tail b) - + | BS.null b = Nothing + | otherwise = Just (a, BS.tail b) ------------------------------------------------------------------------------- -- | Trims tab and space characters from both ends of a ByteString. trimBS :: ByteString -> ByteString trimBS = fst . BS.spanEnd isLWS . BS.dropWhile isLWS where isLWS c = c == ' ' || c == '\t' - ------------------------------------------------------------------------------- -- | 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 diff --git a/test/Network/HTTP/Media/Accept/Tests.hs b/test/Network/HTTP/Media/Accept/Tests.hs --- a/test/Network/HTTP/Media/Accept/Tests.hs +++ b/test/Network/HTTP/Media/Accept/Tests.hs @@ -1,55 +1,32 @@ -{-# 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 Network.HTTP.Media.Accept import Network.HTTP.Media.Gen - +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) ------------------------------------------------------------------------------- -tests :: [Test] +tests :: [TestTree] tests = - [ testMatches - , testMoreSpecificThan - , testMostSpecific - ] - + [ testMatches, + testMoreSpecificThan + ] ------------------------------------------------------------------------------- -testMatches :: Test -testMatches = testGroup "matches" +testMatches :: TestTree +testMatches = + testGroup + "matches" [ testProperty "Does match" $ do string <- genByteString - return $ matches string string - , testProperty "Doesn't 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" $ +testMoreSpecificThan :: TestTree +testMoreSpecificThan = + testProperty "moreSpecificThan" $ (not .) . moreSpecificThan <$> genByteString <*> genByteString - - ------------------------------------------------------------------------------- -testMostSpecific :: Test -testMostSpecific = testProperty "mostSpecific" $ do - string <- genByteString - (=== string) . mostSpecific string <$> genByteString diff --git a/test/Network/HTTP/Media/Charset/Gen.hs b/test/Network/HTTP/Media/Charset/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Media/Charset/Gen.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TupleSections #-} + +-- | Contains definitions for generating 'Charset's. +module Network.HTTP.Media.Charset.Gen + ( anything, + genCharset, + genConcreteCharset, + genDiffCharset, + genDiffConcreteCharsets, + ) +where + +import Network.HTTP.Media.Charset.Internal +import Network.HTTP.Media.Gen (genDiffWith, genToken) +import Test.QuickCheck.Gen + +-- | 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 diff --git a/test/Network/HTTP/Media/Charset/Tests.hs b/test/Network/HTTP/Media/Charset/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Media/Charset/Tests.hs @@ -0,0 +1,83 @@ +module Network.HTTP.Media.Charset.Tests (tests) where + +import Control.Monad (join) +import qualified Data.ByteString.Char8 as BS +import Data.String (fromString) +import Network.HTTP.Media.Accept +import Network.HTTP.Media.Charset (Charset) +import Network.HTTP.Media.Charset.Gen +import Network.HTTP.Media.RenderHeader +import Test.QuickCheck ((===)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +tests :: [TestTree] +tests = + [ testEq, + testShow, + testFromString, + testMatches, + testMoreSpecific, + testParseAccept + ] + +-- Equality is derived, but we test it here to get 100% coverage. +testEq :: TestTree +testEq = + testGroup + "Eq" + [ testProperty "==" $ do + enc <- genCharset + return $ enc === enc, + testProperty "/=" $ do + enc <- genCharset + enc' <- genDiffCharset enc + return $ enc /= enc' + ] + +testShow :: TestTree +testShow = testProperty "show" $ do + enc <- genCharset + return $ parseAccept (BS.pack $ show enc) === Just enc + +testFromString :: TestTree +testFromString = testProperty "fromString" $ do + enc <- genCharset + return $ enc === fromString (show enc) + +testMatches :: TestTree +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 :: TestTree +testMoreSpecific = + testGroup + "moreSpecificThan" + [ testProperty "Against *" $ + flip moreSpecificThan anything <$> genConcreteCharset, + testProperty "With *" $ + not . moreSpecificThan anything <$> genConcreteCharset, + testProperty "Unrelated encodings" $ + not . uncurry moreSpecificThan <$> genDiffConcreteCharsets + ] + +testParseAccept :: TestTree +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 + ] diff --git a/test/Network/HTTP/Media/Encoding/Gen.hs b/test/Network/HTTP/Media/Encoding/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Media/Encoding/Gen.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TupleSections #-} + +-- | Contains definitions for generating 'Encoding's. +module Network.HTTP.Media.Encoding.Gen + ( anything, + identity, + genEncoding, + genConcreteEncoding, + genDiffEncoding, + genDiffConcreteEncodings, + ) +where + +import Network.HTTP.Media.Encoding.Internal +import Network.HTTP.Media.Gen (genDiffWith, genToken) +import Test.QuickCheck.Gen + +-- | 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 diff --git a/test/Network/HTTP/Media/Encoding/Tests.hs b/test/Network/HTTP/Media/Encoding/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Media/Encoding/Tests.hs @@ -0,0 +1,82 @@ +module Network.HTTP.Media.Encoding.Tests (tests) where + +import Control.Monad (join) +import qualified Data.ByteString.Char8 as BS +import Data.String (fromString) +import Network.HTTP.Media.Accept +import Network.HTTP.Media.Encoding.Gen +import Network.HTTP.Media.RenderHeader +import Test.QuickCheck ((===)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +tests :: [TestTree] +tests = + [ testEq, + testShow, + testFromString, + testMatches, + testMoreSpecific, + testParseAccept + ] + +-- Equality is derived, but we test it here to get 100% coverage. +testEq :: TestTree +testEq = + testGroup + "Eq" + [ testProperty "==" $ do + enc <- genEncoding + return $ enc === enc, + testProperty "/=" $ do + enc <- genEncoding + enc' <- genDiffEncoding enc + return $ enc /= enc' + ] + +testShow :: TestTree +testShow = testProperty "show" $ do + enc <- genEncoding + return $ parseAccept (BS.pack $ show enc) === Just enc + +testFromString :: TestTree +testFromString = testProperty "fromString" $ do + enc <- genEncoding + return $ enc === fromString (show enc) + +testMatches :: TestTree +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 :: TestTree +testMoreSpecific = + testGroup + "moreSpecificThan" + [ testProperty "Against *" $ + flip moreSpecificThan anything <$> genConcreteEncoding, + testProperty "With *" $ + not . moreSpecificThan anything <$> genConcreteEncoding, + testProperty "Unrelated encodings" $ + not . uncurry moreSpecificThan <$> genDiffConcreteEncodings + ] + +testParseAccept :: TestTree +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 + ] diff --git a/test/Network/HTTP/Media/Gen.hs b/test/Network/HTTP/Media/Gen.hs --- a/test/Network/HTTP/Media/Gen.hs +++ b/test/Network/HTTP/Media/Gen.hs @@ -1,83 +1,72 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------- -- | Contains definitions for generating 'ByteString's. module Network.HTTP.Media.Gen - ( genByteStringFrom - , genCIByteStringFrom - , genByteString - , genCIByteString - , genDiffWith - , genDiffByteString - , genDiffCIByteString - - , padString - ) where - ------------------------------------------------------------------------------- -#if !MIN_VERSION_base(4, 8, 0) -import Data.Functor ((<$>)) -#endif + ( genToken, + genByteStringFrom, + genCIByteStringFrom, + genByteString, + genCIByteString, + genDiffWith, + genDiffByteString, + genDiffCIByteString, + padString, + ) +where ------------------------------------------------------------------------------- +import Control.Monad (join, liftM2) +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS -import qualified Data.CaseInsensitive as CI - ------------------------------------------------------------------------------- -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) +import qualified Data.CaseInsensitive as CI +import Data.Monoid ((<>)) +import qualified Network.HTTP.Media.Utils as Utils +import Test.QuickCheck.Gen (Gen) +import qualified Test.QuickCheck.Gen as Gen +import Prelude hiding ((<>)) +-- | 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 ------------------------------------------------------------------------------- genCIByteStringFrom :: String -> Gen (CI ByteString) genCIByteStringFrom = fmap CI.mk . genByteStringFrom - ------------------------------------------------------------------------------- --- | 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 - ------------------------------------------------------------------------------- -- | 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 :: (Eq a) => Gen a -> a -> Gen a +genDiffWith gen = Gen.suchThat gen . (/=) ------------------------------------------------------------------------------- -- | Produces a non-empty ByteString of random alphanumeric characters that -- is case-insensitively different to the given one. genDiffByteString :: ByteString -> Gen ByteString genDiffByteString = fmap original . genDiffCIByteString . CI.mk - ------------------------------------------------------------------------------- -- | Produces a non-empty case-insensitive ByteString of random alphanumeric -- characters that is different to the given one. genDiffCIByteString :: CI ByteString -> Gen (CI ByteString) genDiffCIByteString = genDiffWith genCIByteString - ------------------------------------------------------------------------------- -- | 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")) - where pad a b = a <> c <> b +padString c = join (liftM2 pad) (BS.pack <$> Gen.listOf (Gen.elements " \t")) + where + pad a b = a <> c <> b diff --git a/test/Network/HTTP/Media/Language/Gen.hs b/test/Network/HTTP/Media/Language/Gen.hs --- a/test/Network/HTTP/Media/Language/Gen.hs +++ b/test/Network/HTTP/Media/Language/Gen.hs @@ -1,120 +1,84 @@ -{-# LANGUAGE CPP, TupleSections #-} +{-# LANGUAGE TupleSections #-} ------------------------------------------------------------------------------- -- | Contains definitions for generating 'Language's. module Network.HTTP.Media.Language.Gen - ( - -- * Generating Languages - anything - , genLanguage - , genConcreteLanguage - , genDiffLanguage - , genMatchingLanguage - , genDiffMatchingLanguage - , genNonMatchingLanguage - , genMatchingLanguages - , genDiffMatchingLanguages - , genNonMatchingLanguages - ) where + ( -- * Generating Languages + anything, + genLanguage, + genConcreteLanguage, + genDiffLanguage, + genMatchingLanguage, + genDiffMatchingLanguage, + genNonMatchingLanguage, + genMatchingLanguages, + genDiffMatchingLanguages, + genNonMatchingLanguages, + ) +where ------------------------------------------------------------------------------- -#if !MIN_VERSION_base(4, 8, 0) -import Control.Applicative ((<$>)) -#endif -import Data.ByteString (ByteString) +import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) -import Test.QuickCheck.Gen - ------------------------------------------------------------------------------- import qualified Network.HTTP.Media.Gen as Gen - ------------------------------------------------------------------------------- import Network.HTTP.Media.Language.Internal - +import Test.QuickCheck.Gen ------------------------------------------------------------------------------- -- | The Language that matches anything. anything :: Language anything = Language [] - ------------------------------------------------------------------------------- -- | Generates any kind of Language. genLanguage :: Gen Language genLanguage = Language <$> listOf genCIByteString - ------------------------------------------------------------------------------- -- | Generates a Language that does not match everything. genConcreteLanguage :: Gen Language genConcreteLanguage = Language <$> listOf1 genCIByteString - ------------------------------------------------------------------------------- -- | Generates a different Language to the given one. genDiffLanguage :: Language -> Gen Language genDiffLanguage (Language []) = genConcreteLanguage -genDiffLanguage l = Gen.genDiffWith genLanguage l - +genDiffLanguage l = Gen.genDiffWith genLanguage l ------------------------------------------------------------------------------- -- | Generate a Language that has the given language as a prefix. genMatchingLanguage :: Language -> Gen Language genMatchingLanguage (Language pre) = - (Language . (pre ++)) <$> listOf genCIByteString - + Language . (pre ++) <$> listOf genCIByteString ------------------------------------------------------------------------------- -- | Generate a Language that has the given language as a proper prefix. genDiffMatchingLanguage :: Language -> Gen Language genDiffMatchingLanguage (Language pre) = - (Language . (pre ++)) <$> listOf1 genCIByteString - + Language . (pre ++) <$> listOf1 genCIByteString ------------------------------------------------------------------------------- -- | Generate a Language that does not have the given language as a prefix. genNonMatchingLanguage :: Language -> Gen Language -genNonMatchingLanguage (Language []) = genConcreteLanguage +genNonMatchingLanguage (Language []) = genConcreteLanguage genNonMatchingLanguage (Language (pre : _)) = do - pre' <- genDiffCIByteString pre - genMatchingLanguage $ Language [pre'] - + pre' <- genDiffCIByteString pre + genMatchingLanguage $ Language [pre'] ------------------------------------------------------------------------------- -- | A private definition for generating pairs of languagues. genLanguages :: (Language -> Gen Language) -> Gen (Language, Language) genLanguages gen = do - pre <- genLanguage - (pre,) <$> gen pre - + pre <- genLanguage + (pre,) <$> gen pre ------------------------------------------------------------------------------- -- | Generate two languages, the first of which is a prefix of the second. genMatchingLanguages :: Gen (Language, Language) genMatchingLanguages = genLanguages genMatchingLanguage - ------------------------------------------------------------------------------- -- | Generate two languages, the first of which is a proper prefix of the -- second. genDiffMatchingLanguages :: Gen (Language, Language) genDiffMatchingLanguages = genLanguages genDiffMatchingLanguage - ------------------------------------------------------------------------------- -- | Generate two languages, the first of which is not a prefix of the second. genNonMatchingLanguages :: Gen (Language, Language) genNonMatchingLanguages = do - pre <- genConcreteLanguage - (pre,) <$> genNonMatchingLanguage pre - + pre <- genConcreteLanguage + (pre,) <$> genNonMatchingLanguage pre ------------------------------------------------------------------------------- genCIByteString :: Gen (CI ByteString) -genCIByteString = - resize 8 $ Gen.genCIByteStringFrom (['a'..'z'] ++ ['A'..'Z']) - +genCIByteString = resize 8 Gen.genCIByteString ------------------------------------------------------------------------------- genDiffCIByteString :: CI ByteString -> Gen (CI ByteString) genDiffCIByteString = Gen.genDiffWith genCIByteString diff --git a/test/Network/HTTP/Media/Language/Tests.hs b/test/Network/HTTP/Media/Language/Tests.hs --- a/test/Network/HTTP/Media/Language/Tests.hs +++ b/test/Network/HTTP/Media/Language/Tests.hs @@ -1,129 +1,92 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------- module Network.HTTP.Media.Language.Tests (tests) where ------------------------------------------------------------------------------- -#if !MIN_VERSION_base(4, 8, 0) -import Data.Functor ((<$>)) -#endif - ------------------------------------------------------------------------------- +import Control.Monad (join) 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 Data.Monoid ((<>)) +import Data.String (fromString) import Network.HTTP.Media.Accept import Network.HTTP.Media.Language import Network.HTTP.Media.Language.Gen import Network.HTTP.Media.RenderHeader - +import Test.QuickCheck ((===)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Prelude hiding ((<>)) ------------------------------------------------------------------------------- -tests :: [Test] +tests :: [TestTree] tests = - [ testEq - , testShow - , testFromString - , testMatches - , testMoreSpecific - , testMostSpecific - , testParseAccept - ] - + [ testEq, + testShow, + testFromString, + testMatches, + testMoreSpecific, + testParseAccept + ] ------------------------------------------------------------------------------- -- Equality is derived, but we test it here to get 100% coverage. -testEq :: Test -testEq = testGroup "Eq" +testEq :: TestTree +testEq = + testGroup + "Eq" [ testProperty "==" $ do lang <- genLanguage - return $ lang === lang - , testProperty "/=" $ do - lang <- genLanguage + return $ lang === lang, + testProperty "/=" $ do + lang <- genLanguage lang' <- genDiffLanguage lang return $ lang /= lang' ] - ------------------------------------------------------------------------------- -testShow :: Test +testShow :: TestTree testShow = testProperty "show" $ do - lang <- genLanguage - return $ parseAccept (BS.pack $ show lang) === Just lang - + lang <- genLanguage + return $ parseAccept (BS.pack $ show lang) === Just lang ------------------------------------------------------------------------------- -testFromString :: Test +testFromString :: TestTree testFromString = testProperty "fromString" $ do - lang <- genLanguage - return $ lang === fromString (show lang) - + lang <- genLanguage + return $ lang === fromString (show lang) ------------------------------------------------------------------------------- -testMatches :: Test -testMatches = testGroup "matches" +testMatches :: TestTree +testMatches = + testGroup + "matches" [ testProperty "Equal values match" $ - join matches <$> genLanguage - , testProperty "Right prefix matches left" $ - uncurry (flip matches) <$> genMatchingLanguages - , testProperty "Left prefix does not match right" $ - not . uncurry matches <$> genDiffMatchingLanguages - , testProperty "* matches anything" $ - flip matches anything <$> genLanguage - , testProperty "No concrete language matches *" $ + join matches <$> genLanguage, + testProperty "Right prefix matches left" $ + uncurry (flip matches) <$> genMatchingLanguages, + testProperty "Left prefix does not match right" $ + not . uncurry matches <$> genDiffMatchingLanguages, + testProperty "* matches anything" $ + flip matches anything <$> genLanguage, + testProperty "No concrete language matches *" $ not . matches anything <$> genConcreteLanguage ] - ------------------------------------------------------------------------------- -testMoreSpecific :: Test -testMoreSpecific = testGroup "moreSpecificThan" +testMoreSpecific :: TestTree +testMoreSpecific = + testGroup + "moreSpecificThan" [ testProperty "Against *" $ - flip moreSpecificThan anything <$> genConcreteLanguage - , testProperty "With *" $ - not . moreSpecificThan anything <$> genLanguage - , testProperty "Proper prefix lhs" $ - not . uncurry moreSpecificThan <$> genDiffMatchingLanguages - , testProperty "Proper prefix rhs" $ - uncurry (flip moreSpecificThan) <$> genDiffMatchingLanguages - , testProperty "Unrelated languages" $ + flip moreSpecificThan anything <$> genConcreteLanguage, + testProperty "With *" $ + not . moreSpecificThan anything <$> genLanguage, + testProperty "Proper prefix lhs" $ + not . uncurry moreSpecificThan <$> genDiffMatchingLanguages, + testProperty "Proper prefix rhs" $ + 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' - ] - - ------------------------------------------------------------------------------- -testParseAccept :: Test -testParseAccept = testGroup "parseAccept" - [ testProperty "Valid parse"$ do +testParseAccept :: TestTree +testParseAccept = + testGroup + "parseAccept" + [ testProperty "Valid parse" $ do lang <- genLanguage - return $ parseAccept (renderHeader lang) === Just lang - , testProperty "Trailing hyphen" $ do + return $ parseAccept (renderHeader lang) === Just lang, + testProperty "Trailing hyphen" $ do bs <- renderHeader <$> genLanguage return $ (parseAccept $ bs <> "-" :: Maybe Language) === Nothing ] diff --git a/test/Network/HTTP/Media/MediaType/Gen.hs b/test/Network/HTTP/Media/MediaType/Gen.hs --- a/test/Network/HTTP/Media/MediaType/Gen.hs +++ b/test/Network/HTTP/Media/MediaType/Gen.hs @@ -1,188 +1,170 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------- -- | Contains definitions for generating 'MediaType's. module Network.HTTP.Media.MediaType.Gen - ( - -- * Generating MediaTypes - anything - , genMediaType - , genSubStar - , genMaybeSubStar - , subStarOf - , genConcreteMediaType - , genWithoutParams - , genWithParams - , stripParams - , genDiffMediaTypesWith - , genDiffMediaTypeWith - , genDiffMediaTypes - , genDiffMediaType + ( -- * Generating MediaTypes + anything, + genMediaType, + genSubStar, + genMaybeSubStar, + subStarOf, + genConcreteMediaType, + genWithoutParams, + genWithParams, + stripParams, + genDiffMediaTypesWith, + genDiffMediaTypeWith, + genDiffMediaTypes, + genDiffMediaType, + genMatchingPair, -- * Generating Parameters - , genParameters - , genMaybeParameters - , genDiffParameters + genParameters, + genMaybeParameters, + genDiffParameters, -- * Rendering Parameters - , renderParameters - ) where - ------------------------------------------------------------------------------- -#if !MIN_VERSION_base(4, 8, 0) -import Data.Functor ((<$>)) -#endif - ------------------------------------------------------------------------------- -import qualified Data.Map as Map + renderParameters, + ) +where ------------------------------------------------------------------------------- -import Control.Monad (liftM, liftM2) -import Data.ByteString (ByteString) +import Control.Monad (filterM, 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 Data.Foldable (foldlM) +import Data.Map (fromList) +import qualified Data.Map as Map +import Data.Monoid ((<>)) import Network.HTTP.Media.Gen import Network.HTTP.Media.MediaType.Internal - +import Test.QuickCheck.Gen +import Prelude hiding ((<>)) ------------------------------------------------------------------------------- -- | Parameter entry for testing. type ParamEntry = (CI ByteString, CI 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 <- genCIByteString - return $ MediaType main "*" Map.empty - + main <- genCIByteString + 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 } - +subStarOf media = media {subType = "*", parameters = Map.empty} ------------------------------------------------------------------------------- -- | Generates a concrete MediaType which may have parameters. genConcreteMediaType :: Gen MediaType genConcreteMediaType = do - main <- genCIByteString - sub <- genCIByteString - params <- oneof [return Map.empty, genParameters] - return $ MediaType main sub params - + main <- genCIByteString + sub <- genCIByteString + params <- oneof [return Map.empty, genParameters] + return $ MediaType main sub params ------------------------------------------------------------------------------- -- | Generates a concrete MediaType with no parameters. genWithoutParams :: Gen MediaType genWithoutParams = do - main <- genCIByteString - sub <- genCIByteString - return $ MediaType main sub Map.empty - + main <- genCIByteString + sub <- genCIByteString + return $ MediaType main sub Map.empty ------------------------------------------------------------------------------- -- | Generates a MediaType with at least one parameter. genWithParams :: Gen MediaType genWithParams = do - main <- genCIByteString - sub <- genCIByteString - params <- genParameters - return $ MediaType main sub params - + main <- genCIByteString + sub <- genCIByteString + MediaType main sub <$> genParameters ------------------------------------------------------------------------------- -- | Strips the parameters from the given MediaType. stripParams :: MediaType -> MediaType -stripParams media = media { parameters = Map.empty } - +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' - + 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. +-- | 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 (,) (genDiffCIByteString "q") genCIByteString) - +mkGenParams = + fmap fromList + . ($ liftM2 (,) (genDiffCIByteString "q") genCIByteString) ------------------------------------------------------------------------------- -- | 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' + params' <- genParameters + 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 + -- | Render parameters with a generated amount of whitespace between the -- semicolons. Note that there is a leading semicolon in front of the -- parameters, as it is expected that this will always be attached to @@ -191,4 +173,4 @@ renderParameters params = foldlM pad "" (Map.toList params) where pad s (k, v) = - (s <>) . (<> original k <> "=" <> original v) <$> padString ";" + (s <>) . (<> original k <> "=" <> original v) <$> padString ";" diff --git a/test/Network/HTTP/Media/MediaType/Tests.hs b/test/Network/HTTP/Media/MediaType/Tests.hs --- a/test/Network/HTTP/Media/MediaType/Tests.hs +++ b/test/Network/HTTP/Media/MediaType/Tests.hs @@ -1,245 +1,198 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------- module Network.HTTP.Media.MediaType.Tests (tests) where ------------------------------------------------------------------------------- -#if !MIN_VERSION_base(4, 8, 0) -import Data.Functor ((<$>)) -#endif - ------------------------------------------------------------------------------- +import Control.Monad (join) +import Data.ByteString (ByteString) 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 Data.CaseInsensitive (foldedCase) +import qualified Data.Map as Map +import Data.Monoid ((<>)) +import Data.String (fromString) import Network.HTTP.Media.Accept import Network.HTTP.Media.Gen -import Network.HTTP.Media.MediaType ((/.), (/?)) +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.RenderHeader (renderHeader) +import Test.QuickCheck (property, (.&&.), (===)) +import Test.QuickCheck.Gen (Gen) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Prelude hiding ((<>)) ------------------------------------------------------------------------------- -tests :: [Test] +tests :: [TestTree] tests = - [ testEq - , testShow - , testFromString - , testHas - , testGet - , testMatches - , testMoreSpecificThan - , testMostSpecific - , testParseAccept - ] - + [ testEq, + testShow, + testFromString, + testHas, + testGet, + testMatches, + testMoreSpecificThan, + testParseAccept + ] ------------------------------------------------------------------------------- -- Equality is derived, but we test it here to get 100% coverage. -testEq :: Test -testEq = testGroup "Eq" +testEq :: TestTree +testEq = + testGroup + "Eq" [ testProperty "==" $ do media <- genMediaType - return $ media === media - , testProperty "/=" $ do - media <- genMediaType + return $ media === media, + testProperty "/=" $ do + media <- genMediaType media' <- genDiffMediaType media return $ media /= media' ] - ------------------------------------------------------------------------------- -testShow :: Test +testShow :: TestTree testShow = testProperty "show" $ do - media <- genMediaType - return $ parseAccept (BS.pack $ show media) === Just media - + media <- genMediaType + return $ parseAccept (BS.pack $ show media) === Just media ------------------------------------------------------------------------------- -testFromString :: Test +testFromString :: TestTree testFromString = testProperty "fromString" $ do - media <- genMediaType - return $ media === fromString (show media) - + media <- genMediaType + return $ media === fromString (show media) ------------------------------------------------------------------------------- -testHas :: Test -testHas = testGroup "(/?)" +testHas :: TestTree +testHas = + testGroup + "(/?)" [ testProperty "True for property it has" $ do media <- genWithParams - return $ all ((media /?) . foldedCase) (Map.keys $ parameters media) - , testProperty "False for property it doesn't have" $ do + return $ all ((media /?) . foldedCase) (Map.keys $ parameters media), + testProperty "False for property it doesn't have" $ do media <- genWithParams - return $ all (not . (stripParams media /?) . foldedCase) + return . not $ + any + ((stripParams media /?) . foldedCase) (Map.keys $ parameters media) ] - ------------------------------------------------------------------------------- -testGet :: Test -testGet = testGroup "(/.)" +testGet :: TestTree +testGet = + testGroup + "(/.)" [ testProperty "Retrieves property it has" $ do - media <- genWithParams + media <- genWithParams let is n v = (.&&. media /. foldedCase n === Just v) - return $ Map.foldrWithKey is (property True) $ parameters media - , testProperty "Nothing for property it doesn't have" $ do + return $ Map.foldrWithKey is (property True) $ parameters media, + testProperty "Nothing for property it doesn't have" $ do media <- genWithParams let is n _ = (.&&. stripParams media /. foldedCase n === Nothing) return $ Map.foldrWithKey is (property True) $ parameters media ] - ------------------------------------------------------------------------------- -testMatches :: Test -testMatches = testGroup "matches" +testMatches :: TestTree +testMatches = + testGroup + "matches" [ testProperty "Equal values match" $ do media <- genMediaType - return $ matches media media - , testProperty "Same sub but different main don't match" $ do + return $ matches media media, + testProperty "Same sub but different main don't match" $ do media <- genMaybeSubStar - main <- genDiffCIByteString $ 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 + main <- genDiffCIByteString $ 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 <- genDiffCIByteString $ 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 + sub <- genDiffCIByteString $ subType media + return . not $ + matches media media {subType = sub} + || matches media {subType = sub} media, + testProperty "Different parameters don't match" $ + 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 + return $ matches media media' && not (matches media' media), + testGroup + "*/*" + [ testProperty "Matches itself" $ matches anything anything, + testProperty "Matches anything on the right" $ + (`matches` anything) <$> genMediaType, + testProperty "Doesn't match more specific on the left" $ + not . (anything `matches`) <$> genMaybeSubStar + ], + testGroup + "type/*" + [ testProperty "Matches itself" $ join matches <$> genSubStar, + testProperty "Matches on the right" $ + dotJoin (flip matches) subStarOf <$> genConcreteMediaType, + testProperty "Doesn't match on the left" $ + not . dotJoin matches subStarOf <$> genConcreteMediaType ] ] - ------------------------------------------------------------------------------- -testMoreSpecificThan :: Test -testMoreSpecificThan = testGroup "moreSpecificThan" +testMoreSpecificThan :: TestTree +testMoreSpecificThan = + testGroup + "moreSpecificThan" [ 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 + (`moreSpecificThan` anything) <$> genMaybeSubStar, + testProperty "With */*" $ + not . (anything `moreSpecificThan`) <$> genMaybeSubStar, + testProperty "Against type/*" $ + dotJoin (flip moreSpecificThan) subStarOf <$> genConcreteMediaType, + testProperty "With type/*" $ + not . dotJoin moreSpecificThan subStarOf <$> genConcreteMediaType, + testProperty "With parameters" $ + 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 + 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'' + return . not $ moreSpecificThan media media {parameters = params} ] - ------------------------------------------------------------------------------- -testParseAccept :: Test -testParseAccept = testGroup "parseAccept" +testParseAccept :: TestTree +testParseAccept = + testGroup + "parseAccept" [ testProperty "Valid parse" $ do media <- genMediaType let main = mainType media - sub = subType media + sub = subType media params <- renderParameters (parameters media) let parsed = parseAccept $ foldedCase (main <> "/" <> sub) <> params - return $ parsed === Just media - , testProperty "No sub" $ do + return $ parsed === Just media, + testProperty "No sub" $ do bs <- genByteString - return $ (parseAccept bs :: Maybe MediaType) === Nothing - , testProperty "Empty main" $ do + return $ (parseAccept bs :: Maybe MediaType) === Nothing, + testProperty "Empty main" $ do sep <- padString "/" - bs <- (sep <>) <$> genByteString - return $ (parseAccept bs :: Maybe MediaType) === Nothing - , testProperty "Empty sub" $ do + bs <- (sep <>) <$> genByteString + return $ (parseAccept bs :: Maybe MediaType) === Nothing, + testProperty "Empty sub" $ do sep <- padString "/" - bs <- (<> sep) <$> genByteString - return $ (parseAccept bs :: Maybe MediaType) === Nothing - , testProperty "Empty parameters" $ do + bs <- (<> sep) <$> genByteString + return $ (parseAccept bs :: Maybe MediaType) === Nothing, + testProperty "Empty parameters" $ do sep <- padString ";" - bs <- renderHeader <$> genWithoutParams - return $ (parseAccept (bs <> sep) :: Maybe MediaType) === Nothing - , testProperty "No value" $ - (=== Nothing) <$> genMediaNameAndParams "" - , testProperty "Empty value" $ do + bs <- renderHeader <$> genWithoutParams + return $ (parseAccept (bs <> sep) :: Maybe MediaType) === Nothing, + testProperty "No value" $ + (=== Nothing) <$> genMediaNameAndParams "", + testProperty "Empty value" $ do eq <- padString "=" (=== Nothing) <$> genMediaNameAndParams eq ] genMediaNameAndParams :: ByteString -> Gen (Maybe MediaType) genMediaNameAndParams eq = do - sep <- padString ";" - bs <- renderHeader <$> genByteString - name <- genByteString - ps <- genMaybeParameters >>= renderParameters - return $ parseAccept (bs <> sep <> name <> eq <> sep <> ps) - + sep <- padString ";" + bs <- renderHeader <$> genByteString + name <- genByteString + ps <- genMaybeParameters >>= renderParameters + return $ parseAccept (bs <> sep <> name <> eq <> sep <> ps) ------------------------------------------------------------------------------- -- | 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 diff --git a/test/Network/HTTP/Media/Tests.hs b/test/Network/HTTP/Media/Tests.hs --- a/test/Network/HTTP/Media/Tests.hs +++ b/test/Network/HTTP/Media/Tests.hs @@ -1,56 +1,52 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections #-} ------------------------------------------------------------------------------- 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.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 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 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 Test.QuickCheck +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Prelude hiding ((<>)) ------------------------------------------------------------------------------- -tests :: [Test] +tests :: [TestTree] tests = - [ testParse - , testMatchAccept - , testMapAccept - , testMatchContent - , testMapContent - , testMatchQuality - , testMapQuality - ] - + [ testParse, + testMatchAccept, + testMapAccept, + testMatchContent, + testMapContent, + testMatchQuality, + testMapQuality + ] ------------------------------------------------------------------------------- -testParse :: Test -testParse = testGroup "parseQuality" +testParse :: TestTree +testParse = + testGroup + "parseQuality" [ testProperty "Without quality" $ do - media <- medias + media <- medias rendered <- padConcat (return . renderHeader) media - return $ parseQuality rendered === Just (map maxQuality media) - , testProperty "With quality" $ do - media <- qualities + return $ parseQuality rendered === Just (map maxQuality media), + testProperty "With quality" $ do + media <- qualities rendered <- padConcat padQuality media - return $ parseQuality rendered === Just media - , testProperty "With extensions" $ do - media <- qualities + return $ parseQuality rendered === Just media, + testProperty "With extensions" $ do + media <- qualities rendered <- padConcat (padQuality >=> padExtensions) media return $ parseQuality rendered === Just media ] @@ -60,145 +56,190 @@ padConcat f l = flip (foldlM (padComma f)) (tail l) =<< f (head l) padComma f a b = pad a <$> padString "," <*> f b padQuality qMedia = do - semi <- padString ";" - let d = renderHeader (qualityData qMedia) - v = showQ (qualityValue qMedia) - return $ d <> semi <> "q=" <> v + semi <- padString ";" + let d = renderHeader (qualityData qMedia) + v = showQ (qualityValue qMedia) + return $ d <> semi <> "q=" <> v padExtensions s = genParameters >>= fmap (s <>) . renderParameters pad a s b = a <> s <> b - ------------------------------------------------------------------------------- -testMatchAccept :: Test +testMatchAccept :: TestTree testMatchAccept = testMatch "Accept" matchAccept renderHeader - ------------------------------------------------------------------------------- -testMapAccept :: Test +testMapAccept :: TestTree testMapAccept = testMap "Accept" mapAccept renderHeader - ------------------------------------------------------------------------------- -testMatchContent :: Test -testMatchContent = testGroup "matchContent" +testMatchContent :: TestTree +testMatchContent = + testGroup + "matchContent" [ testProperty "Matches" $ do media <- genMediaType - return $ matchContent [media] (renderHeader media) === Just media - , testProperty "Nothing" $ do + return $ matchContent [media] (renderHeader media) === Just media, + testProperty "Nothing" $ do content <- genMediaType parsers <- filter (not . matches content) <$> genServer - return $ matchContent parsers (renderHeader content) === Nothing - , testProperty "Against */*" $ do + return $ matchContent parsers (renderHeader content) === Nothing, + testProperty "Against */*" $ do media <- genMediaType return $ - matchContent [anything] (renderHeader media) === Just anything - , testProperty "Against type/*" $ do + matchContent [anything] (renderHeader media) === Just anything, + testProperty "Against type/*" $ do media <- genMediaType let sub = subStarOf media return $ matchContent [sub] (renderHeader media) === Just sub ] - ------------------------------------------------------------------------------- -testMapContent :: Test -testMapContent = testGroup "mapContent" +testMapContent :: TestTree +testMapContent = + testGroup + "mapContent" [ testProperty "Matches" $ do media <- genMediaType - return $ mapContent [(media, ())] (renderHeader media) === Just () - , testProperty "Nothing" $ do + return $ mapContent [(media, ())] (renderHeader media) === Just (), + testProperty "Nothing" $ do content <- genMediaType parsers <- join zip . filter (not . matches content) <$> genServer - return $ mapContent parsers (renderHeader content) === Nothing + return $ mapContent parsers (renderHeader content) === Nothing, + testProperty "Overlapping keys" $ do + (a, b) <- genMatchingPair + return $ mapContent [(a, False), (b, True)] (renderHeader b) ] - ------------------------------------------------------------------------------- -testMatchQuality :: Test +testMatchQuality :: TestTree testMatchQuality = testMatch "Quality" matchQuality id - ------------------------------------------------------------------------------- -testMapQuality :: Test +testMapQuality :: TestTree testMapQuality = testMap "Quality" mapQuality id - ------------------------------------------------------------------------------- -testMatch - :: String - -> ([MediaType] -> a -> Maybe MediaType) - -> ([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 +testMatch :: + String -> + ([MediaType] -> a -> Maybe MediaType) -> + ([Quality MediaType] -> a) -> + TestTree +testMatch name match qToI = + testGroup + ("match" ++ name) + [ testProperty "Most specific" $ do media <- genConcreteMediaType - let client = qToI $ map maxQuality - [ MediaType "*" "*" empty - , media { subType = "*" } - , media { parameters = empty } - , media - ] - return $ match [media] client === Just media - , testProperty "Nothing" $ do + let client = + qToI $ + map + maxQuality + [ MediaType "*" "*" empty, + media {subType = "*"}, + media {parameters = empty}, + media + ] + return $ match [media] client === Just media, + testProperty "Nothing" $ do 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 + return $ match server (qToI $ map maxQuality client) === Nothing, + testProperty "Left biased" $ do + server <- genNubServer let client = qToI $ map maxQuality server - return $ match server client === Just (head server) - , testProperty "Against */*" $ do - server <- genServer + return $ match server client === Just (head server), + testProperty "Against */*" $ do + server <- genNubServer let stars = "*/*" :: MediaType - return $ match server (qToI [maxQuality stars]) === - Just (head server) - , testProperty "Against type/*" $ do - server <- genServer + return $ + match server (qToI [maxQuality stars]) + === Just (head server), + testProperty "Against type/*" $ do + server <- genNubServer let client = qToI [maxQuality (subStarOf $ head server)] - return $ match server client === Just (head server) + return $ match server client === Just (head server), + testQuality match qToI ] +testQuality :: + ([MediaType] -> a -> Maybe MediaType) -> + ([Quality MediaType] -> a) -> + TestTree +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 + ] ------------------------------------------------------------------------------- -testMap - :: String - -> ([(MediaType, MediaType)] -> a -> Maybe MediaType) - -> ([Quality MediaType] -> a) - -> Test -testMap name mapf qToI = testGroup ("map" ++ name) +testQ0 :: + ([MediaType] -> a -> Maybe MediaType) -> + ([Quality MediaType] -> a) -> + TestTree +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) -> + ([Quality MediaType] -> a) -> + TestTree +testMap name mapf qToI = + testGroup + ("map" ++ name) [ testProperty "Matches" $ do server <- genServer - qs <- replicateM (length server) $ choose (1, 1000 :: Word16) + 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 $ mapf zipped (qToI client) === - Just (qualityData $ foldr1 qmax client) - , testProperty "Nothing" $ do + return $ + mapf zipped (qToI client) + === Just (qualityData $ foldr1 qmax client), + testProperty "Nothing" $ do (server, client) <- genServerAndClient - let zipped = zip server $ repeat "*/*" + let zipped = map (,"*/*") server return $ mapf zipped (qToI $ map maxQuality client) === Nothing ] - ------------------------------------------------------------------------------- genServer :: Gen [MediaType] genServer = listOf1 genConcreteMediaType +genNubServer :: Gen [MediaType] +genNubServer = nubBy (on (==) stripParams) <$> genServer ------------------------------------------------------------------------------- genServerAndClient :: Gen ([MediaType], [MediaType]) genServerAndClient = do - server <- genServer - client <- filter (not . flip any server . flip matches) <$> - listOf1 (genDiffMediaTypesWith genConcreteMediaType server) - return (server, client) + server <- genServer + client <- + filter (not . flip any server . flip matches) + <$> listOf1 (genDiffMediaTypesWith genConcreteMediaType server) + return (server, client) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,21 +1,22 @@ ------------------------------------------------------------------------------- module Main (main) where ------------------------------------------------------------------------------- -import Test.Framework (defaultMain, testGroup) - ------------------------------------------------------------------------------- -import qualified Network.HTTP.Media.Accept.Tests as Accept -import qualified Network.HTTP.Media.Language.Tests as Language +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 - +import qualified Network.HTTP.Media.Tests as Media +import Test.Tasty (defaultMain, testGroup) ------------------------------------------------------------------------------- main :: IO () -main = defaultMain - [ testGroup "Accept" Accept.tests - , testGroup "Language" Language.tests - , testGroup "MediaType" MediaType.tests - , testGroup "Media" Media.tests - ] +main = + defaultMain $ + testGroup + "http-media" + [ testGroup "Accept" Accept.tests, + testGroup "Charset" Charset.tests, + testGroup "Encoding" Encoding.tests, + testGroup "Language" Language.tests, + testGroup "MediaType" MediaType.tests, + testGroup "Media" Media.tests + ]