http-media 0.8.1.0 → 0.8.1.1

raw patch · 27 files changed

+1149/−1349 lines, 27 filesdep ~QuickCheckdep ~bytestringdep ~containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: QuickCheck, bytestring, containers

API changes (from Hackage documentation)

Files

• CHANGES.md +8/−1
• http-media.cabal +3/−4
• src/Network/HTTP/Media.hs +190/−193
• src/Network/HTTP/Media/Accept.hs +36/−40
• src/Network/HTTP/Media/Charset.hs +2/−4
• src/Network/HTTP/Media/Charset/Internal.hs +27/−29
• src/Network/HTTP/Media/Encoding.hs +2/−4
• src/Network/HTTP/Media/Encoding/Internal.hs +30/−32
• src/Network/HTTP/Media/Language.hs +7/−10
• src/Network/HTTP/Media/Language/Internal.hs +43/−43
• src/Network/HTTP/Media/MediaType.hs +36/−53
• src/Network/HTTP/Media/MediaType/Internal.hs +67/−63
• src/Network/HTTP/Media/Quality.hs +53/−69
• src/Network/HTTP/Media/RenderHeader.hs +9/−12
• src/Network/HTTP/Media/Utils.hs +35/−35
• test/Network/HTTP/Media/Accept/Tests.hs +15/−20
• test/Network/HTTP/Media/Charset/Gen.hs +12/−24
• test/Network/HTTP/Media/Charset/Tests.hs +48/−57
• test/Network/HTTP/Media/Encoding/Gen.hs +13/−26
• test/Network/HTTP/Media/Encoding/Tests.hs +47/−56
• test/Network/HTTP/Media/Gen.hs +27/−46
• test/Network/HTTP/Media/Language/Gen.hs +28/−57
• test/Network/HTTP/Media/Language/Tests.hs +57/−65
• test/Network/HTTP/Media/MediaType/Gen.hs +74/−116
• test/Network/HTTP/Media/MediaType/Tests.hs +124/−128
• test/Network/HTTP/Media/Tests.hs +139/−144
• test/Test.hs +17/−18

