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,20 +1,20 @@ -Copyright (c) 2012-2014 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: +Copyright (c) 2012-2015 Timothy Jones -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. +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 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 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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -4,4 +4,3 @@ main :: IO () main = defaultMain - diff --git a/dist/build/test-http-mediaStub/test-http-mediaStub-tmp/test-http-mediaStub.hs b/dist/build/test-http-mediaStub/test-http-mediaStub-tmp/test-http-mediaStub.hs deleted file mode 100644 --- a/dist/build/test-http-mediaStub/test-http-mediaStub-tmp/test-http-mediaStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import Tests ( tests ) -main :: IO () -main = stubMain tests diff --git a/http-media.cabal b/http-media.cabal --- a/http-media.cabal +++ b/http-media.cabal @@ -1,34 +1,44 @@ name: http-media -version: 0.2.0 +version: 0.8.1.1 license: MIT license-file: LICENSE author: Timothy Jones -maintainer: Timothy Jones -homepage: http://github.com/zmthy/http-media -bug-reports: http://github.com/zmthy/http-media/issues +maintainer: Timothy Jones +homepage: https://github.com/zmthy/http-media +bug-reports: https://github.com/zmthy/http-media/issues +copyright: (c) 2012-2023 Timothy Jones category: Web -copyright: (c) 2012-2014 Timothy Jones 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 media - types, including quality parameters, in HTTP headers. It addresses parsing of - the Content-Type and Accept headers, and includes general data types for - matching against the other accept headers as well. It encodes MIME parameters - into a 'MediaType' data, and allows the matching of the final value by - comparing quality values from the client. + 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. . - In the following example, the Accept header is parsed, and then matched - against a list of server options to serve the appropriate media: + 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 > [ ("text/html", asHtml) > , ("application/json", asJson) > ] . - Similarly, the Content-Type header can be used to produce a parser for request - bodies based on the given content type: + 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) @@ -37,64 +47,98 @@ . The API is agnostic to your choice of server. +extra-source-files: + CHANGES.md library - hs-source-dirs: src + default-language: Haskell2010 ghc-options: -Wall - default-language: Haskell2010 + hs-source-dirs: + src + default-extensions: OverloadedStrings 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.0 && < 5.0, - bytestring >= 0.10.0 && < 0.11, - containers >= 0.5.0 && < 0.6, - utf8-string >= 0.3.7 && < 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 test-suite test-http-media - type: detailed-0.9 - hs-source-dirs: src test + type: exitcode-stdio-1.0 + main-is: Test.hs default-language: Haskell2010 + + ghc-options: -Wall + + hs-source-dirs: + src + test + default-extensions: OverloadedStrings - test-module: Tests + other-extensions: + 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 + Network.HTTP.Media.Language.Tests Network.HTTP.Media.MediaType Network.HTTP.Media.MediaType.Gen Network.HTTP.Media.MediaType.Internal Network.HTTP.Media.MediaType.Tests Network.HTTP.Media.Quality + Network.HTTP.Media.RenderHeader Network.HTTP.Media.Tests Network.HTTP.Media.Utils - ghc-options: -Wall -fhpc - build-depends: - base >= 4.6.0 && < 5.0, - bytestring >= 0.10.0 && < 0.11, - Cabal >= 1.18.0 && < 1.21, - cabal-test-quickcheck >= 0.1.0 && < 0.2, - containers >= 0.5.0 && < 0.6, - QuickCheck >= 2.6 && < 2.9, - utf8-string >= 0.3.7 && < 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,55 +1,79 @@ ------------------------------------------------------------------------------- -- | 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, + -- * Accept matching - , matchAccept - , mapAccept - , mapAcceptMedia - , mapAcceptBytes + matchAccept, + mapAccept, + mapAcceptMedia, + mapAcceptCharset, + mapAcceptEncoding, + mapAcceptLanguage, + mapAcceptBytes, -- * Content matching - , matchContent - , mapContent - , mapContentMedia + 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 (..) - ) where - ------------------------------------------------------------------------------- -import qualified Data.ByteString as BS + Accept (..), ------------------------------------------------------------------------------- -import Control.Applicative (pure, (<$>), (<*>), (<|>)) -import Control.Monad (guard, (>=>)) -import Data.ByteString (ByteString, split) -import Data.ByteString.UTF8 (toString) + -- * Rendering + RenderHeader (..), + ) +where ------------------------------------------------------------------------------- -import Network.HTTP.Media.Accept as Accept +import Control.Applicative ((<|>)) +import Control.Monad (guard, (>=>)) +import Data.ByteString (ByteString) +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.Utils - +import Network.HTTP.Media.RenderHeader +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 @@ -63,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. @@ -80,16 +104,16 @@ -- > [ ("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, +-- | A specialisation of 'mapAccept' that only takes 'MediaType' as its input, -- to avoid ambiguous-type errors when using string literal overloading. -- -- > getHeader >>= maybe render406Error renderResource . mapAcceptMedia @@ -97,28 +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 ByteString as its input, +-- | A specialisation of 'mapAccept' that only takes 'Encoding' as its input, -- to avoid ambiguous-type errors when using string literal overloading. -- --- > getHeader >>= maybe render406Error encodeResourceWith . mapAcceptBytes +-- > getHeader >>= maybe render406Error renderResource . mapAcceptEncoding -- > [ ("compress", compress) --- > , ("gzip", gzip) +-- > , ("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 +-- > [ ("en-gb", inBritishEnglish) +-- > , ("fr", inFrench) +-- > ] +mapAcceptLanguage :: + -- | 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 +-- > [ ("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). @@ -126,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. -- @@ -146,42 +212,111 @@ -- > [ ("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. +-- | A specialisation of 'mapContent' that only takes 'MediaType' as its +-- input, to avoid ambiguous-type errors when using string literal +-- overloading. -- -- > getContentType >>= -- > maybe send415Error readRequestBodyWith . mapContentMedia -- > [ ("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. +-- +-- > getContentLanguage >>= +-- > maybe send415Error readRequestBodyWith . mapContentLanguage +-- > [ ("en-gb", parseBritishEnglish) +-- > , ("fr", parseFrench) +-- > ] +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 = (. split comma) . mapM $ \bs -> - let (accept, q) = BS.breakSubstring ";q=" $ BS.filter (/= space) bs - in (<*> parseAccept accept) $ if BS.null q - then pure maxQuality else flip Quality <$> readQ - (toString $ BS.takeWhile (/= semi) $ BS.drop 3 q) +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 + 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 + ) + + -- Trawl backwards through the string, ignoring extension parameters. + findQ s = do + 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 @@ -195,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. @@ -223,20 +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 ------------------------------------------------------------------------------- --- | 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 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 +-- | 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,54 +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 - ) where - ------------------------------------------------------------------------------- -import Data.ByteString -import Data.ByteString.UTF8 (toString) + ( 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 - -- | Specifies how to show an Accept-* header. Defaults to the standard - -- show method. - -- - -- Mostly useful just for avoiding quotes when rendering 'ByteString's - -- with accompanying quality. - showAccept :: a -> String - showAccept = show + -- | 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 - -- (order may be important). - 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. - 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 instance Accept ByteString where - parseAccept = Just - showAccept = toString - matches = (==) - 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 - + 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 new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Media/Language.hs @@ -0,0 +1,16 @@ +-- | Defines the 'Language' accept header with an 'Accept' instance for use in +-- language negotiation. +module Network.HTTP.Media.Language + ( Language, + toParts, + ) +where + +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] +toParts (Language l) = l diff --git a/src/Network/HTTP/Media/Language/Internal.hs b/src/Network/HTTP/Media/Language/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Media/Language/Internal.hs @@ -0,0 +1,67 @@ +-- | Defines the 'Language' accept header with an 'Accept' instance for use in +-- language negotiation. +module Network.HTTP.Media.Language.Internal + ( Language (..), + ) +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.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*8alphanum)) / "*" +newtype Language = Language [CI ByteString] + deriving (Eq, Ord) + +-- Note that internally, Language [] equates to *. + +instance Show Language where + show = BS.unpack . renderHeader + +instance IsString Language where + 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 + && 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 + + -- 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) 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,104 +1,86 @@ ------------------------------------------------------------------------------- --- | Defines the media type types and functions. +-- | 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 - , (//) - , (/:) - , toByteString + ( -- * Type and creation + MediaType, + Parameters, + (//), + (/:), -- * Querying - , mainType - , subType - , parameters - , (/?) - , (/.) - ) where - ------------------------------------------------------------------------------- -import qualified Data.ByteString as BS -import qualified Data.Map as Map + mainType, + subType, + parameters, + (/?), + (/.), + ) +where ------------------------------------------------------------------------------- import Data.ByteString (ByteString) -import Data.Map (empty, insert) -import Data.Word (Word8) - ------------------------------------------------------------------------------- -import qualified Network.HTTP.Media.MediaType.Internal as Internal - ------------------------------------------------------------------------------- +import qualified Data.ByteString.Char8 as BS +import Data.CaseInsensitive (CI) +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 -> ByteString +mainType :: MediaType -> CI ByteString mainType = Internal.mainType - ------------------------------------------------------------------------------- -- | Retrieves the sub type of a 'MediaType'. -subType :: MediaType -> ByteString +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 = MediaType (ensureR a) (ensureR b) empty - +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 ------------------------------------------------------------------------------- -- | Adds a parameter to a 'MediaType'. Can produce an error if either -- string is invalid. (/:) :: MediaType -> (ByteString, ByteString) -> MediaType (MediaType a b p) /: (k, v) = MediaType a b $ insert (ensureR k) (ensureV v) p - ------------------------------------------------------------------------------- -- | Evaluates if a 'MediaType' has a parameter of the given name. (/?) :: MediaType -> ByteString -> Bool -(MediaType _ _ p) /? k = Map.member k p - +(MediaType _ _ p) /? k = Map.member (CI.mk k) p ------------------------------------------------------------------------------- -- | Retrieves a parameter from a 'MediaType'. -(/.) :: MediaType -> ByteString -> Maybe ByteString -(MediaType _ _ p) /. k = Map.lookup k p - +(/.) :: 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 -> ByteString -ensureR bs = if l == 0 || l > 127 - then error $ "Invalid length for " ++ show bs else ensure isValidChar bs - where l = BS.length bs - +ensureR :: ByteString -> CI ByteString +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 -> ByteString -ensureV = ensure (`notElem` [44, 59]) - +ensureV :: ByteString -> CI ByteString +ensureV = CI.mk . ensure (`notElem` [',', ';']) ------------------------------------------------------------------------------- -- | Ensures the predicate matches for every character in the given string. -ensure :: (Word8 -> Bool) -> ByteString -> ByteString -ensure f bs = maybe - (error $ "Invalid character in " ++ show bs) (const bs) (BS.find f bs) - +ensure :: (Char -> Bool) -> ByteString -> ByteString +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 - , toByteString - ) where - ------------------------------------------------------------------------------- -import qualified Data.ByteString as BS -import qualified Data.ByteString.UTF8 as BS -import qualified Data.Map as Map - ------------------------------------------------------------------------------- -import Control.Monad (guard) -import Data.ByteString (ByteString) -import Data.ByteString.UTF8 (toString) -import Data.String (IsString (..)) -import Data.Map (Map) -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) + ( MediaType (..), + Parameters, + ) +where ------------------------------------------------------------------------------- +import Control.Monad (foldM, guard) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.CaseInsensitive (CI, original) +import qualified Data.CaseInsensitive as CI +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.String (IsString (..)) import Network.HTTP.Media.Accept (Accept (..)) -import Network.HTTP.Media.Utils - +import Network.HTTP.Media.RenderHeader (RenderHeader (..)) +import Network.HTTP.Media.Utils (breakChar, trimBS) +import Prelude hiding ((<>)) ------------------------------------------------------------------------------- -- | An HTTP media type, consisting of the type, subtype, and parameters. data MediaType = MediaType - { mainType :: ByteString -- ^ The main type of the MediaType - , subType :: ByteString -- ^ The sub type of the MediaType - , parameters :: Parameters -- ^ The parameters of the MediaType - } deriving (Eq) + { -- | 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 (MediaType a b p) = - Map.foldrWithKey f (toString a ++ '/' : toString b) p - where - f k v = (++ ';' : toString k ++ '=' : toString v) + show = BS.unpack . renderHeader instance IsString MediaType where - fromString str = flip fromMaybe (parseAccept $ BS.fromString 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 - let pieces = BS.split semi bs - guard $ not (null pieces) - let (m : ps) = pieces - (a, b) = breakByte slash m - guard $ BS.elem slash m && (a /= "*" || b == "*") - return $ MediaType a b $ - foldr (uncurry Map.insert . breakByte equal) Map.empty ps - - 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) + 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 ------------------------------------------------------------------------------- --- | 'MediaType' parameters. -type Parameters = Map ByteString ByteString + 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 ------------------------------------------------------------------------------- --- | Converts 'MediaType' to 'ByteString'. -toByteString :: MediaType -> ByteString -toByteString (MediaType a b p) = Map.foldrWithKey f (a <> "/" <> b) p - where - f k v = (<> ";" <> k <> "=" <> v) +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) +-- | '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,61 +1,122 @@ ------------------------------------------------------------------------------- +{-# LANGUAGE DeriveFunctor #-} + -- | Defines the quality value data type. module Network.HTTP.Media.Quality - ( Quality (..) - , maxQuality - , minQuality - , readQ - ) where - ------------------------------------------------------------------------------- -import Data.Maybe (listToMaybe) -import Data.Word (Word16) + ( Quality (..), + quality, + QualityOrder, + qualityOrder, + isAcceptable, + maxQuality, + minQuality, + mostSpecific, + showQ, + readQ, + ) +where ------------------------------------------------------------------------------- -import Network.HTTP.Media.Accept +import Data.ByteString (ByteString) +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) + { qualityData :: a, + qualityValue :: Word16 + } + deriving (Eq, Functor, Ord) -instance Accept a => Show (Quality a) where - show (Quality a q) = showAccept a ++ ";q=" ++ showQ q +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 ------------------------------------------------------------------------------- +-- | 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 -> String +showQ :: Word16 -> ByteString showQ 1000 = "1" -showQ 0 = "0" -showQ q = '0' : '.' : let s = show q in replicate (3 - length s) '0' ++ s - +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 :: String -> Maybe Word16 -readQ "1" = Just 1000 -readQ "0" = Just 0 -readQ ('1' : '.' : t) - | length t <= 3 && all (== '0') t = Just 1000 - | otherwise = Nothing -readQ ('0' : '.' : t) - | length t <= 3 = fmap fst . listToMaybe . filter (null . snd) . reads $ - t ++ replicate (3 - length t) '0' - | otherwise = Nothing -readQ _ = Nothing +readQ :: ByteString -> Maybe Word16 +readQ bs + | 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 + 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 + where + h = BS.head bs + t = BS.tail bs + toWord = read . BS.unpack diff --git a/src/Network/HTTP/Media/RenderHeader.hs b/src/Network/HTTP/Media/RenderHeader.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Media/RenderHeader.hs @@ -0,0 +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 + +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 + +instance RenderHeader ByteString where + renderHeader = id + +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,59 +1,74 @@ ------------------------------------------------------------------------------ -- | Common utilities. module Network.HTTP.Media.Utils - ( breakByte - , trimBS - - , validChars - , isValidChar - - , slash - , semi - , comma - , space - , equal - ) where - ------------------------------------------------------------------------------- -import qualified Data.ByteString as BS + ( breakChar, + trimBS, + mediaChars, + isMediaChar, + tokenChars, + isTokenChar, + isValidToken, + ) +where ------------------------------------------------------------------------------- import Data.ByteString (ByteString) -import Data.Word (Word8) - - ------------------------------------------------------------------------------- --- | Equivalent to 'Data.ByteString.breakByte', but leaves out the byte the --- string is broken on. -breakByte :: Word8 -> ByteString -> (ByteString, ByteString) -breakByte w = fmap BS.tail . BS.breakByte w +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) ------------------------------------------------------------------------------- --- | Trims space characters from both ends of a ByteString. +-- | Trims tab and space characters from both ends of a ByteString. trimBS :: ByteString -> ByteString -trimBS = BS.reverse . dropSpace . BS.reverse . dropSpace +trimBS = fst . BS.spanEnd isLWS . BS.dropWhile isLWS where - dropSpace = BS.dropWhile (== space) - + isLWS c = c == ' ' || c == '\t' ------------------------------------------------------------------------------- -- | List of the valid characters for a media-type `reg-name` as per RFC 4288. -validChars :: [Word8] -validChars = - [33, 35, 36, 37, 43, 45, 46, 94, 95] ++ [48..57] ++ [65..90] ++ [97..122] - +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 :: Word8 -> Bool -isValidChar c = c >= 97 && c <= 122 || c >= 48 && c <= 57 || - c >= 65 && c <= 90 || c `elem` [33, 35, 36, 37, 43, 45, 46, 94, 95] +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 = + [ '(', + ')', + '<', + '>', + '@', + ',', + ';', + ':', + '\\', + '"', + '/', + '[', + ']', + '?', + '=', + '{', + '}', + ' ' + ] ------------------------------------------------------------------------------- --- | 'ByteString' compatible characters. -slash, semi, comma, space, equal :: Word8 -[slash, semi, comma, space, equal] = [47, 59, 44, 32, 61] +-- | 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,48 +1,32 @@ ------------------------------------------------------------------------------- module Network.HTTP.Media.Accept.Tests (tests) where ------------------------------------------------------------------------------- -import Control.Monad (join, liftM, liftM2) -import Distribution.TestSuite.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" $ - join (liftM2 ((not .) . moreSpecificThan)) genByteString - - ------------------------------------------------------------------------------- -testMostSpecific :: Test -testMostSpecific = testProperty "mostSpecific" $ do - string <- genByteString - liftM ((== string) . mostSpecific string) genByteString - +testMoreSpecificThan :: TestTree +testMoreSpecificThan = + testProperty "moreSpecificThan" $ + (not .) . moreSpecificThan <$> genByteString <*> 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,28 +1,72 @@ ------------------------------------------------------------------------------- -- | Contains definitions for generating 'ByteString's. module Network.HTTP.Media.Gen - ( genByteString - , genDiffByteString - ) where + ( genToken, + genByteStringFrom, + genCIByteStringFrom, + genByteString, + genCIByteString, + genDiffWith, + genDiffByteString, + genDiffCIByteString, + padString, + ) +where ------------------------------------------------------------------------------- -import Control.Monad (liftM) -import Data.ByteString (ByteString, pack) -import Test.QuickCheck.Gen (Gen, listOf1, oneof) +import Control.Monad (join, liftM2) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.CaseInsensitive (CI, original) +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 ByteString of random alpha characters. +-- | Produces a non-empty ByteString of random characters from the given set. +genByteStringFrom :: String -> Gen ByteString +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 with a +-- non-numeric head. genByteString :: Gen ByteString -genByteString = liftM pack $ listOf1 (oneof $ map return validChars) +genByteString = + fmap BS.pack . (:) + <$> Gen.elements alpha + <*> Gen.scale (max 0 . pred) (Gen.listOf (Gen.elements alphaNum)) where - validChars = [48..57] ++ [65..90] ++ [97..122] + 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 random ByteString different to the given one. +-- | Produces a non-empty ByteString different to the given one using the +-- given generator. +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 bs = do - bs' <- genByteString - if bs == bs' then genDiffByteString bs else return bs' +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 <$> 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 new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Media/Language/Gen.hs @@ -0,0 +1,84 @@ +{-# 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 + +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI) +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 + +-- | Generate a Language that has the given language as a prefix. +genMatchingLanguage :: Language -> Gen Language +genMatchingLanguage (Language pre) = + 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 + +-- | Generate a Language that does not have the given language as a prefix. +genNonMatchingLanguage :: Language -> Gen Language +genNonMatchingLanguage (Language []) = genConcreteLanguage +genNonMatchingLanguage (Language (pre : _)) = do + 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 + +-- | 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 + +genCIByteString :: Gen (CI ByteString) +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 new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Media/Language/Tests.hs @@ -0,0 +1,92 @@ +module Network.HTTP.Media.Language.Tests (tests) where + +import Control.Monad (join) +import qualified Data.ByteString.Char8 as BS +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 :: [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 + lang <- genLanguage + return $ lang === lang, + testProperty "/=" $ do + lang <- genLanguage + lang' <- genDiffLanguage lang + return $ lang /= lang' + ] + +testShow :: TestTree +testShow = testProperty "show" $ do + lang <- genLanguage + return $ parseAccept (BS.pack $ show lang) === Just lang + +testFromString :: TestTree +testFromString = testProperty "fromString" $ do + lang <- genLanguage + return $ lang === fromString (show lang) + +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 *" $ + not . matches anything <$> genConcreteLanguage + ] + +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" $ + not . uncurry moreSpecificThan <$> genNonMatchingLanguages + ] + +testParseAccept :: TestTree +testParseAccept = + testGroup + "parseAccept" + [ testProperty "Valid parse" $ do + lang <- genLanguage + 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,174 +1,176 @@ ------------------------------------------------------------------------------- -- | Contains definitions for generating 'MediaType's. module Network.HTTP.Media.MediaType.Gen - ( - -- * Generating ByteStrings - genByteString - , genDiffByteString - - -- * Generating MediaTypes - , anything - , genMediaType - , genSubStar - , genMaybeSubStar - , subStarOf - , genConcreteMediaType - , genWithoutParams - , genWithParams - , stripParams - , genDiffMediaTypesWith - , genDiffMediaTypeWith - , genDiffMediaTypes - , genDiffMediaType + ( -- * Generating MediaTypes + anything, + genMediaType, + genSubStar, + genMaybeSubStar, + subStarOf, + genConcreteMediaType, + genWithoutParams, + genWithParams, + stripParams, + genDiffMediaTypesWith, + genDiffMediaTypeWith, + genDiffMediaTypes, + genDiffMediaType, + genMatchingPair, -- * Generating Parameters - , genParameters - , genMaybeParameters - , genDiffParameters - ) where - ------------------------------------------------------------------------------- -import qualified Data.Map as Map + genParameters, + genMaybeParameters, + genDiffParameters, ------------------------------------------------------------------------------- -import Control.Monad (liftM, liftM2) -import Data.ByteString (ByteString) -import Data.Map (fromList) -import Test.QuickCheck.Gen + -- * Rendering Parameters + renderParameters, + ) +where ------------------------------------------------------------------------------- +import Control.Monad (filterM, liftM2) +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI, original) +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 = (ByteString, ByteString) - +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 <- genByteString - 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 <- genByteString - sub <- genByteString - 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 <- genByteString - sub <- genByteString - 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 <- genByteString - sub <- genByteString - 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 (,) (genDiffByteString "q") genByteString) - +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 +-- a preceding 'MediaType' rendering. +renderParameters :: Parameters -> Gen ByteString +renderParameters params = foldlM pad "" (Map.toList params) + where + pad s (k, v) = + (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,204 +1,198 @@ ------------------------------------------------------------------------------- module Network.HTTP.Media.MediaType.Tests (tests) where ------------------------------------------------------------------------------- -import qualified Data.ByteString.UTF8 as BS -import qualified Data.Map as Map - ------------------------------------------------------------------------------- -import Control.Monad (join, liftM) -import Data.String (fromString) -import Data.Maybe (isNothing) -import Data.Monoid ((<>), mconcat) -import Distribution.TestSuite.QuickCheck - ------------------------------------------------------------------------------- +import Control.Monad (join) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +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.MediaType ((/?), (/.)) -import Network.HTTP.Media.MediaType.Internal +import Network.HTTP.Media.Gen +import Network.HTTP.Media.MediaType ((/.), (/?)) import Network.HTTP.Media.MediaType.Gen - +import Network.HTTP.Media.MediaType.Internal +import Network.HTTP.Media.RenderHeader (renderHeader) +import 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.fromString $ 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 /?) (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 /?)) + 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 - let is n v = (&& media /. n == Just v) - return $ Map.foldrWithKey is True $ parameters media - , testProperty "Nothing for property it doesn't have" $ do media <- genWithParams - let is n _ = (&& isNothing (stripParams media /. n)) - return $ Map.foldrWithKey is True $ parameters media + 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 + 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 <- genDiffByteString $ mainType media - return $ not (matches media media { mainType = main }) && - not (matches media { mainType = main } media) - , testProperty "Same main but different sub don't match" $ do + 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 <- genDiffByteString $ subType media - return . not $ matches media media { subType = sub } || - matches media { subType = sub } media - , testProperty "Different parameters don't match" $ - liftM (not . dotJoin matches stripParams) genWithParams - , testProperty "Missing parameters match" $ do + 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 "isMoreSpecific" +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 } + 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'' +testParseAccept :: TestTree +testParseAccept = + testGroup + "parseAccept" + [ testProperty "Valid parse" $ do + media <- genMediaType + let main = mainType media + sub = subType media + params <- renderParameters (parameters media) + let parsed = parseAccept $ foldedCase (main <> "/" <> sub) <> params + return $ parsed === Just media, + testProperty "No sub" $ do + bs <- genByteString + 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 + sep <- padString "/" + 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 + eq <- padString "=" + (=== Nothing) <$> genMediaNameAndParams eq ] - ------------------------------------------------------------------------------- -testParseAccept :: Test -testParseAccept = testProperty "parseAccept" $ do - media <- genMediaType - let main = mainType media - sub = subType media - params = parameters media - let (Just parsed) = parseAccept $ main <> "/" <> sub <> mconcat - (map (uncurry ((<>) . (<> "=") . (";" <>))) $ Map.toList params) - return $ parsed == media - +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) ------------------------------------------------------------------------------- -- | 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,208 +1,245 @@ ------------------------------------------------------------------------------- -module Network.HTTP.Media.Tests (tests) where +{-# LANGUAGE TupleSections #-} ------------------------------------------------------------------------------- -import Control.Monad (replicateM) -import Data.ByteString (ByteString) -import Data.ByteString.UTF8 (fromString) -import Data.List (intercalate) -import Data.Map (empty) -import Data.Maybe (isNothing, listToMaybe) -import Data.Word (Word16) -import Distribution.TestSuite.QuickCheck -import Test.QuickCheck +module Network.HTTP.Media.Tests (tests) where ------------------------------------------------------------------------------- -import Network.HTTP.Media hiding (parameters, subType) +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 - return $ - parseQuality (group media) == Just (map maxQuality media) - , testProperty "With quality" $ do - media <- medias >>= mapM (flip fmap (choose (0, 1000)) . Quality) - return $ parseQuality (group media) == Just media + rendered <- padConcat (return . renderHeader) media + 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 + rendered <- padConcat (padQuality >=> padExtensions) media + return $ parseQuality rendered === Just media ] where medias = listOf1 genMediaType - group media = fromString $ intercalate "," (map show media) - - ------------------------------------------------------------------------------- -testMatchAccept :: Test -testMatchAccept = testMatch "Accept" matchAccept qToBS - + qualities = medias >>= mapM (flip fmap (choose (0, 1000)) . Quality) + 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 + padExtensions s = genParameters >>= fmap (s <>) . renderParameters + pad a s b = a <> s <> b ------------------------------------------------------------------------------- -testMapAccept :: Test -testMapAccept = testMap "Accept" mapAccept qToBS +testMatchAccept :: TestTree +testMatchAccept = testMatch "Accept" matchAccept renderHeader +testMapAccept :: TestTree +testMapAccept = testMap "Accept" mapAccept renderHeader ------------------------------------------------------------------------------- -testMatchContent :: Test -testMatchContent = testGroup "matchContent" - [ testProperty "Most specific" $ do - media <- genConcreteMediaType - let client = toBS - [ MediaType "*" "*" empty - , media { subType = "*" } - , media { parameters = empty } - , media - ] - return $ matchAccept [media] client == Just media - , testProperty "Nothing" $ do - (server, client) <- genServerAndClient - let client' = filter (not . flip any server . matches) client - return . isNothing $ matchAccept server (toBS client') - , testProperty "Left biased" $ do - server <- genServer - return $ matchAccept server (toBS server) == Just (head server) - , testProperty "Against */*" $ do - server <- genServer - let stars = "*/*" :: ByteString - return $ matchAccept server (toBS [stars]) == Just (head server) - , testProperty "Against type/*" $ do - server <- genServer - let client = toBS [subStarOf $ head server] - return $ matchAccept server client == Just (head server) +testMatchContent :: TestTree +testMatchContent = + testGroup + "matchContent" + [ testProperty "Matches" $ do + media <- genMediaType + 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 + media <- genMediaType + return $ + 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 - server <- genServer - let zipped = zip server server - return $ mapAccept zipped (toBS server) == listToMaybe server - , testProperty "Nothing" $ do - server <- genServer - client <- listOf1 $ genDiffMediaTypesWith genConcreteMediaType server - let zipped = zip server $ repeat () - return . isNothing $ mapAccept zipped (toBS client) + media <- genMediaType + 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, + 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) -> + 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 + client <- listOf1 genConcreteMediaType + server <- filter (not . flip any client . matches) <$> 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 <- genNubServer + let stars = "*/*" :: MediaType + 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), + testQuality match qToI + ] ------------------------------------------------------------------------------- -testMatch - :: String - -> ([MediaType] -> a -> Maybe MediaType) - -> ([Quality MediaType] -> a) - -> Test -testMatch name match qToI = testGroup ("match" ++ name) +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) + 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 - media <- genConcreteMediaType - let client = qToI $ map maxQuality - [ MediaType "*" "*" empty - , media { subType = "*" } - , media { parameters = empty } - , media - ] - return $ match [media] client == Just media - , testProperty "Nothing" $ do - server <- genServer - client <- listOf1 $ genDiffMediaTypesWith genConcreteMediaType server - let client' = filter (not . flip any server . matches) client - return . isNothing $ match server - (qToI $ map maxQuality client') - , testProperty "Never chooses q=0" $ do - server <- genServer - return . isNothing $ - match server (qToI $ map minQuality server) - , testProperty "Left biased" $ do - server <- genServer - let client = qToI $ map maxQuality server - return $ match server client == Just (head server) - , testProperty "Against */*" $ do - server <- genServer - let stars = "*/*" :: MediaType - return $ match server (qToI [maxQuality stars]) == - Just (head server) - , testProperty "Against type/*" $ do - server <- genServer - let client = qToI [maxQuality (subStarOf $ head server)] - return $ match server client == Just (head server) + return $ + match server (qToI client) + === Just (qualityData $ foldr1 qmax client), + testProperty "Most specific quality" $ do + (a, b) <- genMatchingPair + c <- genDiffMediaType a + let client = qToI [quality a "0.5", maxQuality b, maxQuality c] + return $ match [a, c] client === Just c, + testQ0 match qToI ] +testQ0 :: + ([MediaType] -> a -> Maybe MediaType) -> + ([Quality MediaType] -> a) -> + 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) - -> Test -testMap name mapf qToI = testGroup ("map" ++ name) +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 "*/*" - return . isNothing $ mapf zipped (qToI $ map maxQuality client) + 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 <- listOf1 $ genDiffMediaTypesWith genConcreteMediaType server - return (server, client) - - ------------------------------------------------------------------------------- -toBS :: Accept a => [a] -> ByteString -toBS = fromString . intercalate "," . map showAccept - - ------------------------------------------------------------------------------- -qToBS :: Accept a => [Quality a] -> ByteString -qToBS = fromString . intercalate "," . map show - + 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 new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,22 @@ +module Main (main) where + +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 Test.Tasty (defaultMain, testGroup) + +main :: IO () +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 + ] diff --git a/test/Tests.hs b/test/Tests.hs deleted file mode 100644 --- a/test/Tests.hs +++ /dev/null @@ -1,20 +0,0 @@ ------------------------------------------------------------------------------- -module Tests (tests) where - ------------------------------------------------------------------------------- -import Distribution.TestSuite - ------------------------------------------------------------------------------- -import qualified Network.HTTP.Media.Tests as Media -import qualified Network.HTTP.Media.Accept.Tests as Accept -import qualified Network.HTTP.Media.MediaType.Tests as MediaType - - ------------------------------------------------------------------------------- -tests :: IO [Test] -tests = return - [ testGroup "MediaType" MediaType.tests - , testGroup "Accept" Accept.tests - , testGroup "Media" Media.tests - ] -