http-media 0.2.0 → 0.8.1.1

raw patch · 31 files changed

Files

CHANGES.md +102/−0
LICENSE +17/−17
Setup.hs +0/−1
dist/build/test-http-mediaStub/test-http-mediaStub-tmp/test-http-mediaStub.hs +0/−5
http-media.cabal +79/−35
src/Network/HTTP/Media.hs +271/−133
src/Network/HTTP/Media/Accept.hs +37/−39
src/Network/HTTP/Media/Charset.hs +5/−0
src/Network/HTTP/Media/Charset/Internal.hs +49/−0
src/Network/HTTP/Media/Encoding.hs +5/−0
src/Network/HTTP/Media/Encoding/Internal.hs +52/−0
src/Network/HTTP/Media/Language.hs +16/−0
src/Network/HTTP/Media/Language/Internal.hs +67/−0
src/Network/HTTP/Media/MediaType.hs +45/−63
src/Network/HTTP/Media/MediaType/Internal.hs +69/−68
src/Network/HTTP/Media/Quality.hs +99/−38
src/Network/HTTP/Media/RenderHeader.hs +24/−0
src/Network/HTTP/Media/Utils.hs +58/−43
test/Network/HTTP/Media/Accept/Tests.hs +17/−33
test/Network/HTTP/Media/Charset/Gen.hs +37/−0
test/Network/HTTP/Media/Charset/Tests.hs +83/−0
test/Network/HTTP/Media/Encoding/Gen.hs +42/−0
test/Network/HTTP/Media/Encoding/Tests.hs +82/−0
test/Network/HTTP/Media/Gen.hs +61/−17
test/Network/HTTP/Media/Language/Gen.hs +84/−0
test/Network/HTTP/Media/Language/Tests.hs +92/−0
test/Network/HTTP/Media/MediaType/Gen.hs +98/−96
test/Network/HTTP/Media/MediaType/Tests.hs +149/−155
test/Network/HTTP/Media/Tests.hs +198/−161
test/Test.hs +22/−0
test/Tests.hs +0/−20

+ CHANGES.md view

@@ -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.

LICENSE view

@@ -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.

Setup.hs view

@@ -4,4 +4,3 @@  main :: IO () main = defaultMain-

− dist/build/test-http-mediaStub/test-http-mediaStub-tmp/test-http-mediaStub.hs

@@ -1,5 +0,0 @@-module Main ( main ) where-import Distribution.Simple.Test.LibV09 ( stubMain )-import Tests ( tests )-main :: IO ()-main = stubMain tests

http-media.cabal view

@@ -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 <git@zmthy.io>-homepage:      http://github.com/zmthy/http-media-bug-reports:   http://github.com/zmthy/http-media/issues+maintainer:    Timothy Jones <tim@zmthy.net>+homepage:      https://github.com/zmthy/http-media+bug-reports:   https://github.com/zmthy/http-media/issues+copyright:     (c) 2012-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

src/Network/HTTP/Media.hs view

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

src/Network/HTTP/Media/Accept.hs view

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

+ src/Network/HTTP/Media/Charset.hs view

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

+ src/Network/HTTP/Media/Charset/Internal.hs view

@@ -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+-- <https://tools.ietf.org/html/rfc7231#section-5.3.3 RFC7231>.+--+-- Specifically:+--+-- > charset = token / "*"+newtype Charset = Charset (CI ByteString)+  deriving (Eq, Ord)++instance Show Charset where+  show = BS.unpack . renderHeader++instance IsString Charset where+  fromString str =+    flip fromMaybe (parseAccept $ BS.pack str) $+      error $+        "Invalid encoding literal " ++ str++instance Accept Charset where+  parseAccept bs = do+    guard $ isValidToken bs+    return $ Charset (CI.mk bs)++  matches _ (Charset "*") = True+  matches a b = a == b++  moreSpecificThan _ (Charset "*") = True+  moreSpecificThan _ _ = False++instance RenderHeader Charset where+  renderHeader (Charset e) = original e

+ src/Network/HTTP/Media/Encoding.hs view

@@ -0,0 +1,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

+ src/Network/HTTP/Media/Encoding/Internal.hs view

@@ -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+-- <https://tools.ietf.org/html/rfc7231#section-5.3.4 RFC7231>.+--+-- Specifically:+--+-- > codings = content-coding / "identity" / "*"+newtype Encoding = Encoding (CI ByteString)+  deriving (Eq, Ord)++instance Show Encoding where+  show = BS.unpack . renderHeader++instance IsString Encoding where+  fromString str =+    flip fromMaybe (parseAccept $ BS.pack str) $+      error $+        "Invalid encoding literal " ++ str++instance Accept Encoding where+  -- This handles the case where the header value is empty, but it also+  -- allows technically invalid values such as "compress;q=0.8,;q=0.5".+  parseAccept "" = Just $ Encoding "identity"+  parseAccept bs = do+    guard $ isValidToken bs+    return $ Encoding (CI.mk bs)++  matches _ (Encoding "*") = True+  matches a b = a == b++  moreSpecificThan _ (Encoding "*") = True+  moreSpecificThan _ _ = False++instance RenderHeader Encoding where+  renderHeader (Encoding e) = original e

+ src/Network/HTTP/Media/Language.hs view

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

+ src/Network/HTTP/Media/Language/Internal.hs view

@@ -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+-- <https://tools.ietf.org/html/rfc4647#section-2.1 RFC4647>.+--+-- 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)

src/Network/HTTP/Media/MediaType.hs view

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

src/Network/HTTP/Media/MediaType/Internal.hs view

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

src/Network/HTTP/Media/Quality.hs view

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

+ src/Network/HTTP/Media/RenderHeader.hs view

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

src/Network/HTTP/Media/Utils.hs view

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

test/Network/HTTP/Media/Accept/Tests.hs view

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

+ test/Network/HTTP/Media/Charset/Gen.hs view

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

+ test/Network/HTTP/Media/Charset/Tests.hs view

@@ -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+    ]

+ test/Network/HTTP/Media/Encoding/Gen.hs view

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

+ test/Network/HTTP/Media/Encoding/Tests.hs view

@@ -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+    ]

test/Network/HTTP/Media/Gen.hs view

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

+ test/Network/HTTP/Media/Language/Gen.hs view

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

+ test/Network/HTTP/Media/Language/Tests.hs view

@@ -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+    ]

test/Network/HTTP/Media/MediaType/Gen.hs view

@@ -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 ";"

test/Network/HTTP/Media/MediaType/Tests.hs view

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

test/Network/HTTP/Media/Tests.hs view

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

+ test/Test.hs view

@@ -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+      ]

− test/Tests.hs

@@ -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-    ]-