@@ -1,7 +1,14 @@ Changelog ========= -- [ Version 0.8.1.0](https://github.com/zmthy/http-media/releases/tag/v0.8.1.0)+- [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. 

@@ -1,5 +1,5 @@ name:          http-media-version:       0.8.1.0+version:       0.8.1.1 license:       MIT license-file:  LICENSE author:        Timothy Jones@@ -11,8 +11,7 @@ build-type:    Simple cabal-version: >= 1.10 tested-with:-    GHC == 8.4.4-  , GHC == 8.6.5+    GHC == 8.6.5   , GHC == 8.8.4   , GHC == 8.10.7   , GHC == 9.0.2@@ -137,7 +136,7 @@     containers       >= 0.5  && < 0.7,     utf8-string      >= 0.3  && < 1.1,     QuickCheck       >= 2.8  && < 2.15,-    tasty            >= 0.11 && < 1.5,+    tasty            >= 0.11 && < 1.6,     tasty-quickcheck >= 0.8  && < 0.11  source-repository head

@@ -1,85 +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+    Charset,      -- * Encodings-    , Encoding+    Encoding,      -- * Languages-    , Language-    , toParts+    Language,+    toParts,      -- * Accept matching-    , matchAccept-    , mapAccept-    , mapAcceptMedia-    , mapAcceptCharset-    , mapAcceptEncoding-    , mapAcceptLanguage-    , mapAcceptBytes+    matchAccept,+    mapAccept,+    mapAcceptMedia,+    mapAcceptCharset,+    mapAcceptEncoding,+    mapAcceptLanguage,+    mapAcceptBytes,      -- * Content matching-    , matchContent-    , mapContent-    , mapContentMedia-    , mapContentCharset-    , mapContentEncoding-    , mapContentLanguage+    matchContent,+    mapContent,+    mapContentMedia,+    mapContentCharset,+    mapContentEncoding,+    mapContentLanguage,      -- * Quality values-    , Quality (qualityData)-    , quality-    , QualityOrder-    , qualityOrder-    , isAcceptable-    , maxQuality-    , minQuality-    , parseQuality-    , matchQuality-    , mapQuality+    Quality (qualityData),+    quality,+    QualityOrder,+    qualityOrder,+    isAcceptable,+    maxQuality,+    minQuality,+    parseQuality,+    matchQuality,+    mapQuality,      -- * Accept-    , Accept (..)+    Accept (..),      -- * Rendering-    , RenderHeader (..)-    ) where--import           Control.Applicative             ((<|>))--import qualified Data.ByteString.Char8           as BS--import           Control.Monad                   (guard, (>=>))-import           Data.ByteString                 (ByteString)-import           Data.Foldable                   (foldl', maximumBy)-import           Data.Function                   (on)-import           Data.Maybe                      (fromMaybe)-import           Data.Proxy                      (Proxy (Proxy))--import           Network.HTTP.Media.Accept       as Accept-import           Network.HTTP.Media.Charset      as Charset-import           Network.HTTP.Media.Encoding     as Encoding-import           Network.HTTP.Media.Language     as Language-import           Network.HTTP.Media.MediaType    as MediaType-import           Network.HTTP.Media.Quality-import           Network.HTTP.Media.RenderHeader-import           Network.HTTP.Media.Utils        (trimBS)+    RenderHeader (..),+  )+where +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.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@@ -93,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.@@ -110,15 +104,15 @@ -- >     [ ("text" // "html",        asHtml) -- >     , ("application" // "json", asJson) -- >     ]-mapAccept-    :: Accept a-    => [(a, b)]    -- ^ The map of server-side preferences to values-    -> ByteString  -- ^ The client-side header value-    -> Maybe b+mapAccept ::+  (Accept a) =>+  -- | The map of server-side preferences to values+  [(a, b)] ->+  -- | The client-side header value+  ByteString ->+  Maybe b mapAccept = (parseQuality >=>) . mapQuality -------------------------------------------------------------------------------- -- | A specialisation of 'mapAccept' that only takes 'MediaType' as its input, -- to avoid ambiguous-type errors when using string literal overloading. --@@ -127,13 +121,13 @@ -- >     , ("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. --@@ -142,13 +136,13 @@ -- >     , ("us-ascii", inAscii) -- >     ] mapAcceptCharset ::-    [(Charset, 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+  [(Charset, b)] ->+  -- | The client-side header value+  ByteString ->+  Maybe b mapAcceptCharset = mapAccept -------------------------------------------------------------------------------- -- | A specialisation of 'mapAccept' that only takes 'Encoding' as its input, -- to avoid ambiguous-type errors when using string literal overloading. --@@ -157,13 +151,13 @@ -- >     , ("identity", id) -- >     ] mapAcceptEncoding ::-    [(Encoding, 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+  [(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. --@@ -172,13 +166,13 @@ -- >     , ("fr",    inFrench) -- >     ] mapAcceptLanguage ::-    [(Language, b)]  -- ^ The map of server-side preferences to values-    -> ByteString    -- ^ The client-side header value-    -> Maybe b+  -- | The map of server-side preferences to values+  [(Language, b)] ->+  -- | The client-side header value+  ByteString ->+  Maybe b mapAcceptLanguage = mapAccept -------------------------------------------------------------------------------- -- | A specialisation of 'mapAccept' that only takes 'ByteString' as its -- input, to avoid ambiguous-type errors when using string literal -- overloading.@@ -188,13 +182,13 @@ -- >     , ("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).@@ -202,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. --@@ -222,16 +212,15 @@ -- >     [ ("application" // "json", parseJson) -- >     , ("text" // "plain",       parseText) -- >     ]-mapContent-    :: Accept a-    => [(a, b)]    -- ^ The map of server-side responses-    -> ByteString  -- ^ The client request's header value-    -> Maybe b-mapContent options ctype =-    matchContent (map fst options) ctype >>= lookupMatches options-+mapContent ::+  (Accept a) =>+  -- | The map of server-side responses+  [(a, b)] ->+  -- | The client request's header value+  ByteString ->+  Maybe b+mapContent options = fmap snd . findMatch fst options ------------------------------------------------------------------------------- -- | A specialisation of 'mapContent' that only takes 'MediaType' as its -- input, to avoid ambiguous-type errors when using string literal -- overloading.@@ -241,14 +230,14 @@ -- >         [ ("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. --@@ -257,14 +246,14 @@ -- >         [ ("utf-8",    parseUtf8) -- >         , ("us-ascii", parseAscii) -- >         ]-mapContentCharset-    :: [(Charset, b)]  -- ^ The map of server-side responses-    -> ByteString      -- ^ The client request's header value-    -> Maybe b+mapContentCharset ::+  -- | 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. --@@ -273,14 +262,14 @@ -- >         [ ("compress", decompress) -- >         , ("identity", id) -- >         ]-mapContentEncoding-    :: [(Encoding, b)]  -- ^ The map of server-side responses-    -> ByteString       -- ^ The client request's header value-    -> Maybe b+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. --@@ -289,41 +278,45 @@ -- >         [ ("en-gb", parseBritishEnglish) -- >         , ("fr",    parseFrench) -- >         ]-mapContentLanguage-    :: [(Language, b)]  -- ^ The map of server-side responses-    -> ByteString       -- ^ The client request's header value-    -> Maybe b+mapContentLanguage ::+  -- | The map of server-side responses+  [(Language, b)] ->+  -- | The client request's header value+  ByteString ->+  Maybe b mapContentLanguage = mapContent -------------------------------------------------------------------------------- -- | Parses a full Accept header into a list of quality-valued media types.-parseQuality :: Accept a => ByteString -> Maybe [Quality a]+parseQuality :: (Accept a) => ByteString -> Maybe [Quality a] parseQuality = parseQuality' Proxy -parseQuality' :: Accept a => Proxy a -> ByteString -> Maybe [Quality a]-parseQuality' p = (. map trimBS . BS.split ',') . mapM $ \ s ->-    let (accept, q) = fromMaybe (s, Nothing) $ if ext then findQ s else getQ s-    in maybe (pure maxQuality) (fmap (flip Quality) . readQ) q <*>-        parseAccept accept+parseQuality' :: (Accept a) => Proxy a -> ByteString -> Maybe [Quality a]+parseQuality' p = (. map trimBS . BS.split ',') . mapM $ \s ->+  let (accept, q) = fromMaybe (s, Nothing) $ if ext then findQ s else getQ s+   in maybe (pure maxQuality) (fmap (flip Quality) . readQ) q+        <*> parseAccept accept   where     ext = hasExtensionParameters p      -- Split on ';', and check if a quality value is there. A value of Nothing     -- indicates there was no parameter, whereas a value of Nothing in the     -- pair indicates the parameter was not a quality value.-    getQ s = let (a, b) = trimBS <$> BS.breakEnd (== ';') s in-        if BS.null a then Nothing else Just (BS.init a,-            if BS.isPrefixOf "q=" b then Just (BS.drop 2 b) else Nothing)+    getQ s =+      let (a, b) = trimBS <$> BS.breakEnd (== ';') s+       in if BS.null a+            then Nothing+            else+              Just+                ( BS.init a,+                  if BS.isPrefixOf "q=" b then Just (BS.drop 2 b) else Nothing+                )      -- Trawl backwards through the string, ignoring extension parameters.     findQ s = do-        let q = getQ s-        (a, m) <- q-        maybe (findQ a) (const q) m-+      let q = getQ s+      (a, m) <- q+      maybe (findQ a) (const q) m ------------------------------------------------------------------------------- -- | Matches a list of server-side resource options against a pre-parsed -- quality-marked list of client-side preferences. A result of 'Nothing' means -- that nothing matched (which should indicate a 406 error). If two or more@@ -337,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-    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-        | opt `matches` qualityData q = mostSpecific q <$> cur <|> Just q-        | otherwise                   = cur-+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.@@ -365,19 +347,34 @@ -- >     [ ("text" // "html",        asHtml) -- >     , ("application" // "json", asJson) -- >     ]-mapQuality-    :: Accept a-    => [(a, b)]     -- ^ The map of server-side preferences to values-    -> [Quality a]  -- ^ The client-side header value-    -> Maybe b-mapQuality options accept =-    matchQuality (map fst options) accept >>= lookupMatches options+mapQuality ::+  (Accept a) =>+  -- | The map of server-side preferences to values+  [(a, b)] ->+  -- | The client-side header value+  [Quality a] ->+  Maybe b+mapQuality options = fmap snd . findQuality fst options +-- | Find a match in a list of options against a ByteString using an 'Accept'+-- instance obtained by mapping the options to another type.+findMatch :: (Accept b) => (a -> b) -> [a] -> ByteString -> Maybe a+findMatch f options bs = do+  ctype <- parseAccept bs+  find (matches ctype . f) options ---------------------------------------------------------------------------------- | The equivalent of 'lookupBy matches'.-lookupMatches :: Accept a => [(a, b)] -> a -> Maybe b-lookupMatches ((k, v) : r) a-    | Accept.matches k a = Just v-    | otherwise         = lookupMatches r a-lookupMatches [] _ = Nothing+-- | Find a quality match between a list of options and a quality-marked list+-- of a different type, by mapping the type of the former to the latter.+findQuality :: (Accept a) => (b -> a) -> [b] -> [Quality a] -> Maybe b+findQuality f options acceptq = do+  guard $ not (null options)+  q <- maximumBy (compare `on` fmap qualityOrder) optionsq+  guard $ isAcceptable q+  return $ qualityData q+  where+    optionsq = reverse $ map addQuality options+    addQuality opt = withQValue opt <$> foldl' (mfold opt) Nothing acceptq+    withQValue opt q = q {qualityData = opt}+    mfold opt cur q+      | f opt `matches` qualityData q = mostSpecific q <$> cur <|> Just q+      | otherwise = cur

@@ -1,56 +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 (..)-    ) where+  ( Accept (..),+  )+where +import Data.ByteString (ByteString) import qualified Data.CaseInsensitive as CI--import           Data.ByteString      (ByteString)-import           Data.Proxy           (Proxy)-+import Data.Proxy (Proxy) ------------------------------------------------------------------------------- -- | Defines methods for a type whose values can be matched against each -- other in terms of an HTTP Accept-* header. -- -- This allows functions to work on both the standard Accept header and -- others such as Accept-Language that still may use quality values.-class Show a => Accept a where--    -- | Specifies how to parse an Accept-* header after quality has been-    -- handled.-    parseAccept :: ByteString -> Maybe a+class (Show a) => Accept a where+  -- | Specifies how to parse an Accept-* header after quality has been+  -- handled.+  parseAccept :: ByteString -> Maybe a -    -- | Evaluates whether either the left argument matches the right one.-    ---    -- This relation must be a total order, where more specific terms on the-    -- left can produce a match, but a less specific term on the left can-    -- never produce a match. For instance, when matching against media types-    -- it is important that if the client asks for a general type then we can-    -- choose a more specific offering from the server, but if a client asks-    -- for a specific type and the server only offers a more general form,-    -- then we cannot generalise. In this case, the server types will be the-    -- left argument, and the client types the right.-    ---    -- For types with no concept of specificity, this operation is just-    -- equality.-    matches :: a -> a -> Bool+  -- | Evaluates whether either the left argument matches the right one.+  --+  -- This relation must be a total order, where more specific terms on the+  -- left can produce a match, but a less specific term on the left can+  -- never produce a match. For instance, when matching against media types+  -- it is important that if the client asks for a general type then we can+  -- choose a more specific offering from the server, but if a client asks+  -- for a specific type and the server only offers a more general form,+  -- then we cannot generalise. In this case, the server types will be the+  -- left argument, and the client types the right.+  --+  -- For types with no concept of specificity, this operation is just+  -- equality.+  matches :: a -> a -> Bool -    -- | Evaluates whether the left argument is more specific than the right.-    ---    -- This relation must be irreflexive and transitive. For types with no-    -- concept of specificity, this is the empty relation (always false).-    moreSpecificThan :: a -> a -> Bool+  -- | Evaluates whether the left argument is more specific than the right.+  --+  -- This relation must be irreflexive and transitive. For types with no+  -- concept of specificity, this is the empty relation (always false).+  moreSpecificThan :: a -> a -> Bool -    -- | Indicates whether extension parameters are permitted after the weight-    -- parameter when this type appears in an Accept header. Defaults to-    -- false.-    hasExtensionParameters :: Proxy a -> Bool-    hasExtensionParameters _ = False+  -- | Indicates whether extension parameters are permitted after the weight+  -- parameter when this type appears in an Accept header. Defaults to+  -- false.+  hasExtensionParameters :: Proxy a -> Bool+  hasExtensionParameters _ = False  instance Accept ByteString where-    parseAccept = Just-    matches a b = CI.mk a == CI.mk b-    moreSpecificThan _ _ = False+  parseAccept = Just+  matches a b = CI.mk a == CI.mk b+  moreSpecificThan _ _ = False

@@ -1,7 +1,5 @@------------------------------------------------------------------------------- -- | Defines the 'Charset' accept header with an 'Accept' instance for use in -- encoding negotiation.-module Network.HTTP.Media.Charset-    ( Charset ) where+module Network.HTTP.Media.Charset (Charset) where -import           Network.HTTP.Media.Charset.Internal+import Network.HTTP.Media.Charset.Internal

@@ -1,25 +1,21 @@------------------------------------------------------------------------------- -- | Defines the 'Charset' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Charset.Internal-    ( Charset (..)-    ) where--import qualified Data.ByteString.Char8           as BS-import qualified Data.CaseInsensitive            as CI--import           Control.Monad                   (guard)-import           Data.ByteString                 (ByteString)-import           Data.CaseInsensitive            (CI, original)-import           Data.Maybe                      (fromMaybe)-import           Data.String                     (IsString (..))--import           Network.HTTP.Media.Accept       (Accept (..))-import           Network.HTTP.Media.RenderHeader (RenderHeader (..))-import           Network.HTTP.Media.Utils        (isValidToken)+  ( 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>. --@@ -27,25 +23,27 @@ -- -- > charset = token / "*" newtype Charset = Charset (CI ByteString)-    deriving (Eq, Ord)+  deriving (Eq, Ord)  instance Show Charset where-    show = BS.unpack . renderHeader+  show = BS.unpack . renderHeader  instance IsString Charset where-    fromString str = flip fromMaybe (parseAccept $ BS.pack str) $-        error $ "Invalid encoding literal " ++ str+  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)+  parseAccept bs = do+    guard $ isValidToken bs+    return $ Charset (CI.mk bs) -    matches _ (Charset "*") = True-    matches a b             = a == b+  matches _ (Charset "*") = True+  matches a b = a == b -    moreSpecificThan _ (Charset "*") = True-    moreSpecificThan _ _             = False+  moreSpecificThan _ (Charset "*") = True+  moreSpecificThan _ _ = False  instance RenderHeader Charset where-    renderHeader (Charset e) = original e+  renderHeader (Charset e) = original e

@@ -1,7 +1,5 @@------------------------------------------------------------------------------- -- | Defines the 'Encoding' accept header with an 'Accept' instance for use in -- encoding negotiation.-module Network.HTTP.Media.Encoding-    ( Encoding ) where+module Network.HTTP.Media.Encoding (Encoding) where -import           Network.HTTP.Media.Encoding.Internal+import Network.HTTP.Media.Encoding.Internal

@@ -1,25 +1,21 @@------------------------------------------------------------------------------- -- | Defines the 'Encoding' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Encoding.Internal-    ( Encoding (..)-    ) where--import qualified Data.ByteString.Char8           as BS-import qualified Data.CaseInsensitive            as CI--import           Control.Monad                   (guard)-import           Data.ByteString                 (ByteString)-import           Data.CaseInsensitive            (CI, original)-import           Data.Maybe                      (fromMaybe)-import           Data.String                     (IsString (..))--import           Network.HTTP.Media.Accept       (Accept (..))-import           Network.HTTP.Media.RenderHeader (RenderHeader (..))-import           Network.HTTP.Media.Utils        (isValidToken)+  ( 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>. --@@ -27,28 +23,30 @@ -- -- > codings = content-coding / "identity" / "*" newtype Encoding = Encoding (CI ByteString)-    deriving (Eq, Ord)+  deriving (Eq, Ord)  instance Show Encoding where-    show = BS.unpack . renderHeader+  show = BS.unpack . renderHeader  instance IsString Encoding where-    fromString str = flip fromMaybe (parseAccept $ BS.pack str) $-        error $ "Invalid encoding literal " ++ str+  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)+  -- 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+  matches _ (Encoding "*") = True+  matches a b = a == b -    moreSpecificThan _ (Encoding "*") = True-    moreSpecificThan _ _              = False+  moreSpecificThan _ (Encoding "*") = True+  moreSpecificThan _ _ = False  instance RenderHeader Encoding where-    renderHeader (Encoding e) = original e+  renderHeader (Encoding e) = original e

@@ -1,18 +1,15 @@------------------------------------------------------------------------------- -- | 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+  ( 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]

@@ -1,26 +1,22 @@------------------------------------------------------------------------------- -- | Defines the 'Language' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Language.Internal-    ( Language (..)-    ) where--import qualified Data.ByteString.Char8           as BS-import qualified Data.CaseInsensitive            as CI--import           Control.Monad                   (guard)-import           Data.ByteString                 (ByteString)-import           Data.CaseInsensitive            (CI, original)-import           Data.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 (..))+  ( 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>. --@@ -28,40 +24,44 @@ -- -- > language-range = (1*8ALPHA *("-" 1*8alphanum)) / "*" newtype Language = Language [CI ByteString]-    deriving (Eq, Ord)+  deriving (Eq, Ord)  -- Note that internally, Language [] equates to *.  instance Show Language where-    show = BS.unpack . renderHeader+  show = BS.unpack . renderHeader  instance IsString Language where-    fromString "*" = Language []-    fromString str = flip fromMaybe (parseAccept $ BS.pack str) $-        error $ "Invalid language literal " ++ str+  fromString "*" = Language []+  fromString str =+    flip fromMaybe (parseAccept $ BS.pack str) $+      error $+        "Invalid language literal " ++ str  instance Accept Language where-    parseAccept "*" = Just $ Language []-    parseAccept bs = do-        let pieces = BS.split '-' bs-        guard $ not (null pieces)-        Language <$> mapM check pieces-      where-        check part = do-            let len = BS.length part-            guard $ len >= 1 && len <= 8 &&-                isAlpha (BS.head part) &&-                BS.all isAlphaNum (BS.tail part)-            return (CI.mk part)+  parseAccept "*" = Just $ Language []+  parseAccept bs = do+    let pieces = BS.split '-' bs+    guard $ not (null pieces)+    Language <$> mapM check pieces+    where+      check part = do+        let len = BS.length part+        guard $+          len >= 1+            && len <= 8+            && isAlpha (BS.head part)+            && BS.all isAlphaNum (BS.tail part)+        return (CI.mk part) -    -- Languages match if the right argument is a prefix of the left.-    matches (Language a) (Language b)  = b `isPrefixOf` a+  -- Languages match if the right argument is a prefix of the left.+  matches (Language a) (Language b) = b `isPrefixOf` a -    -- The left language is more specific than the right if the right-    -- arguments is a strict prefix of the left.-    moreSpecificThan (Language a) (Language b) =-        b `isPrefixOf` a && length a > length b+  -- The left language is more specific than the right if the right+  -- arguments is a strict prefix of the left.+  moreSpecificThan (Language a) (Language b) =+    b `isPrefixOf` a && length a > length b  instance RenderHeader Language where-    renderHeader (Language []) = "*"-    renderHeader (Language l)  = BS.intercalate "-" (map original l)+  renderHeader (Language []) = "*"+  renderHeader (Language l) = BS.intercalate "-" (map original l)

@@ -1,103 +1,86 @@------------------------------------------------------------------------------- -- | Defines the 'MediaType' accept header with an 'Accept' instance for use -- in content-type negotiation. module Network.HTTP.Media.MediaType-    (-    -- * Type and creation-      MediaType-    , Parameters-    , (//)-    , (/:)+  ( -- * Type and creation+    MediaType,+    Parameters,+    (//),+    (/:),      -- * Querying-    , mainType-    , subType-    , parameters-    , (/?)-    , (/.)-    ) where--import qualified Data.ByteString.Char8                 as BS-import qualified Data.CaseInsensitive                  as CI-import qualified Data.Map                              as Map--import           Data.ByteString                       (ByteString)-import           Data.CaseInsensitive                  (CI)-import           Data.Map                              (empty, insert)+    mainType,+    subType,+    parameters,+    (/?),+    (/.),+  )+where +import Data.ByteString (ByteString)+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.MediaType.Internal (MediaType (MediaType))-import           Network.HTTP.Media.MediaType.Internal hiding (MediaType (..))-import           Network.HTTP.Media.Utils-+import Network.HTTP.Media.Utils ------------------------------------------------------------------------------- -- | Retrieves the main type of a 'MediaType'. mainType :: MediaType -> CI ByteString mainType = Internal.mainType -------------------------------------------------------------------------------- -- | Retrieves the sub type of a 'MediaType'. subType :: MediaType -> CI ByteString subType = Internal.subType -------------------------------------------------------------------------------- -- | Retrieves the parameters of a 'MediaType'. parameters :: MediaType -> Parameters parameters = Internal.parameters -------------------------------------------------------------------------------- -- | Builds a 'MediaType' without parameters. Can produce an error if -- either type is invalid. (//) :: ByteString -> ByteString -> MediaType a // b-    | a == "*" && b == "*" = MediaType (CI.mk a) (CI.mk b) empty-    | b == "*"             = MediaType (ensureR a) (CI.mk b) empty-    | otherwise            = MediaType (ensureR a) (ensureR b) empty-+  | a == "*" && b == "*" = MediaType (CI.mk a) (CI.mk b) empty+  | b == "*" = MediaType (ensureR a) (CI.mk b) empty+  | otherwise = MediaType (ensureR a) (ensureR b) empty ------------------------------------------------------------------------------- -- | Adds a parameter to a 'MediaType'. Can produce an error if either -- string is invalid. (/:) :: MediaType -> (ByteString, ByteString) -> MediaType (MediaType a b p) /: (k, v) = MediaType a b $ insert (ensureR k) (ensureV v) p -------------------------------------------------------------------------------- -- | Evaluates if a 'MediaType' has a parameter of the given name. (/?) :: MediaType -> ByteString -> Bool (MediaType _ _ p) /? k = Map.member (CI.mk k) p -------------------------------------------------------------------------------- -- | Retrieves a parameter from a 'MediaType'. (/.) :: MediaType -> ByteString -> Maybe (CI ByteString) (MediaType _ _ p) /. k = Map.lookup (CI.mk k) p -------------------------------------------------------------------------------- -- | Ensures that the 'ByteString' matches the ABNF for `reg-name` in RFC -- 4288. ensureR :: ByteString -> CI ByteString-ensureR bs = CI.mk $ if l == 0 || l > 127-    then error $ "Invalid length for " ++ show bs else ensure isMediaChar bs-  where l = BS.length bs-+ensureR bs =+  CI.mk $+    if l == 0 || l > 127+      then error $ "Invalid length for " ++ show bs+      else ensure isMediaChar bs+  where+    l = BS.length bs ------------------------------------------------------------------------------- -- | Ensures that the 'ByteString' does not contain invalid characters for -- a parameter value. RFC 4288 does not specify what characters are valid, so -- here we just disallow parameter and media type breakers, ',' and ';'. ensureV :: ByteString -> CI ByteString ensureV = CI.mk . ensure (`notElem` [',', ';']) -------------------------------------------------------------------------------- -- | Ensures the predicate matches for every character in the given string. ensure :: (Char -> Bool) -> ByteString -> ByteString-ensure f bs = maybe-    (error $ "Invalid character in " ++ show bs) (const bs) (BS.find f bs)+ensure f bs =+  maybe+    (error $ "Invalid character in " ++ show bs)+    (const bs)+    (BS.find f bs)

@@ -1,83 +1,87 @@------------------------------------------------------------------------------- -- | Defined to allow the constructor of 'MediaType' to be exposed to tests. module Network.HTTP.Media.MediaType.Internal-    ( MediaType (..)-    , Parameters-    ) where--import qualified Data.ByteString.Char8           as BS-import qualified Data.CaseInsensitive            as CI-import qualified Data.Map                        as Map--import           Control.Monad                   (foldM, guard)-import           Data.ByteString                 (ByteString)-import           Data.CaseInsensitive            (CI, original)-import           Data.Map                        (Map)-import           Data.Maybe                      (fromMaybe)-import           Data.Monoid                     ((<>))-import           Data.String                     (IsString (..))--import           Network.HTTP.Media.Accept       (Accept (..))-import           Network.HTTP.Media.RenderHeader (RenderHeader (..))-import           Network.HTTP.Media.Utils        (breakChar, trimBS)+  ( 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.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   :: CI ByteString  -- ^ The main type of the MediaType-    , subType    :: CI ByteString  -- ^ The sub type of the MediaType-    , parameters :: Parameters     -- ^ The parameters of the MediaType-    } deriving (Eq, Ord)+  { -- | The main type of the MediaType+    mainType :: CI ByteString,+    -- | The sub type of the MediaType+    subType :: CI ByteString,+    -- | The parameters of the MediaType+    parameters :: Parameters+  }+  deriving (Eq, Ord)  instance Show MediaType where-    show = BS.unpack . renderHeader+  show = BS.unpack . renderHeader  instance IsString MediaType where-    fromString str = flip fromMaybe (parseAccept $ BS.pack str) $-        error $ "Invalid media type literal " ++ str+  fromString str =+    flip fromMaybe (parseAccept $ BS.pack str) $+      error $+        "Invalid media type literal " ++ str  instance Accept MediaType where-    parseAccept bs = do-        (s, ps) <- uncons (map trimBS (BS.split ';' bs))-        (a, b)  <- breakChar '/' s-        guard $ not (BS.null a || BS.null b) && (a /= "*" || b == "*")-        ps' <- foldM insert Map.empty ps-        return $ MediaType (CI.mk a) (CI.mk b) ps'-      where-        uncons []      = Nothing-        uncons (a : b) = Just (a, b)-        both f (a, b) = (f a, f b)-        insert ps =-          fmap (flip (uncurry Map.insert) ps . both CI.mk) . breakChar '='+  parseAccept bs = do+    (s, ps) <- uncons (map trimBS (BS.split ';' bs))+    (a, b) <- breakChar '/' s+    guard $ not (BS.null a || BS.null b) && (a /= "*" || b == "*")+    ps' <- foldM insert Map.empty ps+    return $ MediaType (CI.mk a) (CI.mk b) ps'+    where+      uncons [] = Nothing+      uncons (a : b) = Just (a, b)+      both f (a, b) = (f a, f b)+      insert ps =+        fmap (flip (uncurry Map.insert) ps . both CI.mk) . breakChar '=' -    matches a b-        | mainType b == "*" = params-        | subType b == "*"  = mainType a == mainType b && params-        | otherwise         = main && sub && params-      where-        main = mainType a == mainType b-        sub = subType a == subType b-        params = Map.null (parameters b) || parameters a == parameters b+  matches a b+    | mainType b == "*" = params+    | subType b == "*" = mainType a == mainType b && params+    | otherwise = main && sub && params+    where+      main = mainType a == mainType b+      sub = subType a == subType b+      params = Map.null (parameters b) || parameters a == parameters b -    moreSpecificThan a b = (a `matches` b &&) $-        mainType a == "*" && anyB && params ||-        subType a == "*" && (anyB || subB && params) ||-        anyB || subB || params-      where-        anyB = mainType b == "*"-        subB = subType b == "*"-        params = not (Map.null $ parameters a) && Map.null (parameters b)+  moreSpecificThan a b =+    (a `matches` b &&) $+      mainType a == "*" && anyB && params+        || subType a == "*" && (anyB || subB && params)+        || anyB+        || subB+        || params+    where+      anyB = mainType b == "*"+      subB = subType b == "*"+      params = not (Map.null $ parameters a) && Map.null (parameters b) -    hasExtensionParameters _ = True+  hasExtensionParameters _ = True  instance RenderHeader MediaType where-    renderHeader (MediaType a b p) =-        Map.foldrWithKey f (original a <> "/" <> original b) p-      where-        f k v = (<> ";" <> original k <> "=" <> original v)-+  renderHeader (MediaType a b p) =+    Map.foldrWithKey f (original a <> "/" <> original b) p+    where+      f k v = (<> ";" <> original k <> "=" <> original v) ------------------------------------------------------------------------------- -- | 'MediaType' parameters. type Parameters = Map (CI ByteString) (CI ByteString)

@@ -1,137 +1,121 @@ {-# LANGUAGE DeriveFunctor #-} ------------------------------------------------------------------------------- -- | Defines the quality value data type. module Network.HTTP.Media.Quality-    ( Quality (..)-    , quality-    , QualityOrder-    , qualityOrder-    , isAcceptable-    , maxQuality-    , minQuality-    , mostSpecific-    , showQ-    , readQ-    ) where--import qualified Data.ByteString.Char8           as BS--import           Data.ByteString                 (ByteString)-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 (..))+  ( Quality (..),+    quality,+    QualityOrder,+    qualityOrder,+    isAcceptable,+    maxQuality,+    minQuality,+    mostSpecific,+    showQ,+    readQ,+  )+where +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, Functor, Ord)--instance RenderHeader a => Show (Quality a) where-    show = BS.unpack . renderHeader+  { qualityData :: a,+    qualityValue :: Word16+  }+  deriving (Eq, Functor, Ord) -instance RenderHeader h => RenderHeader (Quality h) where-    renderHeader (Quality a q) = renderHeader 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)-+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)+  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 :: (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'+  | a `moreSpecificThan` b = Quality a q+  | b `moreSpecificThan` a = Quality b r+  | otherwise = Quality a q'   where     q' = fromIntegral (fromIntegral q * fromIntegral r `div` 1000 :: Word32) -------------------------------------------------------------------------------- -- | Converts the integral value into its standard quality representation. showQ :: Word16 -> ByteString showQ 1000 = "1"-showQ 0    = "0"-showQ q    = "0." <> BS.replicate (3 - length s) '0' <> b+showQ 0 = "0"+showQ q = "0." <> BS.replicate (3 - length s) '0' <> b   where     s = show q     b = BS.pack (dropWhileEnd (== '0') s) -------------------------------------------------------------------------------- -- | Reads the standard quality representation into an integral value. readQ :: ByteString -> Maybe Word16 readQ bs-    | BS.null bs = Nothing-    | h == '1'   = read1 t-    | h == '0'   = read0 t-    | otherwise  = Nothing+  | BS.null bs = Nothing+  | h == '1' = read1 t+  | h == '0' = read0 t+  | otherwise = Nothing   where     h = BS.head bs     t = BS.tail bs  read1 :: ByteString -> Maybe Word16 read1 bs-    | BS.null bs || h == '.' && BS.length t < 4 && BS.all (== '0') t-                = Just 1000-    | otherwise = Nothing+  | BS.null bs || h == '.' && BS.length t < 4 && BS.all (== '0') t =+      Just 1000+  | otherwise = Nothing   where     h = BS.head bs     t = BS.tail bs  read0 :: ByteString -> Maybe Word16 read0 bs-    | BS.null bs = Just 0-    | h == '.' && BS.length t < 4 && BS.all isDigit t-                = Just (toWord (t <> BS.replicate (3 - BS.length t) '0'))-    | otherwise = Nothing+  | BS.null bs = Just 0+  | h == '.' && BS.length t < 4 && BS.all isDigit t =+      Just (toWord (t <> BS.replicate (3 - BS.length t) '0'))+  | otherwise = Nothing   where     h = BS.head bs     t = BS.tail bs

@@ -1,27 +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)+  ( RenderHeader (..),+  )+where +import Data.ByteString (ByteString, intercalate) ------------------------------------------------------------------------------- -- | A class for header values, so they may be rendered to their 'ByteString' -- representation. Lists of header values and quality-marked header values -- will render appropriately. class RenderHeader h where--    -- | Render a header value to a UTF-8 'ByteString'.-    renderHeader :: h -> ByteString+  -- | Render a header value to a UTF-8 'ByteString'.+  renderHeader :: h -> ByteString  instance RenderHeader ByteString where-    renderHeader = id+  renderHeader = id -instance RenderHeader h => RenderHeader [h] where-    renderHeader = intercalate "," . map renderHeader+instance (RenderHeader h) => RenderHeader [h] where+  renderHeader = intercalate "," . map renderHeader

@@ -1,73 +1,73 @@------------------------------------------------------------------------------ -- | Common utilities. module Network.HTTP.Media.Utils-    ( breakChar-    , trimBS--    , mediaChars-    , isMediaChar--    , tokenChars-    , isTokenChar-    , isValidToken-    ) where+  ( breakChar,+    trimBS,+    mediaChars,+    isMediaChar,+    tokenChars,+    isTokenChar,+    isValidToken,+  )+where +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS--import           Data.ByteString       (ByteString)-import           Data.Char             (isControl)-+import Data.Char (isControl) ------------------------------------------------------------------------------- -- | Equivalent to 'Data.ByteString.break' (on equality against the given -- character), but leaves out the byte that the string is broken on. breakChar :: Char -> ByteString -> Maybe (ByteString, ByteString) breakChar c = safeTail . BS.break (== c)   where     safeTail (a, b)-        | BS.null b = Nothing-        | otherwise = Just (a, BS.tail b)-+      | BS.null b = Nothing+      | otherwise = Just (a, BS.tail b) ------------------------------------------------------------------------------- -- | Trims tab and space characters from both ends of a ByteString. trimBS :: ByteString -> ByteString trimBS = fst . BS.spanEnd isLWS . BS.dropWhile isLWS   where     isLWS c = c == ' ' || c == '\t' -------------------------------------------------------------------------------- -- | List of the valid characters for a media-type `reg-name` as per RFC 4288. mediaChars :: [Char]-mediaChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "!#$&.+-^_"-+mediaChars = ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ "!#$&.+-^_" ------------------------------------------------------------------------------- -- | Evaluates whether the given character is valid in a media type `reg-name` -- as per RFC 4288. 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 = [ '(', ')', '<', '>', '@', ',', ';', ':', '\\'-                 , '"', '/', '[', ']', '?', '=', '{', '}', ' '-                 ]-+    separators =+      [ '(',+        ')',+        '<',+        '>',+        '@',+        ',',+        ';',+        ':',+        '\\',+        '"',+        '/',+        '[',+        ']',+        '?',+        '=',+        '{',+        '}',+        ' '+      ] ------------------------------------------------------------------------------- -- | HTTP header token characters as per RFC 2616. tokenChars :: [Char]-tokenChars = filter isTokenChar ['\0'..'\127']-+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

@@ -1,37 +1,32 @@------------------------------------------------------------------------------- module Network.HTTP.Media.Accept.Tests (tests) where -import           Test.Tasty                (TestTree, testGroup)-import           Test.Tasty.QuickCheck     (testProperty)--import           Network.HTTP.Media.Accept-import           Network.HTTP.Media.Gen-+import Network.HTTP.Media.Accept+import Network.HTTP.Media.Gen+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty) ------------------------------------------------------------------------------- tests :: [TestTree] tests =-    [ testMatches-    , testMoreSpecificThan-    ]-+  [ testMatches,+    testMoreSpecificThan+  ] ------------------------------------------------------------------------------- testMatches :: TestTree-testMatches = testGroup "matches"+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 :: TestTree-testMoreSpecificThan = testProperty "moreSpecificThan" $+testMoreSpecificThan =+  testProperty "moreSpecificThan" $     (not .) . moreSpecificThan <$> genByteString <*> genByteString

@@ -1,49 +1,37 @@ {-# LANGUAGE TupleSections #-} ------------------------------------------------------------------------------- -- | Contains definitions for generating 'Charset's. module Network.HTTP.Media.Charset.Gen-    ( anything-    , genCharset-    , genConcreteCharset-    , genDiffCharset-    , genDiffConcreteCharsets-    ) where--import           Test.QuickCheck.Gen--import           Network.HTTP.Media.Gen              (genDiffWith, genToken)--import           Network.HTTP.Media.Charset.Internal+  ( 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+  enc <- genConcreteCharset+  (enc,) <$> genDiffWith genConcreteCharset enc

@@ -1,92 +1,83 @@------------------------------------------------------------------------------- module Network.HTTP.Media.Charset.Tests (tests) where -import qualified Data.ByteString.Char8           as BS--import           Control.Monad                   (join)-import           Data.String                     (fromString)-import           Test.QuickCheck                 ((===))-import           Test.Tasty                      (TestTree, testGroup)-import           Test.Tasty.QuickCheck           (testProperty)--import           Network.HTTP.Media.Accept-import           Network.HTTP.Media.Charset      (Charset)-import           Network.HTTP.Media.Charset.Gen-import           Network.HTTP.Media.RenderHeader-+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-    ]-+  [ testEq,+    testShow,+    testFromString,+    testMatches,+    testMoreSpecific,+    testParseAccept+  ] ------------------------------------------------------------------------------- -- Equality is derived, but we test it here to get 100% coverage. testEq :: TestTree-testEq = testGroup "Eq"+testEq =+  testGroup+    "Eq"     [ testProperty "==" $ do         enc <- genCharset-        return $ enc === enc-    , 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-+  enc <- genCharset+  return $ parseAccept (BS.pack $ show enc) === Just enc ------------------------------------------------------------------------------- testFromString :: TestTree testFromString = testProperty "fromString" $ do-    enc <- genCharset-    return $ enc === fromString (show enc)-+  enc <- genCharset+  return $ enc === fromString (show enc) ------------------------------------------------------------------------------- testMatches :: TestTree-testMatches = testGroup "matches"+testMatches =+  testGroup+    "matches"     [ testProperty "Equal values match" $-        join matches <$> genCharset-    , testProperty "* matches anything" $-        flip matches anything <$> genCharset-    , testProperty "No concrete encoding matches *" $+        join matches <$> genCharset,+      testProperty "* matches anything" $+        flip matches anything <$> genCharset,+      testProperty "No concrete encoding matches *" $         not . matches anything <$> genConcreteCharset     ] -------------------------------------------------------------------------------- testMoreSpecific :: TestTree-testMoreSpecific = testGroup "moreSpecificThan"+testMoreSpecific =+  testGroup+    "moreSpecificThan"     [ testProperty "Against *" $-        flip moreSpecificThan anything <$> genConcreteCharset-    , testProperty "With *" $-        not . moreSpecificThan anything <$> genConcreteCharset-    , testProperty "Unrelated encodings" $+        flip moreSpecificThan anything <$> genConcreteCharset,+      testProperty "With *" $+        not . moreSpecificThan anything <$> genConcreteCharset,+      testProperty "Unrelated encodings" $         not . uncurry moreSpecificThan <$> genDiffConcreteCharsets     ] -------------------------------------------------------------------------------- testParseAccept :: TestTree-testParseAccept = testGroup "parseAccept"+testParseAccept =+  testGroup+    "parseAccept"     [ testProperty "Empty" $-        parseAccept "" === (Nothing :: Maybe Charset)-    , testProperty "Wildcard" $-        parseAccept "*" === Just anything-    , testProperty "Valid parse" $ do+        parseAccept "" === (Nothing :: Maybe Charset),+      testProperty "Wildcard" $+        parseAccept "*" === Just anything,+      testProperty "Valid parse" $ do         enc <- genCharset         return $ parseAccept (renderHeader enc) === Just enc     ]

@@ -1,55 +1,42 @@ {-# LANGUAGE TupleSections #-} ------------------------------------------------------------------------------- -- | Contains definitions for generating 'Encoding's. module Network.HTTP.Media.Encoding.Gen-    ( anything-    , identity-    , genEncoding-    , genConcreteEncoding-    , genDiffEncoding-    , genDiffConcreteEncodings-    ) where--import           Test.QuickCheck.Gen--import           Network.HTTP.Media.Encoding.Internal-import           Network.HTTP.Media.Gen               (genDiffWith, genToken)+  ( 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+  enc <- genConcreteEncoding+  (enc,) <$> genDiffWith genConcreteEncoding enc

@@ -1,91 +1,82 @@------------------------------------------------------------------------------- module Network.HTTP.Media.Encoding.Tests (tests) where -import qualified Data.ByteString.Char8           as BS--import           Control.Monad                   (join)-import           Data.String                     (fromString)-import           Test.QuickCheck                 ((===))-import           Test.Tasty                      (TestTree, testGroup)-import           Test.Tasty.QuickCheck           (testProperty)--import           Network.HTTP.Media.Accept-import           Network.HTTP.Media.Encoding.Gen-import           Network.HTTP.Media.RenderHeader-+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-    ]-+  [ testEq,+    testShow,+    testFromString,+    testMatches,+    testMoreSpecific,+    testParseAccept+  ] ------------------------------------------------------------------------------- -- Equality is derived, but we test it here to get 100% coverage. testEq :: TestTree-testEq = testGroup "Eq"+testEq =+  testGroup+    "Eq"     [ testProperty "==" $ do         enc <- genEncoding-        return $ enc === enc-    , 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-+  enc <- genEncoding+  return $ parseAccept (BS.pack $ show enc) === Just enc ------------------------------------------------------------------------------- testFromString :: TestTree testFromString = testProperty "fromString" $ do-    enc <- genEncoding-    return $ enc === fromString (show enc)-+  enc <- genEncoding+  return $ enc === fromString (show enc) ------------------------------------------------------------------------------- testMatches :: TestTree-testMatches = testGroup "matches"+testMatches =+  testGroup+    "matches"     [ testProperty "Equal values match" $-        join matches <$> genEncoding-    , testProperty "* matches anything" $-        flip matches anything <$> genEncoding-    , testProperty "No concrete encoding matches *" $+        join matches <$> genEncoding,+      testProperty "* matches anything" $+        flip matches anything <$> genEncoding,+      testProperty "No concrete encoding matches *" $         not . matches anything <$> genConcreteEncoding     ] -------------------------------------------------------------------------------- testMoreSpecific :: TestTree-testMoreSpecific = testGroup "moreSpecificThan"+testMoreSpecific =+  testGroup+    "moreSpecificThan"     [ testProperty "Against *" $-        flip moreSpecificThan anything <$> genConcreteEncoding-    , testProperty "With *" $-        not . moreSpecificThan anything <$> genConcreteEncoding-    , testProperty "Unrelated encodings" $+        flip moreSpecificThan anything <$> genConcreteEncoding,+      testProperty "With *" $+        not . moreSpecificThan anything <$> genConcreteEncoding,+      testProperty "Unrelated encodings" $         not . uncurry moreSpecificThan <$> genDiffConcreteEncodings     ] -------------------------------------------------------------------------------- testParseAccept :: TestTree-testParseAccept = testGroup "parseAccept"+testParseAccept =+  testGroup+    "parseAccept"     [ testProperty "Empty" $-        parseAccept "" === Just identity-    , testProperty "Wildcard" $-        parseAccept "*" === Just anything-    , testProperty "Valid parse" $ do+        parseAccept "" === Just identity,+      testProperty "Wildcard" $+        parseAccept "*" === Just anything,+      testProperty "Valid parse" $ do         enc <- genEncoding         return $ parseAccept (renderHeader enc) === Just enc     ]

@@ -1,91 +1,72 @@------------------------------------------------------------------------------- -- | Contains definitions for generating 'ByteString's. module Network.HTTP.Media.Gen-    ( genToken--    , genByteStringFrom-    , genCIByteStringFrom-    , genByteString-    , genCIByteString-    , genDiffWith-    , genDiffByteString-    , genDiffCIByteString--    , padString-    ) where--import qualified Data.ByteString.Char8    as BS-import qualified Data.CaseInsensitive     as CI-import qualified Test.QuickCheck.Gen      as Gen+  ( genToken,+    genByteStringFrom,+    genCIByteStringFrom,+    genByteString,+    genCIByteString,+    genDiffWith,+    genDiffByteString,+    genDiffCIByteString,+    padString,+  )+where +import Control.Monad (join, liftM2)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.CaseInsensitive (CI, original)+import qualified Data.CaseInsensitive as CI+import Data.Monoid ((<>)) import qualified Network.HTTP.Media.Utils as Utils--import           Control.Monad            (join, liftM2)-import           Data.ByteString          (ByteString)-import           Data.CaseInsensitive     (CI, original)-import           Data.Monoid              ((<>))-import           Test.QuickCheck.Gen      (Gen)-+import Test.QuickCheck.Gen (Gen)+import qualified Test.QuickCheck.Gen as Gen+import Prelude hiding ((<>)) ------------------------------------------------------------------------------- -- | Generates a valid header token. genToken :: Gen (CI ByteString) genToken = genCIByteStringFrom Utils.tokenChars -------------------------------------------------------------------------------- -- | Produces a non-empty ByteString of random characters from the given set. genByteStringFrom :: String -> Gen ByteString genByteStringFrom = fmap BS.pack . 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 = fmap BS.pack . (:)+genByteString =+  fmap BS.pack . (:)     <$> Gen.elements alpha     <*> Gen.scale (max 0 . pred) (Gen.listOf (Gen.elements alphaNum))   where-    alpha = ['a'..'z'] ++ ['A'..'Z']-    alphaNum = alpha ++ ['0'..'9']-+    alpha = ['a' .. 'z'] ++ ['A' .. 'Z']+    alphaNum = alpha ++ ['0' .. '9'] ------------------------------------------------------------------------------- -- | Produces a non-empty case-insensitive ByteString of random alphanumeric -- characters with a non-numeric head. genCIByteString :: Gen (CI ByteString) genCIByteString = fmap CI.mk genByteString -------------------------------------------------------------------------------- -- | Produces a non-empty ByteString different to the given one using the -- given generator.-genDiffWith :: Eq a => Gen a -> a -> Gen a+genDiffWith :: (Eq a) => Gen a -> a -> Gen a genDiffWith gen = Gen.suchThat gen . (/=) -------------------------------------------------------------------------------- -- | Produces a non-empty ByteString of random alphanumeric characters that -- is case-insensitively different to the given one. genDiffByteString :: ByteString -> Gen ByteString genDiffByteString = fmap original . genDiffCIByteString . CI.mk -------------------------------------------------------------------------------- -- | Produces a non-empty case-insensitive ByteString of random alphanumeric -- characters that is different to the given one. genDiffCIByteString :: CI ByteString -> Gen (CI ByteString) genDiffCIByteString = genDiffWith genCIByteString -------------------------------------------------------------------------------- -- | Pad a 'ByteString' with a random amount of tab and space characters. padString :: ByteString -> Gen ByteString padString c = join (liftM2 pad) (BS.pack <$> Gen.listOf (Gen.elements " \t"))-  where pad a b = a <> c <> b+  where+    pad a b = a <> c <> b

@@ -1,113 +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           Test.QuickCheck.Gen--import qualified Network.HTTP.Media.Gen               as Gen--import           Network.HTTP.Media.Language.Internal+  ( -- * 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-+genDiffLanguage l = Gen.genDiffWith genLanguage l ------------------------------------------------------------------------------- -- | Generate a Language that has the given language as a prefix. genMatchingLanguage :: Language -> Gen Language genMatchingLanguage (Language pre) =-    Language . (pre ++) <$> listOf genCIByteString-+  Language . (pre ++) <$> listOf genCIByteString ------------------------------------------------------------------------------- -- | Generate a Language that has the given language as a proper prefix. genDiffMatchingLanguage :: Language -> Gen Language genDiffMatchingLanguage (Language pre) =-    Language . (pre ++) <$> listOf1 genCIByteString-+  Language . (pre ++) <$> listOf1 genCIByteString ------------------------------------------------------------------------------- -- | Generate a Language that does not have the given language as a prefix. genNonMatchingLanguage :: Language -> Gen Language-genNonMatchingLanguage (Language [])        = genConcreteLanguage+genNonMatchingLanguage (Language []) = genConcreteLanguage genNonMatchingLanguage (Language (pre : _)) = do-    pre' <- genDiffCIByteString pre-    genMatchingLanguage $ Language [pre']-+  pre' <- genDiffCIByteString pre+  genMatchingLanguage $ Language [pre'] ------------------------------------------------------------------------------- -- | A private definition for generating pairs of languagues. genLanguages :: (Language -> Gen Language) -> Gen (Language, Language) genLanguages gen = do-    pre <- genLanguage-    (pre,) <$> gen pre-+  pre <- genLanguage+  (pre,) <$> gen pre ------------------------------------------------------------------------------- -- | Generate two languages, the first of which is a prefix of the second. genMatchingLanguages :: Gen (Language, Language) genMatchingLanguages = genLanguages genMatchingLanguage -------------------------------------------------------------------------------- -- | Generate two languages, the first of which is a proper prefix of the -- second. genDiffMatchingLanguages :: Gen (Language, Language) genDiffMatchingLanguages = genLanguages genDiffMatchingLanguage -------------------------------------------------------------------------------- -- | Generate two languages, the first of which is not a prefix of the second. genNonMatchingLanguages :: Gen (Language, Language) genNonMatchingLanguages = do-    pre <- genConcreteLanguage-    (pre,) <$> genNonMatchingLanguage pre-+  pre <- genConcreteLanguage+  (pre,) <$> genNonMatchingLanguage pre ------------------------------------------------------------------------------- genCIByteString :: Gen (CI ByteString) genCIByteString = resize 8 Gen.genCIByteString -------------------------------------------------------------------------------- genDiffCIByteString :: CI ByteString -> Gen (CI ByteString) genDiffCIByteString = Gen.genDiffWith genCIByteString

@@ -1,100 +1,92 @@------------------------------------------------------------------------------- module Network.HTTP.Media.Language.Tests (tests) where -import qualified Data.ByteString.Char8           as BS--import           Control.Monad                   (join)-import           Data.Monoid                     ((<>))-import           Data.String                     (fromString)-import           Test.QuickCheck                 ((===))-import           Test.Tasty                      (TestTree, testGroup)-import           Test.Tasty.QuickCheck           (testProperty)--import           Network.HTTP.Media.Accept-import           Network.HTTP.Media.Language-import           Network.HTTP.Media.Language.Gen-import           Network.HTTP.Media.RenderHeader-+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-    ]-+  [ testEq,+    testShow,+    testFromString,+    testMatches,+    testMoreSpecific,+    testParseAccept+  ] ------------------------------------------------------------------------------- -- Equality is derived, but we test it here to get 100% coverage. testEq :: TestTree-testEq = testGroup "Eq"+testEq =+  testGroup+    "Eq"     [ testProperty "==" $ do         lang <- genLanguage-        return $ lang === lang-    , testProperty "/=" $ do-        lang  <- genLanguage+        return $ lang === lang,+      testProperty "/=" $ do+        lang <- genLanguage         lang' <- genDiffLanguage lang         return $ lang /= lang'     ] -------------------------------------------------------------------------------- testShow :: TestTree testShow = testProperty "show" $ do-    lang <- genLanguage-    return $ parseAccept (BS.pack $ show lang) === Just lang-+  lang <- genLanguage+  return $ parseAccept (BS.pack $ show lang) === Just lang ------------------------------------------------------------------------------- testFromString :: TestTree testFromString = testProperty "fromString" $ do-    lang <- genLanguage-    return $ lang === fromString (show lang)-+  lang <- genLanguage+  return $ lang === fromString (show lang) ------------------------------------------------------------------------------- testMatches :: TestTree-testMatches = testGroup "matches"+testMatches =+  testGroup+    "matches"     [ testProperty "Equal values match" $-        join matches <$> genLanguage-    , testProperty "Right prefix matches left" $-        uncurry (flip matches) <$> genMatchingLanguages-    , testProperty "Left prefix does not match right" $-        not . uncurry matches <$> genDiffMatchingLanguages-    , testProperty "* matches anything" $-        flip matches anything <$> genLanguage-    , testProperty "No concrete language matches *" $+        join matches <$> genLanguage,+      testProperty "Right prefix matches left" $+        uncurry (flip matches) <$> genMatchingLanguages,+      testProperty "Left prefix does not match right" $+        not . uncurry matches <$> genDiffMatchingLanguages,+      testProperty "* matches anything" $+        flip matches anything <$> genLanguage,+      testProperty "No concrete language matches *" $         not . matches anything <$> genConcreteLanguage     ] -------------------------------------------------------------------------------- testMoreSpecific :: TestTree-testMoreSpecific = testGroup "moreSpecificThan"+testMoreSpecific =+  testGroup+    "moreSpecificThan"     [ testProperty "Against *" $-        flip moreSpecificThan anything <$> genConcreteLanguage-    , testProperty "With *" $-        not . moreSpecificThan anything <$> genLanguage-    , testProperty "Proper prefix lhs" $-        not . uncurry moreSpecificThan <$> genDiffMatchingLanguages-    , testProperty "Proper prefix rhs" $-        uncurry (flip moreSpecificThan) <$> genDiffMatchingLanguages-    , testProperty "Unrelated languages" $+        flip moreSpecificThan anything <$> genConcreteLanguage,+      testProperty "With *" $+        not . moreSpecificThan anything <$> genLanguage,+      testProperty "Proper prefix lhs" $+        not . uncurry moreSpecificThan <$> genDiffMatchingLanguages,+      testProperty "Proper prefix rhs" $+        uncurry (flip moreSpecificThan) <$> genDiffMatchingLanguages,+      testProperty "Unrelated languages" $         not . uncurry moreSpecificThan <$> genNonMatchingLanguages     ] -------------------------------------------------------------------------------- testParseAccept :: TestTree-testParseAccept = testGroup "parseAccept"-    [ testProperty "Valid parse"$ do+testParseAccept =+  testGroup+    "parseAccept"+    [ testProperty "Valid parse" $ do         lang <- genLanguage-        return $ parseAccept (renderHeader lang) === Just lang-    , testProperty "Trailing hyphen" $ do+        return $ parseAccept (renderHeader lang) === Just lang,+      testProperty "Trailing hyphen" $ do         bs <- renderHeader <$> genLanguage         return $ (parseAccept $ bs <> "-" :: Maybe Language) === Nothing     ]

@@ -1,212 +1,170 @@------------------------------------------------------------------------------- -- | Contains definitions for generating 'MediaType's. module Network.HTTP.Media.MediaType.Gen-    (-    -- * Generating MediaTypes-      anything-    , genMediaType-    , genSubStar-    , genMaybeSubStar-    , subStarOf-    , genConcreteMediaType-    , genWithoutParams-    , genWithParams-    , stripParams-    , genDiffMediaTypesWith-    , genDiffMediaTypeWith-    , genDiffMediaTypes-    , genDiffMediaType-    , genMatchingPair+  ( -- * Generating MediaTypes+    anything,+    genMediaType,+    genSubStar,+    genMaybeSubStar,+    subStarOf,+    genConcreteMediaType,+    genWithoutParams,+    genWithParams,+    stripParams,+    genDiffMediaTypesWith,+    genDiffMediaTypeWith,+    genDiffMediaTypes,+    genDiffMediaType,+    genMatchingPair,      -- * Generating Parameters-    , genParameters-    , genMaybeParameters-    , genDiffParameters+    genParameters,+    genMaybeParameters,+    genDiffParameters,      -- * Rendering Parameters-    , renderParameters-    ) where--import qualified Data.Map                              as Map--import           Control.Monad                         (filterM, liftM2)-import           Data.ByteString                       (ByteString)-import           Data.CaseInsensitive                  (CI, original)-import           Data.Foldable                         (foldlM)-import           Data.Map                              (fromList)-import           Data.Monoid                           ((<>))-import           Test.QuickCheck.Gen--import           Network.HTTP.Media.Gen-import           Network.HTTP.Media.MediaType.Internal+    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 = (CI ByteString, CI ByteString) -------------------------------------------------------------------------------- -- | The MediaType that matches anything. anything :: MediaType anything = MediaType "*" "*" Map.empty -------------------------------------------------------------------------------- -- | Generates any kind of MediaType. genMediaType :: Gen MediaType genMediaType = oneof [return anything, genSubStar, genConcreteMediaType] -------------------------------------------------------------------------------- -- | Generates a MediaType with just a concrete main type. genSubStar :: Gen MediaType genSubStar = do-    main <- genCIByteString-    return $ MediaType main "*" Map.empty-+  main <- genCIByteString+  return $ MediaType main "*" Map.empty ------------------------------------------------------------------------------- -- | Generates a MediaType whose sub type might be *. genMaybeSubStar :: Gen MediaType genMaybeSubStar = oneof [genSubStar, genConcreteMediaType] -------------------------------------------------------------------------------- -- | Strips the sub type and parameters from a MediaType. subStarOf :: MediaType -> MediaType-subStarOf media = media { subType = "*", parameters = Map.empty }-+subStarOf media = media {subType = "*", parameters = Map.empty} ------------------------------------------------------------------------------- -- | Generates a concrete MediaType which may have parameters. genConcreteMediaType :: Gen MediaType genConcreteMediaType = do-    main <- genCIByteString-    sub  <- genCIByteString-    params <- oneof [return Map.empty, genParameters]-    return $ MediaType main sub params-+  main <- genCIByteString+  sub <- genCIByteString+  params <- oneof [return Map.empty, genParameters]+  return $ MediaType main sub params ------------------------------------------------------------------------------- -- | Generates a concrete MediaType with no parameters. genWithoutParams :: Gen MediaType genWithoutParams = do-    main <- genCIByteString-    sub  <- genCIByteString-    return $ MediaType main sub Map.empty-+  main <- genCIByteString+  sub <- genCIByteString+  return $ MediaType main sub Map.empty ------------------------------------------------------------------------------- -- | Generates a MediaType with at least one parameter. genWithParams :: Gen MediaType genWithParams = do-    main   <- genCIByteString-    sub    <- genCIByteString-    MediaType main sub <$> genParameters-+  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. 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 = fmap fromList .-    ($ liftM2 (,) (genDiffCIByteString "q") genCIByteString)-+mkGenParams =+  fmap fromList+    . ($ liftM2 (,) (genDiffCIByteString "q") genCIByteString) ------------------------------------------------------------------------------- -- | Generates some sort of parameters. genMaybeParameters :: Gen Parameters genMaybeParameters = mkGenParams listOf -------------------------------------------------------------------------------- -- | Generates at least one parameter. genParameters :: Gen Parameters genParameters = mkGenParams listOf1 -------------------------------------------------------------------------------- -- | Generates a set of parameters that is not a submap of the given -- parameters (but not necessarily vice versa). genDiffParameters :: Parameters -> Gen Parameters genDiffParameters params = do-    params' <- genParameters-    if params' `Map.isSubmapOf` params-        then genDiffParameters params-        else return params'-+  params' <- genParameters+  if params' `Map.isSubmapOf` params+    then genDiffParameters params+    else return params' ------------------------------------------------------------------------------- -- | Generates a set of parameters that is a strict submap of the given -- parameters. genSubParameters :: Parameters -> Gen (Maybe Parameters) genSubParameters params-    | Map.null params = return Nothing-    | otherwise       = Just . Map.fromList <$> genStrictSublist+  | 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-+      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)+  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-+      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@@ -215,4 +173,4 @@ renderParameters params = foldlM pad "" (Map.toList params)   where     pad s (k, v) =-        (s <>) . (<> original k <> "=" <> original v) <$> padString ";"+      (s <>) . (<> original k <> "=" <> original v) <$> padString ";"

@@ -1,202 +1,198 @@------------------------------------------------------------------------------- module Network.HTTP.Media.MediaType.Tests (tests) where -import qualified Data.ByteString.Char8                 as BS-import qualified Data.Map                              as Map--import           Control.Monad                         (join)-import           Data.ByteString                       (ByteString)-import           Data.CaseInsensitive                  (foldedCase)-import           Data.Monoid                           ((<>))-import           Data.String                           (fromString)-import           Test.QuickCheck                       (property, (.&&.), (===))-import           Test.QuickCheck.Gen                   (Gen)-import           Test.Tasty                            (TestTree, testGroup)-import           Test.Tasty.QuickCheck                 (testProperty)--import           Network.HTTP.Media.Accept-import           Network.HTTP.Media.Gen-import           Network.HTTP.Media.MediaType          ((/.), (/?))-import           Network.HTTP.Media.MediaType.Gen-import           Network.HTTP.Media.MediaType.Internal-import           Network.HTTP.Media.RenderHeader       (renderHeader)-+import 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.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 :: [TestTree] tests =-    [ testEq-    , testShow-    , testFromString-    , testHas-    , testGet-    , testMatches-    , testMoreSpecificThan-    , testParseAccept-    ]-+  [ testEq,+    testShow,+    testFromString,+    testHas,+    testGet,+    testMatches,+    testMoreSpecificThan,+    testParseAccept+  ] ------------------------------------------------------------------------------- -- Equality is derived, but we test it here to get 100% coverage. testEq :: TestTree-testEq = testGroup "Eq"+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 :: TestTree testShow = testProperty "show" $ do-    media <- genMediaType-    return $ parseAccept (BS.pack $ show media) === Just media-+  media <- genMediaType+  return $ parseAccept (BS.pack $ show media) === Just media ------------------------------------------------------------------------------- testFromString :: TestTree testFromString = testProperty "fromString" $ do-    media <- genMediaType-    return $ media === fromString (show media)-+  media <- genMediaType+  return $ media === fromString (show media) ------------------------------------------------------------------------------- testHas :: TestTree-testHas = testGroup "(/?)"+testHas =+  testGroup+    "(/?)"     [ testProperty "True for property it has" $ do         media <- genWithParams-        return $ all ((media /?) . foldedCase) (Map.keys $ parameters media)-    , testProperty "False for property it doesn't have" $ do+        return $ all ((media /?) . foldedCase) (Map.keys $ parameters media),+      testProperty "False for property it doesn't have" $ do         media <- genWithParams-        return . not $ any ((stripParams media /?) . foldedCase)+        return . not $+          any+            ((stripParams media /?) . foldedCase)             (Map.keys $ parameters media)     ] -------------------------------------------------------------------------------- testGet :: TestTree-testGet = testGroup "(/.)"+testGet =+  testGroup+    "(/.)"     [ testProperty "Retrieves property it has" $ do-        media  <- genWithParams+        media <- genWithParams         let is n v = (.&&. media /. foldedCase n === Just v)-        return $ Map.foldrWithKey is (property True) $ parameters media-    , testProperty "Nothing for property it doesn't have" $ do+        return $ Map.foldrWithKey is (property True) $ parameters media,+      testProperty "Nothing for property it doesn't have" $ do         media <- genWithParams         let is n _ = (.&&. stripParams media /. foldedCase n === Nothing)         return $ Map.foldrWithKey is (property True) $ parameters media     ] -------------------------------------------------------------------------------- testMatches :: TestTree-testMatches = testGroup "matches"+testMatches =+  testGroup+    "matches"     [ testProperty "Equal values match" $ do         media <- genMediaType-        return $ matches media media-    , testProperty "Same sub but different main don't match" $ do+        return $ matches media media,+      testProperty "Same sub but different main don't match" $ do         media <- genMaybeSubStar-        main  <- genDiffCIByteString $ mainType media-        return $ not (matches media media { mainType = main }) &&-            not (matches media { mainType = main } media)-    , testProperty "Same main but different sub don't match" $ do+        main <- genDiffCIByteString $ mainType media+        return $+          not (matches media media {mainType = main})+            && not (matches media {mainType = main} media),+      testProperty "Same main but different sub don't match" $ do         media <- genConcreteMediaType-        sub   <- genDiffCIByteString $ subType media-        return . not $ matches media media { subType = sub } ||-            matches media { subType = sub } media-    , testProperty "Different parameters don't match" $-        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" $-            (`matches` anything) <$> genMediaType-        , testProperty "Doesn't match more specific on the left" $+        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" $+        ],+      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 :: TestTree-testMoreSpecificThan = testGroup "moreSpecificThan"+testMoreSpecificThan =+  testGroup+    "moreSpecificThan"     [ testProperty "Against */*" $-        (`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+        (`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}     ] -------------------------------------------------------------------------------- testParseAccept :: TestTree-testParseAccept = testGroup "parseAccept"+testParseAccept =+  testGroup+    "parseAccept"     [ testProperty "Valid parse" $ do         media <- genMediaType         let main = mainType media-            sub  = subType media+            sub = subType media         params <- renderParameters (parameters media)         let parsed = parseAccept $ foldedCase (main <> "/" <> sub) <> params-        return $ parsed === Just media-    , testProperty "No sub" $ do+        return $ parsed === Just media,+      testProperty "No sub" $ do         bs <- genByteString-        return $ (parseAccept bs :: Maybe MediaType) === Nothing-    , testProperty "Empty main" $ do+        return $ (parseAccept bs :: Maybe MediaType) === Nothing,+      testProperty "Empty main" $ do         sep <- padString "/"-        bs  <- (sep <>) <$> genByteString-        return $ (parseAccept bs :: Maybe MediaType) === Nothing-    , testProperty "Empty sub" $ do+        bs <- (sep <>) <$> genByteString+        return $ (parseAccept bs :: Maybe MediaType) === Nothing,+      testProperty "Empty sub" $ do         sep <- padString "/"-        bs  <- (<> sep) <$> genByteString-        return $ (parseAccept bs :: Maybe MediaType) === Nothing-    , testProperty "Empty parameters" $ do+        bs <- (<> sep) <$> genByteString+        return $ (parseAccept bs :: Maybe MediaType) === Nothing,+      testProperty "Empty parameters" $ do         sep <- padString ";"-        bs  <- renderHeader <$> genWithoutParams-        return $ (parseAccept (bs <> sep) :: Maybe MediaType) === Nothing-    , testProperty "No value" $-        (=== Nothing) <$> genMediaNameAndParams ""-    , testProperty "Empty value" $ do+        bs <- renderHeader <$> genWithoutParams+        return $ (parseAccept (bs <> sep) :: Maybe MediaType) === Nothing,+      testProperty "No value" $+        (=== Nothing) <$> genMediaNameAndParams "",+      testProperty "Empty value" $ do         eq <- padString "="         (=== Nothing) <$> genMediaNameAndParams eq     ]  genMediaNameAndParams :: ByteString -> Gen (Maybe MediaType) genMediaNameAndParams eq = do-    sep  <- padString ";"-    bs   <- renderHeader <$> genByteString-    name <- genByteString-    ps   <- genMaybeParameters >>= renderParameters-    return $ parseAccept (bs <> sep <> name <> eq <> sep <> ps)-+  sep <- padString ";"+  bs <- renderHeader <$> genByteString+  name <- genByteString+  ps <- genMaybeParameters >>= renderParameters+  return $ parseAccept (bs <> sep <> name <> eq <> sep <> ps) ------------------------------------------------------------------------------- -- | Like 'join', but applies the given function to the first argument. dotJoin :: (a -> a -> b) -> (a -> a) -> a -> b dotJoin f g a = f (g a) a

@@ -1,53 +1,52 @@ {-# LANGUAGE TupleSections #-} ------------------------------------------------------------------------------- module Network.HTTP.Media.Tests (tests) where -import           Control.Monad                         (join, replicateM, (>=>))-import           Data.Foldable                         (foldlM)-import           Data.Function                         (on)-import           Data.List                             (nubBy)-import           Data.Map                              (empty)-import           Data.Monoid                           ((<>))-import           Data.Word                             (Word16)-import           Test.QuickCheck-import           Test.Tasty                            (TestTree, testGroup)-import           Test.Tasty.QuickCheck                 (testProperty)--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 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 :: [TestTree] tests =-    [ testParse-    , testMatchAccept-    , testMapAccept-    , testMatchContent-    , testMapContent-    , testMatchQuality-    , testMapQuality-    ]-+  [ testParse,+    testMatchAccept,+    testMapAccept,+    testMatchContent,+    testMapContent,+    testMatchQuality,+    testMapQuality+  ] ------------------------------------------------------------------------------- testParse :: TestTree-testParse = testGroup "parseQuality"+testParse =+  testGroup+    "parseQuality"     [ testProperty "Without quality" $ do-        media    <- medias+        media <- medias         rendered <- padConcat (return . renderHeader) media-        return $ parseQuality rendered === Just (map maxQuality media)-    , testProperty "With quality" $ do-        media    <- qualities+        return $ parseQuality rendered === Just (map maxQuality media),+      testProperty "With quality" $ do+        media <- qualities         rendered <- padConcat padQuality media-        return $ parseQuality rendered === Just media-    , testProperty "With extensions" $ do-        media    <- qualities+        return $ parseQuality rendered === Just media,+      testProperty "With extensions" $ do+        media <- qualities         rendered <- padConcat (padQuality >=> padExtensions) media         return $ parseQuality rendered === Just media     ]@@ -57,194 +56,190 @@     padConcat f l = flip (foldlM (padComma f)) (tail l) =<< f (head l)     padComma f a b = pad a <$> padString "," <*> f b     padQuality qMedia = do-        semi <- padString ";"-        let d = renderHeader (qualityData qMedia)-            v = showQ (qualityValue qMedia)-        return $ d <> semi <> "q=" <> v+      semi <- padString ";"+      let d = renderHeader (qualityData qMedia)+          v = showQ (qualityValue qMedia)+      return $ d <> semi <> "q=" <> v     padExtensions s = genParameters >>= fmap (s <>) . renderParameters     pad a s b = a <> s <> b -------------------------------------------------------------------------------- testMatchAccept :: TestTree testMatchAccept = testMatch "Accept" matchAccept renderHeader -------------------------------------------------------------------------------- testMapAccept :: TestTree testMapAccept = testMap "Accept" mapAccept renderHeader -------------------------------------------------------------------------------- testMatchContent :: TestTree-testMatchContent = testGroup "matchContent"+testMatchContent =+  testGroup+    "matchContent"     [ testProperty "Matches" $ do         media <- genMediaType-        return $ matchContent [media] (renderHeader media) === Just media-    , testProperty "Nothing" $ do+        return $ matchContent [media] (renderHeader media) === Just media,+      testProperty "Nothing" $ do         content <- genMediaType         parsers <- filter (not . matches content) <$> genServer-        return $ matchContent parsers (renderHeader content) === Nothing-    , testProperty "Against */*" $ do+        return $ matchContent parsers (renderHeader content) === Nothing,+      testProperty "Against */*" $ do         media <- genMediaType         return $-            matchContent [anything] (renderHeader media) === Just anything-    , testProperty "Against type/*" $ do+          matchContent [anything] (renderHeader media) === Just anything,+      testProperty "Against type/*" $ do         media <- genMediaType         let sub = subStarOf media         return $ matchContent [sub] (renderHeader media) === Just sub     ] -------------------------------------------------------------------------------- testMapContent :: TestTree-testMapContent = testGroup "mapContent"+testMapContent =+  testGroup+    "mapContent"     [ testProperty "Matches" $ do         media <- genMediaType-        return $ mapContent [(media, ())] (renderHeader media) === Just ()-    , testProperty "Nothing" $ do+        return $ mapContent [(media, ())] (renderHeader media) === Just (),+      testProperty "Nothing" $ do         content <- genMediaType         parsers <- join zip . filter (not . matches content) <$> genServer-        return $ mapContent parsers (renderHeader content) === Nothing+        return $ mapContent parsers (renderHeader content) === Nothing,+      testProperty "Overlapping keys" $ do+        (a, b) <- genMatchingPair+        return $ mapContent [(a, False), (b, True)] (renderHeader b)     ] -------------------------------------------------------------------------------- testMatchQuality :: TestTree testMatchQuality = testMatch "Quality" matchQuality id -------------------------------------------------------------------------------- testMapQuality :: TestTree testMapQuality = testMap "Quality" mapQuality id ---------------------------------------------------------------------------------testMatch-    :: String-    -> ([MediaType] -> a -> Maybe MediaType)-    -> ([Quality MediaType] -> a)-    -> TestTree-testMatch name match qToI = testGroup ("match" ++ name)+testMatch ::+  String ->+  ([MediaType] -> a -> Maybe MediaType) ->+  ([Quality MediaType] -> a) ->+  TestTree+testMatch name match qToI =+  testGroup+    ("match" ++ name)     [ testProperty "Most specific" $ do         media <- genConcreteMediaType-        let client = qToI $ map maxQuality-                [ MediaType "*" "*" empty-                , media { subType = "*" }-                , media { parameters = empty }-                , media-                ]-        return $ match [media] client === Just media-    , testProperty "Nothing" $ do+        let client =+              qToI $+                map+                  maxQuality+                  [ MediaType "*" "*" empty,+                    media {subType = "*"},+                    media {parameters = empty},+                    media+                  ]+        return $ match [media] client === Just media,+      testProperty "Nothing" $ do         client <- listOf1 genConcreteMediaType         server <- filter (not . flip any client . matches) <$> genServer-        return $ match server (qToI $ map maxQuality client) === Nothing-    , testProperty "Left biased" $ do+        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+        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+        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+        return $ match server client === Just (head server),+      testQuality match qToI     ] ---------------------------------------------------------------------------------testQuality-    :: ([MediaType] -> a -> Maybe MediaType)-    -> ([Quality MediaType] -> a)-    -> TestTree-testQuality match qToI = testGroup "Quality"+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 quality" $ do+        return $+          match server (qToI client)+            === Just (qualityData $ foldr1 qmax client),+      testProperty "Most specific quality" $ do         (a, b) <- genMatchingPair-        c      <- genDiffMediaType a+        c <- genDiffMediaType a         let client = qToI [quality a "0.5", maxQuality b, maxQuality c]-        return $ match [a, c] client === Just c-    , testQ0 match qToI+        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"+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+        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+        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+        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+        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+        return $ match [server] client === Nothing,+      testProperty "Does not choose q=0 when preceded by same type" $ do         server <- genConcreteMediaType         let client = qToI [maxQuality server, minQuality server]         return $ match [server] client === Nothing     ] ---------------------------------------------------------------------------------testMap-    :: String-    -> ([(MediaType, MediaType)] -> a -> Maybe MediaType)-    -> ([Quality MediaType] -> a)-    -> TestTree-testMap name mapf qToI = testGroup ("map" ++ name)+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 = map (, "*/*") server+        let zipped = map (,"*/*") server         return $ mapf zipped (qToI $ map maxQuality client) === Nothing     ] -------------------------------------------------------------------------------- genServer :: Gen [MediaType] genServer = listOf1 genConcreteMediaType -------------------------------------------------------------------------------- genNubServer :: Gen [MediaType] genNubServer = nubBy (on (==) stripParams) <$> genServer -------------------------------------------------------------------------------- genServerAndClient :: Gen ([MediaType], [MediaType]) genServerAndClient = do-    server <- genServer-    client <- filter (not . flip any server . flip matches) <$>-        listOf1 (genDiffMediaTypesWith genConcreteMediaType server)-    return (server, client)+  server <- genServer+  client <-+    filter (not . flip any server . flip matches)+      <$> listOf1 (genDiffMediaTypesWith genConcreteMediaType server)+  return (server, client)

@@ -1,23 +1,22 @@------------------------------------------------------------------------------- module Main (main) where -import           Test.Tasty                         (defaultMain, testGroup)--import qualified Network.HTTP.Media.Accept.Tests    as Accept-import qualified Network.HTTP.Media.Charset.Tests   as Charset-import qualified Network.HTTP.Media.Encoding.Tests  as Encoding-import qualified Network.HTTP.Media.Language.Tests  as Language+import qualified Network.HTTP.Media.Accept.Tests as Accept+import qualified Network.HTTP.Media.Charset.Tests as Charset+import qualified Network.HTTP.Media.Encoding.Tests as Encoding+import qualified Network.HTTP.Media.Language.Tests as Language import qualified Network.HTTP.Media.MediaType.Tests as MediaType-import qualified Network.HTTP.Media.Tests           as Media-+import qualified Network.HTTP.Media.Tests as Media+import Test.Tasty (defaultMain, testGroup) ------------------------------------------------------------------------------- main :: IO ()-main = defaultMain $ testGroup "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-    ]+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+      ]