packages feed

http-media 0.7.1.3 → 0.8.1.1

raw patch · 27 files changed

Files

CHANGES.md view
@@ -1,6 +1,41 @@ Changelog ========= +- [Version 0.8.1.1](https://github.com/zmthy/http-media/releases/tag/v0.8.1.1)++  Fixed a bug when mapping againt a client-side content header where a+  match would be overridden by a more specific key earlier in the map.++  The bounds for tasty have been updated to include the latest version.++- [Version 0.8.1.0](https://github.com/zmthy/http-media/releases/tag/v0.8.1.0)++  Exposed `qualityData` accessor.++  Added `isAcceptable` to allow filtering out unacceptable items.++- [Version 0.8.0.0](https://github.com/zmthy/http-media/releases/tag/v0.8.0.0)++  Removed official support for GHC 7.8.++  A separate `QualityOrder` type can now be extracted from a `Quality`+  value for performing comparisons without the attached data value.++  The most specific match will now be used to assign a quality value to+  each server option, ensuring that less specific matches cannot+  override lower quality values on more specific matches. In particular,+  if a type is considered unacceptable by the client, then a separate+  match with a non-zero quality value cannot make it acceptable.++  Numeric characters are now permitted in the tail of a Language value.++  Added support for Accept-Encoding and Content-Encoding.++  Added support for Accept-Charset and Content-Charset.++  The bounds for QuickCheck have been updated to include the latest+  version.+ - [Version 0.7.1.3](https://github.com/zmthy/http-media/releases/tag/v0.7.1.3)    Package bounds have been updated for GHC 8.6.
http-media.cabal view
@@ -1,15 +1,23 @@ name:          http-media-version:       0.7.1.3+version:       0.8.1.1 license:       MIT license-file:  LICENSE author:        Timothy Jones maintainer:    Timothy Jones <tim@zmthy.net> homepage:      https://github.com/zmthy/http-media bug-reports:   https://github.com/zmthy/http-media/issues-copyright:     (c) 2012-2017 Timothy Jones+copyright:     (c) 2012-2023 Timothy Jones category:      Web build-type:    Simple cabal-version: >= 1.10+tested-with:+    GHC == 8.6.5+  , GHC == 8.8.4+  , GHC == 8.10.7+  , GHC == 9.0.2+  , GHC == 9.2.8+  , GHC == 9.4.5+  , GHC == 9.6.2 synopsis:      Processing HTTP Content-Type and Accept headers description:   This library is intended to be a comprehensive solution to parsing and@@ -53,25 +61,26 @@   default-extensions:     OverloadedStrings -  other-extensions:-    CPP-   exposed-modules:     Network.HTTP.Media     Network.HTTP.Media.Accept+    Network.HTTP.Media.Charset+    Network.HTTP.Media.Encoding     Network.HTTP.Media.Language     Network.HTTP.Media.MediaType     Network.HTTP.Media.RenderHeader    other-modules:+    Network.HTTP.Media.Charset.Internal+    Network.HTTP.Media.Encoding.Internal     Network.HTTP.Media.Language.Internal     Network.HTTP.Media.MediaType.Internal     Network.HTTP.Media.Quality     Network.HTTP.Media.Utils    build-depends:-    base             >= 4.7  && < 4.13,-    bytestring       >= 0.10 && < 0.11,+    base             >= 4.8  && < 5,+    bytestring       >= 0.10 && < 0.12,     case-insensitive >= 1.0  && < 1.3,     containers       >= 0.5  && < 0.7,     utf8-string      >= 0.3  && < 1.1@@ -92,14 +101,21 @@     OverloadedStrings    other-extensions:-    CPP     TupleSections    other-modules:     Network.HTTP.Media     Network.HTTP.Media.Accept     Network.HTTP.Media.Accept.Tests+    Network.HTTP.Media.Charset+    Network.HTTP.Media.Charset.Gen+    Network.HTTP.Media.Charset.Internal+    Network.HTTP.Media.Charset.Tests     Network.HTTP.Media.Gen+    Network.HTTP.Media.Encoding+    Network.HTTP.Media.Encoding.Gen+    Network.HTTP.Media.Encoding.Internal+    Network.HTTP.Media.Encoding.Tests     Network.HTTP.Media.Language     Network.HTTP.Media.Language.Gen     Network.HTTP.Media.Language.Internal@@ -114,14 +130,14 @@     Network.HTTP.Media.Utils    build-depends:-    base                       >= 4.7  && < 4.13,-    bytestring                 >= 0.10 && < 0.11,-    case-insensitive           >= 1.0  && < 1.3,-    containers                 >= 0.5  && < 0.7,-    utf8-string                >= 0.3  && < 1.1,-    QuickCheck                 >= 2.6  && < 2.13,-    test-framework             >= 0.8  && < 0.9,-    test-framework-quickcheck2 >= 0.3  && < 0.4+    base             >= 4.8  && < 5,+    bytestring       >= 0.10 && < 0.12,+    case-insensitive >= 1.0  && < 1.3,+    containers       >= 0.5  && < 0.7,+    utf8-string      >= 0.3  && < 1.1,+    QuickCheck       >= 2.8  && < 2.15,+    tasty            >= 0.11 && < 1.6,+    tasty-quickcheck >= 0.8  && < 0.11  source-repository head   type:     git
src/Network/HTTP/Media.hs view
@@ -1,74 +1,79 @@-{-# LANGUAGE CPP #-}-------------------------------------------------------------------------------- -- | A framework for parsing HTTP media type headers. module Network.HTTP.Media-    (-    -- * Media types-      MediaType-    , (//)-    , (/:)-    , mainType-    , subType-    , parameters-    , (/?)-    , (/.)+  ( -- * Media types+    MediaType,+    (//),+    (/:),+    mainType,+    subType,+    parameters,+    (/?),+    (/.), +    -- * Charsets+    Charset,++    -- * Encodings+    Encoding,+     -- * Languages-    , Language-    , toParts+    Language,+    toParts,      -- * Accept matching-    , matchAccept-    , mapAccept-    , mapAcceptMedia-    , mapAcceptLanguage-    , mapAcceptBytes+    matchAccept,+    mapAccept,+    mapAcceptMedia,+    mapAcceptCharset,+    mapAcceptEncoding,+    mapAcceptLanguage,+    mapAcceptBytes,      -- * Content matching-    , matchContent-    , mapContent-    , mapContentMedia-    , mapContentLanguage+    matchContent,+    mapContent,+    mapContentMedia,+    mapContentCharset,+    mapContentEncoding,+    mapContentLanguage,      -- * Quality values-    , Quality-    , quality-    , maxQuality-    , minQuality-    , parseQuality-    , matchQuality-    , mapQuality+    Quality (qualityData),+    quality,+    QualityOrder,+    qualityOrder,+    isAcceptable,+    maxQuality,+    minQuality,+    parseQuality,+    matchQuality,+    mapQuality,      -- * Accept-    , Accept (..)+    Accept (..),      -- * Rendering-    , RenderHeader (..)-    ) where--#if MIN_VERSION_base(4, 8, 0)-import           Control.Applicative             ((<|>))-#else-import           Control.Applicative             (pure, (<$>), (<*>), (<|>))-#endif--import qualified Data.ByteString.Char8           as BS--import           Control.Monad                   (guard, (>=>))-import           Data.ByteString                 (ByteString)-import           Data.Maybe                      (fromMaybe)-import           Data.Proxy                      (Proxy (Proxy))--import           Network.HTTP.Media.Accept       as Accept-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@@ -82,15 +87,15 @@ -- > matchAccept ["text/html", "application/json"] <$> getHeader -- -- For more information on the matching process see RFC 2616, section 14.1-4.-matchAccept-    :: Accept a-    => [a]         -- ^ The server-side options-    -> ByteString  -- ^ The client-side header value-    -> Maybe a+matchAccept ::+  (Accept a) =>+  -- | The server-side options+  [a] ->+  -- | The client-side header value+  ByteString ->+  Maybe a matchAccept = (parseQuality >=>) . matchQuality -------------------------------------------------------------------------------- -- | The equivalent of 'matchAccept' above, except the resulting choice is -- mapped to another value. Convenient for specifying how to translate the -- resource into each of its available formats.@@ -99,15 +104,15 @@ -- >     [ ("text" // "html",        asHtml) -- >     , ("application" // "json", asJson) -- >     ]-mapAccept-    :: Accept a-    => [(a, b)]    -- ^ The map of server-side preferences to values-    -> ByteString  -- ^ The client-side header value-    -> Maybe b+mapAccept ::+  (Accept a) =>+  -- | The map of server-side preferences to values+  [(a, b)] ->+  -- | The client-side header value+  ByteString ->+  Maybe b mapAccept = (parseQuality >=>) . mapQuality -------------------------------------------------------------------------------- -- | A specialisation of 'mapAccept' that only takes 'MediaType' as its input, -- to avoid ambiguous-type errors when using string literal overloading. --@@ -116,44 +121,74 @@ -- >     , ("application/json", asJson) -- >     ] mapAcceptMedia ::-    [(MediaType, b)]  -- ^ The map of server-side preferences to values-    -> ByteString     -- ^ The client-side header value-    -> Maybe b+  -- | The map of server-side preferences to values+  [(MediaType, b)] ->+  -- | The client-side header value+  ByteString ->+  Maybe b mapAcceptMedia = mapAccept +-- | A specialisation of 'mapAccept' that only takes 'Charset' as its input,+-- to avoid ambiguous-type errors when using string literal overloading.+--+-- > getHeader >>= maybe render406Error renderResource . mapAcceptCharset+-- >     [ ("utf-8",    inUtf8)+-- >     , ("us-ascii", inAscii)+-- >     ]+mapAcceptCharset ::+  -- | The map of server-side preferences to values+  [(Charset, b)] ->+  -- | The client-side header value+  ByteString ->+  Maybe b+mapAcceptCharset = mapAccept -------------------------------------------------------------------------------+-- | A specialisation of 'mapAccept' that only takes 'Encoding' as its input,+-- to avoid ambiguous-type errors when using string literal overloading.+--+-- > getHeader >>= maybe render406Error renderResource . mapAcceptEncoding+-- >     [ ("compress", compress)+-- >     , ("identity", id)+-- >     ]+mapAcceptEncoding ::+  -- | The map of server-side preferences to values+  [(Encoding, b)] ->+  -- | The client-side header value+  ByteString ->+  Maybe b+mapAcceptEncoding = mapAccept+ -- | A specialisation of 'mapAccept' that only takes 'Language' as its input, -- to avoid ambiguous-type errors when using string literal overloading. -- -- > getHeader >>= maybe render406Error renderResource . mapAcceptLanguage--- >     [ ("text/html",        asHtml)--- >     , ("application/json", asJson)+-- >     [ ("en-gb", inBritishEnglish)+-- >     , ("fr",    inFrench) -- >     ] mapAcceptLanguage ::-    [(Language, b)]  -- ^ The map of server-side preferences to values-    -> ByteString    -- ^ The client-side header value-    -> Maybe b+  -- | The map of server-side preferences to values+  [(Language, b)] ->+  -- | The client-side header value+  ByteString ->+  Maybe b mapAcceptLanguage = mapAccept -------------------------------------------------------------------------------- -- | A specialisation of 'mapAccept' that only takes 'ByteString' as its -- input, to avoid ambiguous-type errors when using string literal -- overloading. -- -- > getHeader >>= maybe render406Error encodeResourceWith . mapAcceptBytes--- >     [ ("compress", compress)--- >     , ("gzip",     gzip)+-- >     [ ("abc", abc)+-- >     , ("xyz", xyz) -- >     ] mapAcceptBytes ::-    [(ByteString, b)]  -- ^ The map of server-side preferences to values-    -> ByteString      -- ^ The client-side header value-    -> Maybe b+  -- | The map of server-side preferences to values+  [(ByteString, b)] ->+  -- | The client-side header value+  ByteString ->+  Maybe b mapAcceptBytes = mapAccept -------------------------------------------------------------------------------- -- | Matches a list of server-side parsing options against a the client-side -- content value. A result of 'Nothing' means that nothing matched (which -- should indicate a 415 error).@@ -161,19 +196,15 @@ -- > matchContent ["application/json", "text/plain"] <$> getContentType -- -- For more information on the matching process see RFC 2616, section 14.17.-matchContent-    :: Accept a-    => [a]         -- ^ The server-side response options-    -> ByteString  -- ^ The client's request value-    -> Maybe a-matchContent options ctype = foldl choose Nothing options-  where-    choose m server = m <|> do-        parseAccept ctype >>= guard . (`matches` server)-        Just server-+matchContent ::+  (Accept a) =>+  -- | The server-side response options+  [a] ->+  -- | The client's request value+  ByteString ->+  Maybe a+matchContent = findMatch id ------------------------------------------------------------------------------- -- | The equivalent of 'matchContent' above, except the resulting choice is -- mapped to another value. --@@ -181,16 +212,15 @@ -- >     [ ("application" // "json", parseJson) -- >     , ("text" // "plain",       parseText) -- >     ]-mapContent-    :: Accept a-    => [(a, b)]    -- ^ The map of server-side responses-    -> ByteString  -- ^ The client request's header value-    -> Maybe b-mapContent options ctype =-    matchContent (map fst options) ctype >>= lookupMatches options-+mapContent ::+  (Accept a) =>+  -- | The map of server-side responses+  [(a, b)] ->+  -- | The client request's header value+  ByteString ->+  Maybe b+mapContent options = fmap snd . findMatch fst options ------------------------------------------------------------------------------- -- | A specialisation of 'mapContent' that only takes 'MediaType' as its -- input, to avoid ambiguous-type errors when using string literal -- overloading.@@ -200,57 +230,93 @@ -- >         [ ("application/json", parseJson) -- >         , ("text/plain",       parseText) -- >         ]-mapContentMedia-    :: [(MediaType, b)]  -- ^ The map of server-side responses-    -> ByteString        -- ^ The client request's header value-    -> Maybe b+mapContentMedia ::+  -- | The map of server-side responses+  [(MediaType, b)] ->+  -- | The client request's header value+  ByteString ->+  Maybe b mapContentMedia = mapContent +-- | A specialisation of 'mapContent' that only takes 'Charset' as its input,+-- to avoid ambiguous-type errors when using string literal overloading.+--+-- > getContentCharset >>=+-- >     maybe send415Error readRequestBodyWith . mapContentCharset+-- >         [ ("utf-8",    parseUtf8)+-- >         , ("us-ascii", parseAscii)+-- >         ]+mapContentCharset ::+  -- | The map of server-side responses+  [(Charset, b)] ->+  -- | The client request's header value+  ByteString ->+  Maybe b+mapContentCharset = mapContent -------------------------------------------------------------------------------+-- | A specialisation of 'mapContent' that only takes 'Encoding' as its input,+-- to avoid ambiguous-type errors when using string literal overloading.+--+-- > getContentEncoding >>=+-- >     maybe send415Error readRequestBodyWith . mapContentEncoding+-- >         [ ("compress", decompress)+-- >         , ("identity", id)+-- >         ]+mapContentEncoding ::+  -- | The map of server-side responses+  [(Encoding, b)] ->+  -- | The client request's header value+  ByteString ->+  Maybe b+mapContentEncoding = mapContent+ -- | A specialisation of 'mapContent' that only takes 'Language' as its input, -- to avoid ambiguous-type errors when using string literal overloading. ----- > getContentType >>=+-- > getContentLanguage >>= -- >     maybe send415Error readRequestBodyWith . mapContentLanguage--- >         [ ("application/json", parseJson)--- >         , ("text/plain",       parseText)+-- >         [ ("en-gb", parseBritishEnglish)+-- >         , ("fr",    parseFrench) -- >         ]-mapContentLanguage-    :: [(Language, b)]  -- ^ The map of server-side responses-    -> ByteString        -- ^ The client request's header value-    -> Maybe b+mapContentLanguage ::+  -- | The map of server-side responses+  [(Language, b)] ->+  -- | The client request's header value+  ByteString ->+  Maybe b mapContentLanguage = mapContent -------------------------------------------------------------------------------- -- | Parses a full Accept header into a list of quality-valued media types.-parseQuality :: Accept a => ByteString -> Maybe [Quality a]+parseQuality :: (Accept a) => ByteString -> Maybe [Quality a] parseQuality = parseQuality' Proxy -parseQuality' :: Accept a => Proxy a -> ByteString -> Maybe [Quality a]-parseQuality' p = (. map trimBS . BS.split ',') . mapM $ \ s ->-    let (accept, q) = fromMaybe (s, Nothing) $ if ext then findQ s else getQ s-    in maybe (pure maxQuality) (fmap (flip Quality) . readQ) q <*>-        parseAccept accept+parseQuality' :: (Accept a) => Proxy a -> ByteString -> Maybe [Quality a]+parseQuality' p = (. map trimBS . BS.split ',') . mapM $ \s ->+  let (accept, q) = fromMaybe (s, Nothing) $ if ext then findQ s else getQ s+   in maybe (pure maxQuality) (fmap (flip Quality) . readQ) q+        <*> parseAccept accept   where     ext = hasExtensionParameters p      -- Split on ';', and check if a quality value is there. A value of Nothing     -- indicates there was no parameter, whereas a value of Nothing in the     -- pair indicates the parameter was not a quality value.-    getQ s = let (a, b) = trimBS <$> BS.breakEnd (== ';') s in-        if BS.null a then Nothing else Just (BS.init a,-            if BS.isPrefixOf "q=" b then Just (BS.drop 2 b) else Nothing)+    getQ s =+      let (a, b) = trimBS <$> BS.breakEnd (== ';') s+       in if BS.null a+            then Nothing+            else+              Just+                ( BS.init a,+                  if BS.isPrefixOf "q=" b then Just (BS.drop 2 b) else Nothing+                )      -- Trawl backwards through the string, ignoring extension parameters.     findQ s = do-        let q = getQ s-        (a, m) <- q-        maybe (findQ a) (const q) m-+      let q = getQ s+      (a, m) <- q+      maybe (findQ a) (const q) m ------------------------------------------------------------------------------- -- | Matches a list of server-side resource options against a pre-parsed -- quality-marked list of client-side preferences. A result of 'Nothing' means -- that nothing matched (which should indicate a 406 error). If two or more@@ -264,26 +330,15 @@ -- > matchQuality ["text/html", "application/json"] <$> parseQuality header -- -- For more information on the matching process see RFC 2616, section 14.1-4.-matchQuality-    :: Accept a-    => [a]          -- ^ The server-side options-    -> [Quality a]  -- ^ The pre-parsed client-side header value-    -> Maybe a-matchQuality options acceptq = do-    let merge (Quality c q) = map (`Quality` q) $ filter (`matches` c) options-        matched = concatMap merge acceptq-        (hq, qs) = foldr qfold (0, []) matched-        qfold (Quality v q) (mq, vs) = case compare q mq of-            GT -> (q, [v])-            EQ -> (mq, v : vs)-            LT -> (mq, vs)-        specific (a : ms) = Just $ foldl mostSpecific a ms-        specific []       = Nothing-    guard (hq /= 0)-    specific qs-+matchQuality ::+  (Accept a) =>+  -- | The server-side options+  [a] ->+  -- | The pre-parsed client-side header value+  [Quality a] ->+  Maybe a+matchQuality = findQuality id ------------------------------------------------------------------------------- -- | The equivalent of 'matchQuality' above, except the resulting choice is -- mapped to another value. Convenient for specifying how to translate the -- resource into each of its available formats.@@ -292,19 +347,34 @@ -- >     [ ("text" // "html",        asHtml) -- >     , ("application" // "json", asJson) -- >     ]-mapQuality-    :: Accept a-    => [(a, b)]     -- ^ The map of server-side preferences to values-    -> [Quality a]  -- ^ The client-side header value-    -> Maybe b-mapQuality options accept =-    matchQuality (map fst options) accept >>= lookupMatches options+mapQuality ::+  (Accept a) =>+  -- | The map of server-side preferences to values+  [(a, b)] ->+  -- | The client-side header value+  [Quality a] ->+  Maybe b+mapQuality options = fmap snd . findQuality fst options +-- | Find a match in a list of options against a ByteString using an 'Accept'+-- instance obtained by mapping the options to another type.+findMatch :: (Accept b) => (a -> b) -> [a] -> ByteString -> Maybe a+findMatch f options bs = do+  ctype <- parseAccept bs+  find (matches ctype . f) options ---------------------------------------------------------------------------------- | The equivalent of 'lookupBy matches'.-lookupMatches :: Accept a => [(a, b)] -> a -> Maybe b-lookupMatches ((k, v) : r) a-    | Accept.matches k a = Just v-    | otherwise         = lookupMatches r a-lookupMatches [] _ = Nothing+-- | Find a quality match between a list of options and a quality-marked list+-- of a different type, by mapping the type of the former to the latter.+findQuality :: (Accept a) => (b -> a) -> [b] -> [Quality a] -> Maybe b+findQuality f options acceptq = do+  guard $ not (null options)+  q <- maximumBy (compare `on` fmap qualityOrder) optionsq+  guard $ isAcceptable q+  return $ qualityData q+  where+    optionsq = reverse $ map addQuality options+    addQuality opt = withQValue opt <$> foldl' (mfold opt) Nothing acceptq+    withQValue opt q = q {qualityData = opt}+    mfold opt cur q+      | f opt `matches` qualityData q = mostSpecific q <$> cur <|> Just q+      | otherwise = cur
src/Network/HTTP/Media/Accept.hs view
@@ -1,65 +1,52 @@------------------------------------------------------------------------------- -- | Defines the 'Accept' type class, designed to unify types on the matching -- functions in the Media module. module Network.HTTP.Media.Accept-    ( Accept (..)-    , mostSpecific-    ) where+  ( 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------------------------------------------------------------------------------------ | Evaluates to whichever argument is more specific. Left biased.-mostSpecific :: Accept a => a -> a -> a-mostSpecific a b-    | b `moreSpecificThan` a = b-    | otherwise              = a+  parseAccept = Just+  matches a b = CI.mk a == CI.mk b+  moreSpecificThan _ _ = False
+ src/Network/HTTP/Media/Charset.hs view
@@ -0,0 +1,5 @@+-- | Defines the 'Charset' accept header with an 'Accept' instance for use in+-- encoding negotiation.+module Network.HTTP.Media.Charset (Charset) where++import Network.HTTP.Media.Charset.Internal
+ src/Network/HTTP/Media/Charset/Internal.hs view
@@ -0,0 +1,49 @@+-- | Defines the 'Charset' accept header with an 'Accept' instance for use in+-- language negotiation.+module Network.HTTP.Media.Charset.Internal+  ( Charset (..),+  )+where++import Control.Monad (guard)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.CaseInsensitive (CI, original)+import qualified Data.CaseInsensitive as CI+import Data.Maybe (fromMaybe)+import Data.String (IsString (..))+import Network.HTTP.Media.Accept (Accept (..))+import Network.HTTP.Media.RenderHeader (RenderHeader (..))+import Network.HTTP.Media.Utils (isValidToken)++-- | Suitable for HTTP charset as defined in+-- <https://tools.ietf.org/html/rfc7231#section-5.3.3 RFC7231>.+--+-- Specifically:+--+-- > charset = token / "*"+newtype Charset = Charset (CI ByteString)+  deriving (Eq, Ord)++instance Show Charset where+  show = BS.unpack . renderHeader++instance IsString Charset where+  fromString str =+    flip fromMaybe (parseAccept $ BS.pack str) $+      error $+        "Invalid encoding literal " ++ str++instance Accept Charset where+  parseAccept bs = do+    guard $ isValidToken bs+    return $ Charset (CI.mk bs)++  matches _ (Charset "*") = True+  matches a b = a == b++  moreSpecificThan _ (Charset "*") = True+  moreSpecificThan _ _ = False++instance RenderHeader Charset where+  renderHeader (Charset e) = original e
+ src/Network/HTTP/Media/Encoding.hs view
@@ -0,0 +1,5 @@+-- | Defines the 'Encoding' accept header with an 'Accept' instance for use in+-- encoding negotiation.+module Network.HTTP.Media.Encoding (Encoding) where++import Network.HTTP.Media.Encoding.Internal
+ src/Network/HTTP/Media/Encoding/Internal.hs view
@@ -0,0 +1,52 @@+-- | Defines the 'Encoding' accept header with an 'Accept' instance for use in+-- language negotiation.+module Network.HTTP.Media.Encoding.Internal+  ( Encoding (..),+  )+where++import Control.Monad (guard)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.CaseInsensitive (CI, original)+import qualified Data.CaseInsensitive as CI+import Data.Maybe (fromMaybe)+import Data.String (IsString (..))+import Network.HTTP.Media.Accept (Accept (..))+import Network.HTTP.Media.RenderHeader (RenderHeader (..))+import Network.HTTP.Media.Utils (isValidToken)++-- | Suitable for HTTP encoding as defined in+-- <https://tools.ietf.org/html/rfc7231#section-5.3.4 RFC7231>.+--+-- Specifically:+--+-- > codings = content-coding / "identity" / "*"+newtype Encoding = Encoding (CI ByteString)+  deriving (Eq, Ord)++instance Show Encoding where+  show = BS.unpack . renderHeader++instance IsString Encoding where+  fromString str =+    flip fromMaybe (parseAccept $ BS.pack str) $+      error $+        "Invalid encoding literal " ++ str++instance Accept Encoding where+  -- This handles the case where the header value is empty, but it also+  -- allows technically invalid values such as "compress;q=0.8,;q=0.5".+  parseAccept "" = Just $ Encoding "identity"+  parseAccept bs = do+    guard $ isValidToken bs+    return $ Encoding (CI.mk bs)++  matches _ (Encoding "*") = True+  matches a b = a == b++  moreSpecificThan _ (Encoding "*") = True+  moreSpecificThan _ _ = False++instance RenderHeader Encoding where+  renderHeader (Encoding e) = original e
src/Network/HTTP/Media/Language.hs view
@@ -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]
src/Network/HTTP/Media/Language/Internal.hs view
@@ -1,71 +1,67 @@-{-# LANGUAGE CPP #-}-------------------------------------------------------------------------------- -- | Defines the 'Language' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Language.Internal-    ( Language (..)-    ) where--#if !MIN_VERSION_base(4, 8, 0)-import           Data.Functor                    ((<$>))-#endif--import qualified Data.ByteString.Char8           as BS-import qualified Data.CaseInsensitive            as CI--import           Control.Monad                   (guard)-import           Data.ByteString                 (ByteString)-import           Data.CaseInsensitive            (CI, original)-import           Data.Char                       (isAlpha)-import           Data.List                       (isPrefixOf)-import           Data.Maybe                      (fromMaybe)-import           Data.String                     (IsString (..))--import           Network.HTTP.Media.Accept       (Accept (..))-import           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--- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.4 RFC2616>.+-- <https://tools.ietf.org/html/rfc4647#section-2.1 RFC4647>. -- -- Specifically: ----- > language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" )+-- > language-range = (1*8ALPHA *("-" 1*8alphanum)) / "*" newtype Language = Language [CI ByteString]-    deriving (Eq, Ord)+  deriving (Eq, Ord)  -- Note that internally, Language [] equates to *.  instance Show Language where-    show = BS.unpack . renderHeader+  show = BS.unpack . renderHeader  instance IsString Language where-    fromString "*" = Language []-    fromString str = flip fromMaybe (parseAccept $ BS.pack str) $-        error $ "Invalid language literal " ++ str+  fromString "*" = Language []+  fromString str =+    flip fromMaybe (parseAccept $ BS.pack str) $+      error $+        "Invalid language literal " ++ str  instance Accept Language where-    parseAccept "*" = Just $ Language []-    parseAccept bs = do-        let pieces = BS.split '-' bs-        guard $ not (null pieces)-        Language <$> mapM check pieces-      where-        check part = do-            let len = BS.length part-            guard $ len >= 1 && len <= 8 && BS.all isAlpha part-            return (CI.mk part)+  parseAccept "*" = Just $ Language []+  parseAccept bs = do+    let pieces = BS.split '-' bs+    guard $ not (null pieces)+    Language <$> mapM check pieces+    where+      check part = do+        let len = BS.length part+        guard $+          len >= 1+            && len <= 8+            && isAlpha (BS.head part)+            && BS.all isAlphaNum (BS.tail part)+        return (CI.mk part) -    -- Languages match if the right argument is a prefix of the left.-    matches (Language a) (Language b)  = b `isPrefixOf` a+  -- Languages match if the right argument is a prefix of the left.+  matches (Language a) (Language b) = b `isPrefixOf` a -    -- The left language is more specific than the right if the right-    -- arguments is a strict prefix of the left.-    moreSpecificThan (Language a) (Language b) =-        b `isPrefixOf` a && length a > length b+  -- The left language is more specific than the right if the right+  -- arguments is a strict prefix of the left.+  moreSpecificThan (Language a) (Language b) =+    b `isPrefixOf` a && length a > length b  instance RenderHeader Language where-    renderHeader (Language []) = "*"-    renderHeader (Language l)  = BS.intercalate "-" (map original l)+  renderHeader (Language []) = "*"+  renderHeader (Language l) = BS.intercalate "-" (map original l)
src/Network/HTTP/Media/MediaType.hs view
@@ -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 isValidChar bs-  where l = BS.length bs-+ensureR bs =+  CI.mk $+    if l == 0 || l > 127+      then error $ "Invalid length for " ++ show bs+      else ensure isMediaChar bs+  where+    l = BS.length bs ------------------------------------------------------------------------------- -- | Ensures that the 'ByteString' does not contain invalid characters for -- a parameter value. RFC 4288 does not specify what characters are valid, so -- here we just disallow parameter and media type breakers, ',' and ';'. ensureV :: ByteString -> CI ByteString ensureV = CI.mk . ensure (`notElem` [',', ';']) -------------------------------------------------------------------------------- -- | Ensures the predicate matches for every character in the given string. ensure :: (Char -> Bool) -> ByteString -> ByteString-ensure f bs = maybe-    (error $ "Invalid character in " ++ show bs) (const bs) (BS.find f bs)+ensure f bs =+  maybe+    (error $ "Invalid character in " ++ show bs)+    (const bs)+    (BS.find f bs)
src/Network/HTTP/Media/MediaType/Internal.hs view
@@ -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)
src/Network/HTTP/Media/Quality.hs view
@@ -1,97 +1,121 @@-------------------------------------------------------------------------------+{-# LANGUAGE DeriveFunctor #-}+ -- | Defines the quality value data type. module Network.HTTP.Media.Quality-    ( Quality (..)-    , quality-    , maxQuality-    , minQuality-    , 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)+  ( Quality (..),+    quality,+    QualityOrder,+    qualityOrder,+    isAcceptable,+    maxQuality,+    minQuality,+    mostSpecific,+    showQ,+    readQ,+  )+where -import           Network.HTTP.Media.RenderHeader (RenderHeader (..))+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, 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) -------------------------------------------------------------------------------+-- | Whether the quality value is greater than zero; otherwise the value+-- should never be accepted, even when no other options are available.+isAcceptable :: Quality a -> Bool+isAcceptable (Quality _ 0) = False+isAcceptable (Quality _ _) = True++-- | Remove the attached data from a quality value, retaining only the+-- priority of the quality parameter.+qualityOrder :: Quality a -> QualityOrder+qualityOrder = QualityOrder . qualityValue+ -- | Attaches the quality value '1'. maxQuality :: a -> Quality a maxQuality = flip Quality 1000 -------------------------------------------------------------------------------- -- | Attaches the quality value '0'. minQuality :: a -> Quality a minQuality = flip Quality 0 +-- | Combines quality values by specificity. Selects the more specific of the+-- two arguments, but if they are the same returns the data of the left+-- argument with the two quality values of both arguments combined.+mostSpecific :: (Accept a) => Quality a -> Quality a -> Quality a+mostSpecific (Quality a q) (Quality b r)+  | a `moreSpecificThan` b = Quality a q+  | b `moreSpecificThan` a = Quality b r+  | otherwise = Quality a q'+  where+    q' = fromIntegral (fromIntegral q * fromIntegral r `div` 1000 :: Word32) ------------------------------------------------------------------------------- -- | Converts the integral value into its standard quality representation. showQ :: Word16 -> ByteString showQ 1000 = "1"-showQ 0    = "0"-showQ q    = "0." <> BS.replicate (3 - length s) '0' <> b+showQ 0 = "0"+showQ q = "0." <> BS.replicate (3 - length s) '0' <> b   where     s = show q     b = BS.pack (dropWhileEnd (== '0') s) -------------------------------------------------------------------------------- -- | Reads the standard quality representation into an integral value. readQ :: ByteString -> Maybe Word16 readQ bs-    | BS.null bs = Nothing-    | h == '1'   = read1 t-    | h == '0'   = read0 t-    | otherwise  = Nothing+  | BS.null bs = Nothing+  | h == '1' = read1 t+  | h == '0' = read0 t+  | otherwise = Nothing   where     h = BS.head bs     t = BS.tail bs  read1 :: ByteString -> Maybe Word16 read1 bs-    | BS.null bs || h == '.' && BS.length t < 4 && BS.all (== '0') t-                = Just 1000-    | otherwise = Nothing+  | BS.null bs || h == '.' && BS.length t < 4 && BS.all (== '0') t =+      Just 1000+  | otherwise = Nothing   where     h = BS.head bs     t = BS.tail bs  read0 :: ByteString -> Maybe Word16 read0 bs-    | BS.null bs = Just 0-    | h == '.' && BS.length t < 4 && BS.all isDigit t-                = Just (toWord (t <> BS.replicate (3 - BS.length t) '0'))-    | otherwise = Nothing+  | BS.null bs = Just 0+  | h == '.' && BS.length t < 4 && BS.all isDigit t =+      Just (toWord (t <> BS.replicate (3 - BS.length t) '0'))+  | otherwise = Nothing   where     h = BS.head bs     t = BS.tail bs
src/Network/HTTP/Media/RenderHeader.hs view
@@ -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
src/Network/HTTP/Media/Utils.hs view
@@ -1,45 +1,74 @@------------------------------------------------------------------------------ -- | Common utilities. module Network.HTTP.Media.Utils-    ( breakChar-    , trimBS--    , validChars-    , isValidChar-    ) 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) ------------------------------------------------------------------------------- -- | Equivalent to 'Data.ByteString.break' (on equality against the given -- character), but leaves out the byte that the string is broken on. breakChar :: Char -> ByteString -> Maybe (ByteString, ByteString) breakChar c = safeTail . BS.break (== c)   where     safeTail (a, b)-        | BS.null b = Nothing-        | otherwise = Just (a, BS.tail b)-+      | BS.null b = Nothing+      | otherwise = Just (a, BS.tail b) ------------------------------------------------------------------------------- -- | Trims tab and space characters from both ends of a ByteString. trimBS :: ByteString -> ByteString trimBS = fst . BS.spanEnd isLWS . BS.dropWhile isLWS   where     isLWS c = c == ' ' || c == '\t' -------------------------------------------------------------------------------- -- | List of the valid characters for a media-type `reg-name` as per RFC 4288.-validChars :: [Char]-validChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "!#$&.+-^_"-+mediaChars :: [Char]+mediaChars = ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ "!#$&.+-^_" ------------------------------------------------------------------------------- -- | Evaluates whether the given character is valid in a media type `reg-name` -- as per RFC 4288.-isValidChar :: Char -> Bool-isValidChar = (`elem` validChars)+isMediaChar :: Char -> Bool+isMediaChar = (`elem` mediaChars)++-- | Evaluates whether the given character is valid in an HTTP header token as+-- per RFC 2616.+isTokenChar :: Char -> Bool+isTokenChar = (||) <$> not . isControl <*> (`notElem` separators)+  where+    separators =+      [ '(',+        ')',+        '<',+        '>',+        '@',+        ',',+        ';',+        ':',+        '\\',+        '"',+        '/',+        '[',+        ']',+        '?',+        '=',+        '{',+        '}',+        ' '+      ]++-- | HTTP header token characters as per RFC 2616.+tokenChars :: [Char]+tokenChars = filter isTokenChar ['\0' .. '\127']++-- | Evaluates whether the given ASCII string is valid as an HTTP header token+-- as per RFC 2616.+isValidToken :: ByteString -> Bool+isValidToken = (&&) <$> not . BS.null <*> BS.all isTokenChar
test/Network/HTTP/Media/Accept/Tests.hs view
@@ -1,55 +1,32 @@-{-# LANGUAGE CPP #-}-------------------------------------------------------------------------------- module Network.HTTP.Media.Accept.Tests (tests) where --------------------------------------------------------------------------------#if !MIN_VERSION_base(4, 8, 0)-import Control.Applicative ((<$>), (<*>))-#endif---------------------------------------------------------------------------------import Test.Framework                       (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck                      ((===))-------------------------------------------------------------------------------- import Network.HTTP.Media.Accept import Network.HTTP.Media.Gen-+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty) --------------------------------------------------------------------------------tests :: [Test]+tests :: [TestTree] tests =-    [ testMatches-    , testMoreSpecificThan-    , testMostSpecific-    ]-+  [ testMatches,+    testMoreSpecificThan+  ] --------------------------------------------------------------------------------testMatches :: Test-testMatches = testGroup "matches"+testMatches :: TestTree+testMatches =+  testGroup+    "matches"     [ testProperty "Does match" $ do         string <- genByteString-        return $ matches string string-    , testProperty "Doesn't match" $ do-        string  <- genByteString+        return $ matches string string,+      testProperty "Doesn't match" $ do+        string <- genByteString         string' <- genDiffByteString string         return . not $ matches string string'     ] -------------------------------------------------------------------------------- -- | Note that this test never actually generates any strings, as they are not -- required for the 'moreSpecificThan' test.-testMoreSpecificThan :: Test-testMoreSpecificThan = testProperty "moreSpecificThan" $+testMoreSpecificThan :: TestTree+testMoreSpecificThan =+  testProperty "moreSpecificThan" $     (not .) . moreSpecificThan <$> genByteString <*> genByteString----------------------------------------------------------------------------------testMostSpecific :: Test-testMostSpecific = testProperty "mostSpecific" $ do-    string <- genByteString-    (=== string) . mostSpecific string <$> genByteString
+ test/Network/HTTP/Media/Charset/Gen.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE TupleSections #-}++-- | Contains definitions for generating 'Charset's.+module Network.HTTP.Media.Charset.Gen+  ( anything,+    genCharset,+    genConcreteCharset,+    genDiffCharset,+    genDiffConcreteCharsets,+  )+where++import Network.HTTP.Media.Charset.Internal+import Network.HTTP.Media.Gen (genDiffWith, genToken)+import Test.QuickCheck.Gen++-- | The Charset that matches anything.+anything :: Charset+anything = Charset "*"++-- | Generates any kind of Charset.+genCharset :: Gen Charset+genCharset = Charset <$> genToken++-- | Generates an Charset that does not match everything.+genConcreteCharset :: Gen Charset+genConcreteCharset = genDiffWith genCharset anything++-- | Generates a different Charset to the given one.+genDiffCharset :: Charset -> Gen Charset+genDiffCharset = genDiffWith genCharset++-- | Generates two different concrete Charsets.+genDiffConcreteCharsets :: Gen (Charset, Charset)+genDiffConcreteCharsets = do+  enc <- genConcreteCharset+  (enc,) <$> genDiffWith genConcreteCharset enc
+ test/Network/HTTP/Media/Charset/Tests.hs view
@@ -0,0 +1,83 @@+module Network.HTTP.Media.Charset.Tests (tests) where++import Control.Monad (join)+import qualified Data.ByteString.Char8 as BS+import Data.String (fromString)+import Network.HTTP.Media.Accept+import Network.HTTP.Media.Charset (Charset)+import Network.HTTP.Media.Charset.Gen+import Network.HTTP.Media.RenderHeader+import Test.QuickCheck ((===))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++tests :: [TestTree]+tests =+  [ testEq,+    testShow,+    testFromString,+    testMatches,+    testMoreSpecific,+    testParseAccept+  ]++-- Equality is derived, but we test it here to get 100% coverage.+testEq :: TestTree+testEq =+  testGroup+    "Eq"+    [ testProperty "==" $ do+        enc <- genCharset+        return $ enc === enc,+      testProperty "/=" $ do+        enc <- genCharset+        enc' <- genDiffCharset enc+        return $ enc /= enc'+    ]++testShow :: TestTree+testShow = testProperty "show" $ do+  enc <- genCharset+  return $ parseAccept (BS.pack $ show enc) === Just enc++testFromString :: TestTree+testFromString = testProperty "fromString" $ do+  enc <- genCharset+  return $ enc === fromString (show enc)++testMatches :: TestTree+testMatches =+  testGroup+    "matches"+    [ testProperty "Equal values match" $+        join matches <$> genCharset,+      testProperty "* matches anything" $+        flip matches anything <$> genCharset,+      testProperty "No concrete encoding matches *" $+        not . matches anything <$> genConcreteCharset+    ]++testMoreSpecific :: TestTree+testMoreSpecific =+  testGroup+    "moreSpecificThan"+    [ testProperty "Against *" $+        flip moreSpecificThan anything <$> genConcreteCharset,+      testProperty "With *" $+        not . moreSpecificThan anything <$> genConcreteCharset,+      testProperty "Unrelated encodings" $+        not . uncurry moreSpecificThan <$> genDiffConcreteCharsets+    ]++testParseAccept :: TestTree+testParseAccept =+  testGroup+    "parseAccept"+    [ testProperty "Empty" $+        parseAccept "" === (Nothing :: Maybe Charset),+      testProperty "Wildcard" $+        parseAccept "*" === Just anything,+      testProperty "Valid parse" $ do+        enc <- genCharset+        return $ parseAccept (renderHeader enc) === Just enc+    ]
+ test/Network/HTTP/Media/Encoding/Gen.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE TupleSections #-}++-- | Contains definitions for generating 'Encoding's.+module Network.HTTP.Media.Encoding.Gen+  ( anything,+    identity,+    genEncoding,+    genConcreteEncoding,+    genDiffEncoding,+    genDiffConcreteEncodings,+  )+where++import Network.HTTP.Media.Encoding.Internal+import Network.HTTP.Media.Gen (genDiffWith, genToken)+import Test.QuickCheck.Gen++-- | The Encoding that matches anything.+anything :: Encoding+anything = Encoding "*"++-- | The default Encoding.+identity :: Encoding+identity = Encoding "identity"++-- | Generates any kind of Encoding.+genEncoding :: Gen Encoding+genEncoding = Encoding <$> genToken++-- | Generates an Encoding that does not match everything.+genConcreteEncoding :: Gen Encoding+genConcreteEncoding = genDiffWith genEncoding anything++-- | Generates a different Encoding to the given one.+genDiffEncoding :: Encoding -> Gen Encoding+genDiffEncoding = genDiffWith genEncoding++-- | Generates two different concrete Encodings.+genDiffConcreteEncodings :: Gen (Encoding, Encoding)+genDiffConcreteEncodings = do+  enc <- genConcreteEncoding+  (enc,) <$> genDiffWith genConcreteEncoding enc
+ test/Network/HTTP/Media/Encoding/Tests.hs view
@@ -0,0 +1,82 @@+module Network.HTTP.Media.Encoding.Tests (tests) where++import Control.Monad (join)+import qualified Data.ByteString.Char8 as BS+import Data.String (fromString)+import Network.HTTP.Media.Accept+import Network.HTTP.Media.Encoding.Gen+import Network.HTTP.Media.RenderHeader+import Test.QuickCheck ((===))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++tests :: [TestTree]+tests =+  [ testEq,+    testShow,+    testFromString,+    testMatches,+    testMoreSpecific,+    testParseAccept+  ]++-- Equality is derived, but we test it here to get 100% coverage.+testEq :: TestTree+testEq =+  testGroup+    "Eq"+    [ testProperty "==" $ do+        enc <- genEncoding+        return $ enc === enc,+      testProperty "/=" $ do+        enc <- genEncoding+        enc' <- genDiffEncoding enc+        return $ enc /= enc'+    ]++testShow :: TestTree+testShow = testProperty "show" $ do+  enc <- genEncoding+  return $ parseAccept (BS.pack $ show enc) === Just enc++testFromString :: TestTree+testFromString = testProperty "fromString" $ do+  enc <- genEncoding+  return $ enc === fromString (show enc)++testMatches :: TestTree+testMatches =+  testGroup+    "matches"+    [ testProperty "Equal values match" $+        join matches <$> genEncoding,+      testProperty "* matches anything" $+        flip matches anything <$> genEncoding,+      testProperty "No concrete encoding matches *" $+        not . matches anything <$> genConcreteEncoding+    ]++testMoreSpecific :: TestTree+testMoreSpecific =+  testGroup+    "moreSpecificThan"+    [ testProperty "Against *" $+        flip moreSpecificThan anything <$> genConcreteEncoding,+      testProperty "With *" $+        not . moreSpecificThan anything <$> genConcreteEncoding,+      testProperty "Unrelated encodings" $+        not . uncurry moreSpecificThan <$> genDiffConcreteEncodings+    ]++testParseAccept :: TestTree+testParseAccept =+  testGroup+    "parseAccept"+    [ testProperty "Empty" $+        parseAccept "" === Just identity,+      testProperty "Wildcard" $+        parseAccept "*" === Just anything,+      testProperty "Valid parse" $ do+        enc <- genEncoding+        return $ parseAccept (renderHeader enc) === Just enc+    ]
test/Network/HTTP/Media/Gen.hs view
@@ -1,83 +1,72 @@-{-# LANGUAGE CPP #-}-------------------------------------------------------------------------------- -- | Contains definitions for generating 'ByteString's. module Network.HTTP.Media.Gen-    ( genByteStringFrom-    , genCIByteStringFrom-    , genByteString-    , genCIByteString-    , genDiffWith-    , genDiffByteString-    , genDiffCIByteString--    , padString-    ) where---------------------------------------------------------------------------------#if !MIN_VERSION_base(4, 8, 0)-import Data.Functor ((<$>))-#endif+  ( genToken,+    genByteStringFrom,+    genCIByteStringFrom,+    genByteString,+    genCIByteString,+    genDiffWith,+    genDiffByteString,+    genDiffCIByteString,+    padString,+  )+where -------------------------------------------------------------------------------+import Control.Monad (join, liftM2)+import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS-import qualified Data.CaseInsensitive  as CI---------------------------------------------------------------------------------import Control.Monad        (join, liftM2)-import Data.ByteString      (ByteString) import Data.CaseInsensitive (CI, original)-import Data.Monoid          ((<>))-import Test.QuickCheck.Gen  (Gen, elements, listOf, listOf1)+import qualified Data.CaseInsensitive as CI+import Data.Monoid ((<>))+import qualified Network.HTTP.Media.Utils as Utils+import Test.QuickCheck.Gen (Gen)+import qualified Test.QuickCheck.Gen as Gen+import Prelude hiding ((<>)) +-- | Generates a valid header token.+genToken :: Gen (CI ByteString)+genToken = genCIByteStringFrom Utils.tokenChars ------------------------------------------------------------------------------- -- | Produces a non-empty ByteString of random characters from the given set. genByteStringFrom :: String -> Gen ByteString-genByteStringFrom = fmap BS.pack . listOf1 . elements-+genByteStringFrom = fmap BS.pack . Gen.listOf1 . Gen.elements ------------------------------------------------------------------------------- genCIByteStringFrom :: String -> Gen (CI ByteString) genCIByteStringFrom = fmap CI.mk . genByteStringFrom ----------------------------------------------------------------------------------- | Produces a non-empty ByteString of random alphanumeric characters.+-- | Produces a non-empty ByteString of random alphanumeric characters with a+-- non-numeric head. genByteString :: Gen ByteString-genByteString = genByteStringFrom (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'])-+genByteString =+  fmap BS.pack . (:)+    <$> Gen.elements alpha+    <*> Gen.scale (max 0 . pred) (Gen.listOf (Gen.elements alphaNum))+  where+    alpha = ['a' .. 'z'] ++ ['A' .. 'Z']+    alphaNum = alpha ++ ['0' .. '9'] -------------------------------------------------------------------------------+-- | Produces a non-empty case-insensitive ByteString of random alphanumeric+-- characters with a non-numeric head. genCIByteString :: Gen (CI ByteString) genCIByteString = fmap CI.mk genByteString -------------------------------------------------------------------------------- -- | Produces a non-empty ByteString different to the given one using the -- given generator.-genDiffWith :: Eq a => Gen a -> a -> Gen a-genDiffWith gen a = do-    b <- gen-    if a == b then genDiffWith gen a else return b-+genDiffWith :: (Eq a) => Gen a -> a -> Gen a+genDiffWith gen = Gen.suchThat gen . (/=) ------------------------------------------------------------------------------- -- | Produces a non-empty ByteString of random alphanumeric characters that -- is case-insensitively different to the given one. genDiffByteString :: ByteString -> Gen ByteString genDiffByteString = fmap original . genDiffCIByteString . CI.mk -------------------------------------------------------------------------------- -- | Produces a non-empty case-insensitive ByteString of random alphanumeric -- characters that is different to the given one. genDiffCIByteString :: CI ByteString -> Gen (CI ByteString) genDiffCIByteString = genDiffWith genCIByteString -------------------------------------------------------------------------------- -- | Pad a 'ByteString' with a random amount of tab and space characters. padString :: ByteString -> Gen ByteString-padString c = join (liftM2 pad) (BS.pack <$> listOf (elements " \t"))-  where pad a b = a <> c <> b+padString c = join (liftM2 pad) (BS.pack <$> Gen.listOf (Gen.elements " \t"))+  where+    pad a b = a <> c <> b
test/Network/HTTP/Media/Language/Gen.hs view
@@ -1,120 +1,84 @@-{-# LANGUAGE CPP, TupleSections #-}+{-# LANGUAGE TupleSections #-} ------------------------------------------------------------------------------- -- | Contains definitions for generating 'Language's. module Network.HTTP.Media.Language.Gen-    (-    -- * Generating Languages-      anything-    , genLanguage-    , genConcreteLanguage-    , genDiffLanguage-    , genMatchingLanguage-    , genDiffMatchingLanguage-    , genNonMatchingLanguage-    , genMatchingLanguages-    , genDiffMatchingLanguages-    , genNonMatchingLanguages-    ) where+  ( -- * Generating Languages+    anything,+    genLanguage,+    genConcreteLanguage,+    genDiffLanguage,+    genMatchingLanguage,+    genDiffMatchingLanguage,+    genNonMatchingLanguage,+    genMatchingLanguages,+    genDiffMatchingLanguages,+    genNonMatchingLanguages,+  )+where --------------------------------------------------------------------------------#if !MIN_VERSION_base(4, 8, 0)-import Control.Applicative  ((<$>))-#endif-import Data.ByteString      (ByteString)+import Data.ByteString (ByteString) import Data.CaseInsensitive (CI)-import Test.QuickCheck.Gen-------------------------------------------------------------------------------- import qualified Network.HTTP.Media.Gen as Gen-------------------------------------------------------------------------------- import Network.HTTP.Media.Language.Internal-+import Test.QuickCheck.Gen ------------------------------------------------------------------------------- -- | The Language that matches anything. anything :: Language anything = Language [] -------------------------------------------------------------------------------- -- | Generates any kind of Language. genLanguage :: Gen Language genLanguage = Language <$> listOf genCIByteString -------------------------------------------------------------------------------- -- | Generates a Language that does not match everything. genConcreteLanguage :: Gen Language genConcreteLanguage = Language <$> listOf1 genCIByteString -------------------------------------------------------------------------------- -- | Generates a different Language to the given one. genDiffLanguage :: Language -> Gen Language genDiffLanguage (Language []) = genConcreteLanguage-genDiffLanguage l             = Gen.genDiffWith genLanguage l-+genDiffLanguage l = Gen.genDiffWith genLanguage l ------------------------------------------------------------------------------- -- | Generate a Language that has the given language as a prefix. genMatchingLanguage :: Language -> Gen Language genMatchingLanguage (Language pre) =-    (Language . (pre ++)) <$> listOf genCIByteString-+  Language . (pre ++) <$> listOf genCIByteString ------------------------------------------------------------------------------- -- | Generate a Language that has the given language as a proper prefix. genDiffMatchingLanguage :: Language -> Gen Language genDiffMatchingLanguage (Language pre) =-    (Language . (pre ++)) <$> listOf1 genCIByteString-+  Language . (pre ++) <$> listOf1 genCIByteString ------------------------------------------------------------------------------- -- | Generate a Language that does not have the given language as a prefix. genNonMatchingLanguage :: Language -> Gen Language-genNonMatchingLanguage (Language [])        = genConcreteLanguage+genNonMatchingLanguage (Language []) = genConcreteLanguage genNonMatchingLanguage (Language (pre : _)) = do-    pre' <- genDiffCIByteString pre-    genMatchingLanguage $ Language [pre']-+  pre' <- genDiffCIByteString pre+  genMatchingLanguage $ Language [pre'] ------------------------------------------------------------------------------- -- | A private definition for generating pairs of languagues. genLanguages :: (Language -> Gen Language) -> Gen (Language, Language) genLanguages gen = do-    pre <- genLanguage-    (pre,) <$> gen pre-+  pre <- genLanguage+  (pre,) <$> gen pre ------------------------------------------------------------------------------- -- | Generate two languages, the first of which is a prefix of the second. genMatchingLanguages :: Gen (Language, Language) genMatchingLanguages = genLanguages genMatchingLanguage -------------------------------------------------------------------------------- -- | Generate two languages, the first of which is a proper prefix of the -- second. genDiffMatchingLanguages :: Gen (Language, Language) genDiffMatchingLanguages = genLanguages genDiffMatchingLanguage -------------------------------------------------------------------------------- -- | Generate two languages, the first of which is not a prefix of the second. genNonMatchingLanguages :: Gen (Language, Language) genNonMatchingLanguages = do-    pre <- genConcreteLanguage-    (pre,) <$> genNonMatchingLanguage pre-+  pre <- genConcreteLanguage+  (pre,) <$> genNonMatchingLanguage pre ------------------------------------------------------------------------------- genCIByteString :: Gen (CI ByteString)-genCIByteString =-    resize 8 $ Gen.genCIByteStringFrom (['a'..'z'] ++ ['A'..'Z'])-+genCIByteString = resize 8 Gen.genCIByteString ------------------------------------------------------------------------------- genDiffCIByteString :: CI ByteString -> Gen (CI ByteString) genDiffCIByteString = Gen.genDiffWith genCIByteString
test/Network/HTTP/Media/Language/Tests.hs view
@@ -1,129 +1,92 @@-{-# LANGUAGE CPP #-}-------------------------------------------------------------------------------- module Network.HTTP.Media.Language.Tests (tests) where --------------------------------------------------------------------------------#if !MIN_VERSION_base(4, 8, 0)-import Data.Functor ((<$>))-#endif--------------------------------------------------------------------------------+import Control.Monad (join) import qualified Data.ByteString.Char8 as BS---------------------------------------------------------------------------------import Control.Monad                        (join)-import Data.Monoid                          ((<>))-import Data.String                          (fromString)-import Test.Framework                       (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck                      ((.&&.), (===))--------------------------------------------------------------------------------+import Data.Monoid ((<>))+import Data.String (fromString) import Network.HTTP.Media.Accept import Network.HTTP.Media.Language import Network.HTTP.Media.Language.Gen import Network.HTTP.Media.RenderHeader-+import Test.QuickCheck ((===))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Prelude hiding ((<>)) --------------------------------------------------------------------------------tests :: [Test]+tests :: [TestTree] tests =-    [ testEq-    , testShow-    , testFromString-    , testMatches-    , testMoreSpecific-    , testMostSpecific-    , testParseAccept-    ]-+  [ testEq,+    testShow,+    testFromString,+    testMatches,+    testMoreSpecific,+    testParseAccept+  ] ------------------------------------------------------------------------------- -- Equality is derived, but we test it here to get 100% coverage.-testEq :: Test-testEq = testGroup "Eq"+testEq :: TestTree+testEq =+  testGroup+    "Eq"     [ testProperty "==" $ do         lang <- genLanguage-        return $ lang === lang-    , testProperty "/=" $ do-        lang  <- genLanguage+        return $ lang === lang,+      testProperty "/=" $ do+        lang <- genLanguage         lang' <- genDiffLanguage lang         return $ lang /= lang'     ] ---------------------------------------------------------------------------------testShow :: Test+testShow :: TestTree testShow = testProperty "show" $ do-    lang <- genLanguage-    return $ parseAccept (BS.pack $ show lang) === Just lang-+  lang <- genLanguage+  return $ parseAccept (BS.pack $ show lang) === Just lang --------------------------------------------------------------------------------testFromString :: Test+testFromString :: TestTree testFromString = testProperty "fromString" $ do-    lang <- genLanguage-    return $ lang === fromString (show lang)-+  lang <- genLanguage+  return $ lang === fromString (show lang) --------------------------------------------------------------------------------testMatches :: Test-testMatches = testGroup "matches"+testMatches :: TestTree+testMatches =+  testGroup+    "matches"     [ testProperty "Equal values match" $-        join matches <$> genLanguage-    , testProperty "Right prefix matches left" $-        uncurry (flip matches) <$> genMatchingLanguages-    , testProperty "Left prefix does not match right" $-        not . uncurry matches <$> genDiffMatchingLanguages-    , testProperty "* matches anything" $-        flip matches anything <$> genLanguage-    , testProperty "No concrete language matches *" $+        join matches <$> genLanguage,+      testProperty "Right prefix matches left" $+        uncurry (flip matches) <$> genMatchingLanguages,+      testProperty "Left prefix does not match right" $+        not . uncurry matches <$> genDiffMatchingLanguages,+      testProperty "* matches anything" $+        flip matches anything <$> genLanguage,+      testProperty "No concrete language matches *" $         not . matches anything <$> genConcreteLanguage     ] ---------------------------------------------------------------------------------testMoreSpecific :: Test-testMoreSpecific = testGroup "moreSpecificThan"+testMoreSpecific :: TestTree+testMoreSpecific =+  testGroup+    "moreSpecificThan"     [ testProperty "Against *" $-        flip moreSpecificThan anything <$> genConcreteLanguage-    , testProperty "With *" $-        not . moreSpecificThan anything <$> genLanguage-    , testProperty "Proper prefix lhs" $-        not . uncurry moreSpecificThan <$> genDiffMatchingLanguages-    , testProperty "Proper prefix rhs" $-        uncurry (flip moreSpecificThan) <$> genDiffMatchingLanguages-    , testProperty "Unrelated languages" $+        flip moreSpecificThan anything <$> genConcreteLanguage,+      testProperty "With *" $+        not . moreSpecificThan anything <$> genLanguage,+      testProperty "Proper prefix lhs" $+        not . uncurry moreSpecificThan <$> genDiffMatchingLanguages,+      testProperty "Proper prefix rhs" $+        uncurry (flip moreSpecificThan) <$> genDiffMatchingLanguages,+      testProperty "Unrelated languages" $         not . uncurry moreSpecificThan <$> genNonMatchingLanguages     ] ---------------------------------------------------------------------------------testMostSpecific :: Test-testMostSpecific = testGroup "mostSpecific"-    [ testProperty "With *" $ do-        lang <- genLanguage-        return $ mostSpecific lang anything === lang .&&.-            mostSpecific anything lang === lang-    , testProperty "Proper prefix" $ do-        (pre, lang) <- genMatchingLanguages-        return $ mostSpecific lang pre === lang .&&.-            mostSpecific pre lang === lang-    , testProperty "Left biased" $ do-        (lang, lang') <- genNonMatchingLanguages-        return $ mostSpecific lang lang' === lang .&&.-            mostSpecific lang' lang === lang'-    ]----------------------------------------------------------------------------------testParseAccept :: Test-testParseAccept = testGroup "parseAccept"-    [ testProperty "Valid parse"$ do+testParseAccept :: TestTree+testParseAccept =+  testGroup+    "parseAccept"+    [ testProperty "Valid parse" $ do         lang <- genLanguage-        return $ parseAccept (renderHeader lang) === Just lang-    , testProperty "Trailing hyphen" $ do+        return $ parseAccept (renderHeader lang) === Just lang,+      testProperty "Trailing hyphen" $ do         bs <- renderHeader <$> genLanguage         return $ (parseAccept $ bs <> "-" :: Maybe Language) === Nothing     ]
test/Network/HTTP/Media/MediaType/Gen.hs view
@@ -1,188 +1,170 @@-{-# LANGUAGE CPP #-}-------------------------------------------------------------------------------- -- | Contains definitions for generating 'MediaType's. module Network.HTTP.Media.MediaType.Gen-    (-    -- * Generating MediaTypes-      anything-    , genMediaType-    , genSubStar-    , genMaybeSubStar-    , subStarOf-    , genConcreteMediaType-    , genWithoutParams-    , genWithParams-    , stripParams-    , genDiffMediaTypesWith-    , genDiffMediaTypeWith-    , genDiffMediaTypes-    , genDiffMediaType+  ( -- * Generating MediaTypes+    anything,+    genMediaType,+    genSubStar,+    genMaybeSubStar,+    subStarOf,+    genConcreteMediaType,+    genWithoutParams,+    genWithParams,+    stripParams,+    genDiffMediaTypesWith,+    genDiffMediaTypeWith,+    genDiffMediaTypes,+    genDiffMediaType,+    genMatchingPair,      -- * Generating Parameters-    , genParameters-    , genMaybeParameters-    , genDiffParameters+    genParameters,+    genMaybeParameters,+    genDiffParameters,      -- * Rendering Parameters-    , renderParameters-    ) where---------------------------------------------------------------------------------#if !MIN_VERSION_base(4, 8, 0)-import Data.Functor ((<$>))-#endif---------------------------------------------------------------------------------import qualified Data.Map as Map+    renderParameters,+  )+where --------------------------------------------------------------------------------import Control.Monad        (liftM, liftM2)-import Data.ByteString      (ByteString)+import Control.Monad (filterM, liftM2)+import Data.ByteString (ByteString) import Data.CaseInsensitive (CI, original)-import Data.Foldable        (foldlM)-import Data.Map             (fromList)-import Data.Monoid          ((<>))-import Test.QuickCheck.Gen--------------------------------------------------------------------------------+import Data.Foldable (foldlM)+import Data.Map (fromList)+import qualified Data.Map as Map+import Data.Monoid ((<>)) import Network.HTTP.Media.Gen import Network.HTTP.Media.MediaType.Internal-+import Test.QuickCheck.Gen+import Prelude hiding ((<>)) ------------------------------------------------------------------------------- -- | Parameter entry for testing. type ParamEntry = (CI ByteString, CI ByteString) -------------------------------------------------------------------------------- -- | The MediaType that matches anything. anything :: MediaType anything = MediaType "*" "*" Map.empty -------------------------------------------------------------------------------- -- | Generates any kind of MediaType. genMediaType :: Gen MediaType genMediaType = oneof [return anything, genSubStar, genConcreteMediaType] -------------------------------------------------------------------------------- -- | Generates a MediaType with just a concrete main type. genSubStar :: Gen MediaType genSubStar = do-    main <- genCIByteString-    return $ MediaType main "*" Map.empty-+  main <- genCIByteString+  return $ MediaType main "*" Map.empty ------------------------------------------------------------------------------- -- | Generates a MediaType whose sub type might be *. genMaybeSubStar :: Gen MediaType genMaybeSubStar = oneof [genSubStar, genConcreteMediaType] -------------------------------------------------------------------------------- -- | Strips the sub type and parameters from a MediaType. subStarOf :: MediaType -> MediaType-subStarOf media = media { subType = "*", parameters = Map.empty }-+subStarOf media = media {subType = "*", parameters = Map.empty} ------------------------------------------------------------------------------- -- | Generates a concrete MediaType which may have parameters. genConcreteMediaType :: Gen MediaType genConcreteMediaType = do-    main <- genCIByteString-    sub  <- genCIByteString-    params <- oneof [return Map.empty, genParameters]-    return $ MediaType main sub params-+  main <- genCIByteString+  sub <- genCIByteString+  params <- oneof [return Map.empty, genParameters]+  return $ MediaType main sub params ------------------------------------------------------------------------------- -- | Generates a concrete MediaType with no parameters. genWithoutParams :: Gen MediaType genWithoutParams = do-    main <- genCIByteString-    sub  <- genCIByteString-    return $ MediaType main sub Map.empty-+  main <- genCIByteString+  sub <- genCIByteString+  return $ MediaType main sub Map.empty ------------------------------------------------------------------------------- -- | Generates a MediaType with at least one parameter. genWithParams :: Gen MediaType genWithParams = do-    main   <- genCIByteString-    sub    <- genCIByteString-    params <- genParameters-    return $ MediaType main sub params-+  main <- genCIByteString+  sub <- genCIByteString+  MediaType main sub <$> genParameters ------------------------------------------------------------------------------- -- | Strips the parameters from the given MediaType. stripParams :: MediaType -> MediaType-stripParams media = media { parameters = Map.empty }-+stripParams media = media {parameters = Map.empty} ------------------------------------------------------------------------------- -- | Generates a different MediaType to the ones in the given list, using the -- given generator. genDiffMediaTypesWith :: Gen MediaType -> [MediaType] -> Gen MediaType genDiffMediaTypesWith gen media = do-    media' <- gen-    if media' `elem` media-        then genDiffMediaTypesWith gen media-        else return media'-+  media' <- gen+  if media' `elem` media+    then genDiffMediaTypesWith gen media+    else return media' ------------------------------------------------------------------------------- -- | Generates a different MediaType to the given one, using the given -- generator. genDiffMediaTypeWith :: Gen MediaType -> MediaType -> Gen MediaType genDiffMediaTypeWith gen = genDiffMediaTypesWith gen . (: []) ----------------------------------------------------------------------------------- | Generates a  different MediaType to the ones in the given list.+-- | Generates a different MediaType to the ones in the given list. genDiffMediaTypes :: [MediaType] -> Gen MediaType genDiffMediaTypes = genDiffMediaTypesWith genMediaType -------------------------------------------------------------------------------- -- | Generates a different MediaType to the given one. genDiffMediaType :: MediaType -> Gen MediaType genDiffMediaType = genDiffMediaTypes . (: []) -------------------------------------------------------------------------------- -- | Reuse for 'mayParams' and 'someParams'. mkGenParams :: (Gen ParamEntry -> Gen [ParamEntry]) -> Gen Parameters-mkGenParams = liftM fromList .-    ($ liftM2 (,) (genDiffCIByteString "q") genCIByteString)-+mkGenParams =+  fmap fromList+    . ($ liftM2 (,) (genDiffCIByteString "q") genCIByteString) ------------------------------------------------------------------------------- -- | Generates some sort of parameters. genMaybeParameters :: Gen Parameters genMaybeParameters = mkGenParams listOf -------------------------------------------------------------------------------- -- | Generates at least one parameter. genParameters :: Gen Parameters genParameters = mkGenParams listOf1 -------------------------------------------------------------------------------- -- | Generates a set of parameters that is not a submap of the given -- parameters (but not necessarily vice versa). genDiffParameters :: Parameters -> Gen Parameters genDiffParameters params = do-    params' <- genParameters-    if params' `Map.isSubmapOf` params-        then genDiffParameters params-        else return params'+  params' <- genParameters+  if params' `Map.isSubmapOf` params+    then genDiffParameters params+    else return params' +-- | Generates a set of parameters that is a strict submap of the given+-- parameters.+genSubParameters :: Parameters -> Gen (Maybe Parameters)+genSubParameters params+  | Map.null params = return Nothing+  | otherwise = Just . Map.fromList <$> genStrictSublist+  where+    list = Map.toList params+    genStrictSublist = do+      sublist <- filterM (const $ choose (False, True)) list+      if sublist == list+        then genStrictSublist+        else return sublist -------------------------------------------------------------------------------+-- | Generates a pair of non-equal MediaType values that are in a 'matches'+-- relation, with the more specific value on the left.+genMatchingPair :: Gen (MediaType, MediaType)+genMatchingPair = do+  a <- oneof [genSubStar, genConcreteMediaType]+  b <-+    if subType a == "*"+      then return anything+      else oneof $ withSubParameters a : map return [subStarOf a, anything]+  return (a, b)+  where+    withSubParameters a = do+      params <- genSubParameters (parameters a)+      return $ case params of+        Just sub -> a {parameters = sub}+        Nothing -> subStarOf a+ -- | Render parameters with a generated amount of whitespace between the -- semicolons. Note that there is a leading semicolon in front of the -- parameters, as it is expected that this will always be attached to@@ -191,4 +173,4 @@ renderParameters params = foldlM pad "" (Map.toList params)   where     pad s (k, v) =-        (s <>) . (<> original k <> "=" <> original v) <$> padString ";"+      (s <>) . (<> original k <> "=" <> original v) <$> padString ";"
test/Network/HTTP/Media/MediaType/Tests.hs view
@@ -1,245 +1,198 @@-{-# LANGUAGE CPP #-}-------------------------------------------------------------------------------- module Network.HTTP.Media.MediaType.Tests (tests) where --------------------------------------------------------------------------------#if !MIN_VERSION_base(4, 8, 0)-import Data.Functor ((<$>))-#endif--------------------------------------------------------------------------------+import Control.Monad (join)+import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS-import qualified Data.Map              as Map---------------------------------------------------------------------------------import Control.Monad                        (join, liftM)-import Data.ByteString                      (ByteString)-import Data.CaseInsensitive                 (foldedCase)-import Data.Monoid                          ((<>))-import Data.String                          (fromString)-import Test.Framework                       (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck                      (property, (.&&.), (===))-import Test.QuickCheck.Gen                  (Gen)--------------------------------------------------------------------------------+import Data.CaseInsensitive (foldedCase)+import qualified Data.Map as Map+import Data.Monoid ((<>))+import Data.String (fromString) import Network.HTTP.Media.Accept import Network.HTTP.Media.Gen-import Network.HTTP.Media.MediaType          ((/.), (/?))+import Network.HTTP.Media.MediaType ((/.), (/?)) import Network.HTTP.Media.MediaType.Gen import Network.HTTP.Media.MediaType.Internal-import Network.HTTP.Media.RenderHeader       (renderHeader)-+import Network.HTTP.Media.RenderHeader (renderHeader)+import Test.QuickCheck (property, (.&&.), (===))+import Test.QuickCheck.Gen (Gen)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Prelude hiding ((<>)) --------------------------------------------------------------------------------tests :: [Test]+tests :: [TestTree] tests =-    [ testEq-    , testShow-    , testFromString-    , testHas-    , testGet-    , testMatches-    , testMoreSpecificThan-    , testMostSpecific-    , testParseAccept-    ]-+  [ testEq,+    testShow,+    testFromString,+    testHas,+    testGet,+    testMatches,+    testMoreSpecificThan,+    testParseAccept+  ] ------------------------------------------------------------------------------- -- Equality is derived, but we test it here to get 100% coverage.-testEq :: Test-testEq = testGroup "Eq"+testEq :: TestTree+testEq =+  testGroup+    "Eq"     [ testProperty "==" $ do         media <- genMediaType-        return $ media === media-    , testProperty "/=" $ do-        media  <- genMediaType+        return $ media === media,+      testProperty "/=" $ do+        media <- genMediaType         media' <- genDiffMediaType media         return $ media /= media'     ] ---------------------------------------------------------------------------------testShow :: Test+testShow :: TestTree testShow = testProperty "show" $ do-    media <- genMediaType-    return $ parseAccept (BS.pack $ show media) === Just media-+  media <- genMediaType+  return $ parseAccept (BS.pack $ show media) === Just media --------------------------------------------------------------------------------testFromString :: Test+testFromString :: TestTree testFromString = testProperty "fromString" $ do-    media <- genMediaType-    return $ media === fromString (show media)-+  media <- genMediaType+  return $ media === fromString (show media) --------------------------------------------------------------------------------testHas :: Test-testHas = testGroup "(/?)"+testHas :: TestTree+testHas =+  testGroup+    "(/?)"     [ testProperty "True for property it has" $ do         media <- genWithParams-        return $ all ((media /?) . foldedCase) (Map.keys $ parameters media)-    , testProperty "False for property it doesn't have" $ do+        return $ all ((media /?) . foldedCase) (Map.keys $ parameters media),+      testProperty "False for property it doesn't have" $ do         media <- genWithParams-        return $ all (not . (stripParams media /?) . foldedCase)+        return . not $+          any+            ((stripParams media /?) . foldedCase)             (Map.keys $ parameters media)     ] ---------------------------------------------------------------------------------testGet :: Test-testGet = testGroup "(/.)"+testGet :: TestTree+testGet =+  testGroup+    "(/.)"     [ testProperty "Retrieves property it has" $ do-        media  <- genWithParams+        media <- genWithParams         let is n v = (.&&. media /. foldedCase n === Just v)-        return $ Map.foldrWithKey is (property True) $ parameters media-    , testProperty "Nothing for property it doesn't have" $ do+        return $ Map.foldrWithKey is (property True) $ parameters media,+      testProperty "Nothing for property it doesn't have" $ do         media <- genWithParams         let is n _ = (.&&. stripParams media /. foldedCase n === Nothing)         return $ Map.foldrWithKey is (property True) $ parameters media     ] ---------------------------------------------------------------------------------testMatches :: Test-testMatches = testGroup "matches"+testMatches :: TestTree+testMatches =+  testGroup+    "matches"     [ testProperty "Equal values match" $ do         media <- genMediaType-        return $ matches media media-    , testProperty "Same sub but different main don't match" $ do+        return $ matches media media,+      testProperty "Same sub but different main don't match" $ do         media <- genMaybeSubStar-        main  <- genDiffCIByteString $ mainType media-        return $ not (matches media media { mainType = main }) &&-            not (matches media { mainType = main } media)-    , testProperty "Same main but different sub don't match" $ do+        main <- genDiffCIByteString $ mainType media+        return $+          not (matches media media {mainType = main})+            && not (matches media {mainType = main} media),+      testProperty "Same main but different sub don't match" $ do         media <- genConcreteMediaType-        sub   <- genDiffCIByteString $ subType media-        return . not $ matches media media { subType = sub } ||-            matches media { subType = sub } media-    , testProperty "Different parameters don't match" $-        liftM (not . dotJoin matches stripParams) genWithParams-    , testProperty "Missing parameters match" $ do+        sub <- genDiffCIByteString $ subType media+        return . not $+          matches media media {subType = sub}+            || matches media {subType = sub} media,+      testProperty "Different parameters don't match" $+        not . dotJoin matches stripParams <$> genWithParams,+      testProperty "Missing parameters match" $ do         media <- genWithParams         let media' = stripParams media-        return $ matches media media' && not (matches media' media)-    , testGroup "*/*"-        [ testProperty "Matches itself" $ matches anything anything-        , testProperty "Matches anything on the right" $-            liftM (`matches` anything) genMediaType-        , testProperty "Doesn't match more specific on the left" $-            liftM (not . matches anything) genMaybeSubStar-        ]-    , testGroup "type/*"-        [ testProperty "Matches itself" $ liftM (join matches) genSubStar-        , testProperty "Matches on the right" $-            liftM (dotJoin (flip matches) subStarOf) genConcreteMediaType-        , testProperty "Doesn't match on the left" $-            liftM (not . dotJoin matches subStarOf) genConcreteMediaType+        return $ matches media media' && not (matches media' media),+      testGroup+        "*/*"+        [ testProperty "Matches itself" $ matches anything anything,+          testProperty "Matches anything on the right" $+            (`matches` anything) <$> genMediaType,+          testProperty "Doesn't match more specific on the left" $+            not . (anything `matches`) <$> genMaybeSubStar+        ],+      testGroup+        "type/*"+        [ testProperty "Matches itself" $ join matches <$> genSubStar,+          testProperty "Matches on the right" $+            dotJoin (flip matches) subStarOf <$> genConcreteMediaType,+          testProperty "Doesn't match on the left" $+            not . dotJoin matches subStarOf <$> genConcreteMediaType         ]     ] ---------------------------------------------------------------------------------testMoreSpecificThan :: Test-testMoreSpecificThan = testGroup "moreSpecificThan"+testMoreSpecificThan :: TestTree+testMoreSpecificThan =+  testGroup+    "moreSpecificThan"     [ testProperty "Against */*" $-        liftM (`moreSpecificThan` anything) genMaybeSubStar-    , testProperty "With */*" $-        liftM (not . moreSpecificThan anything) genMaybeSubStar-    , testProperty "Against type/*" $-        liftM (dotJoin (flip moreSpecificThan) subStarOf) genConcreteMediaType-    , testProperty "With type/*" $-        liftM (not . dotJoin moreSpecificThan subStarOf) genConcreteMediaType-    , testProperty "With parameters" $-        liftM (dotJoin (flip moreSpecificThan) stripParams) genWithParams-    , testProperty "Different types" $ do-        media  <- genWithoutParams+        (`moreSpecificThan` anything) <$> genMaybeSubStar,+      testProperty "With */*" $+        not . (anything `moreSpecificThan`) <$> genMaybeSubStar,+      testProperty "Against type/*" $+        dotJoin (flip moreSpecificThan) subStarOf <$> genConcreteMediaType,+      testProperty "With type/*" $+        not . dotJoin moreSpecificThan subStarOf <$> genConcreteMediaType,+      testProperty "With parameters" $+        dotJoin (flip moreSpecificThan) stripParams <$> genWithParams,+      testProperty "Different types" $ do+        media <- genWithoutParams         media' <- genDiffMediaTypeWith genWithoutParams media         return . not $-            moreSpecificThan media media' || moreSpecificThan media' media-    , testProperty "Different parameters" $ do-        media  <- genWithParams+          moreSpecificThan media media' || moreSpecificThan media' media,+      testProperty "Different parameters" $ do+        media <- genWithParams         params <- genDiffParameters $ parameters media-        return . not $ moreSpecificThan media media { parameters = params }-    ]----------------------------------------------------------------------------------testMostSpecific :: Test-testMostSpecific = testGroup "mostSpecific"-    [ testProperty "With */*" $ do-        media <- genConcreteMediaType-        return $ mostSpecific media anything === media .&&.-            mostSpecific anything media === media-    , testProperty "With type/*" $ do-        media <- genConcreteMediaType-        let m1 = media { parameters = Map.empty }-            m2 = m1 { subType = "*" }-        return $ mostSpecific m1 m2 === m1 .&&. mostSpecific m2 m1 === m1-    , testProperty "With parameters" $ do-        media  <- genMediaType-        params <- genParameters-        let media'  = media { parameters = params }-            media'' = media { parameters = Map.empty }-        return $ mostSpecific media' media'' === media' .&&.-            mostSpecific media'' media' === media'-    , testProperty "Different types" $ do-        media  <- genConcreteMediaType-        media' <- genDiffMediaTypeWith genConcreteMediaType media-        return $ mostSpecific media media' === media-    , testProperty "Left biased" $ do-        media  <- genConcreteMediaType-        media' <- genConcreteMediaType-        let media'' = media' { parameters = parameters media }-        return $ mostSpecific media media'' === media .&&.-            mostSpecific media'' media === media''+        return . not $ moreSpecificThan media media {parameters = params}     ] ---------------------------------------------------------------------------------testParseAccept :: Test-testParseAccept = testGroup "parseAccept"+testParseAccept :: TestTree+testParseAccept =+  testGroup+    "parseAccept"     [ testProperty "Valid parse" $ do         media <- genMediaType         let main = mainType media-            sub  = subType media+            sub = subType media         params <- renderParameters (parameters media)         let parsed = parseAccept $ foldedCase (main <> "/" <> sub) <> params-        return $ parsed === Just media-    , testProperty "No sub" $ do+        return $ parsed === Just media,+      testProperty "No sub" $ do         bs <- genByteString-        return $ (parseAccept bs :: Maybe MediaType) === Nothing-    , testProperty "Empty main" $ do+        return $ (parseAccept bs :: Maybe MediaType) === Nothing,+      testProperty "Empty main" $ do         sep <- padString "/"-        bs  <- (sep <>) <$> genByteString-        return $ (parseAccept bs :: Maybe MediaType) === Nothing-    , testProperty "Empty sub" $ do+        bs <- (sep <>) <$> genByteString+        return $ (parseAccept bs :: Maybe MediaType) === Nothing,+      testProperty "Empty sub" $ do         sep <- padString "/"-        bs  <- (<> sep) <$> genByteString-        return $ (parseAccept bs :: Maybe MediaType) === Nothing-    , testProperty "Empty parameters" $ do+        bs <- (<> sep) <$> genByteString+        return $ (parseAccept bs :: Maybe MediaType) === Nothing,+      testProperty "Empty parameters" $ do         sep <- padString ";"-        bs  <- renderHeader <$> genWithoutParams-        return $ (parseAccept (bs <> sep) :: Maybe MediaType) === Nothing-    , testProperty "No value" $-        (=== Nothing) <$> genMediaNameAndParams ""-    , testProperty "Empty value" $ do+        bs <- renderHeader <$> genWithoutParams+        return $ (parseAccept (bs <> sep) :: Maybe MediaType) === Nothing,+      testProperty "No value" $+        (=== Nothing) <$> genMediaNameAndParams "",+      testProperty "Empty value" $ do         eq <- padString "="         (=== Nothing) <$> genMediaNameAndParams eq     ]  genMediaNameAndParams :: ByteString -> Gen (Maybe MediaType) genMediaNameAndParams eq = do-    sep  <- padString ";"-    bs   <- renderHeader <$> genByteString-    name <- genByteString-    ps   <- genMaybeParameters >>= renderParameters-    return $ parseAccept (bs <> sep <> name <> eq <> sep <> ps)-+  sep <- padString ";"+  bs <- renderHeader <$> genByteString+  name <- genByteString+  ps <- genMaybeParameters >>= renderParameters+  return $ parseAccept (bs <> sep <> name <> eq <> sep <> ps) ------------------------------------------------------------------------------- -- | Like 'join', but applies the given function to the first argument. dotJoin :: (a -> a -> b) -> (a -> a) -> a -> b dotJoin f g a = f (g a) a
test/Network/HTTP/Media/Tests.hs view
@@ -1,56 +1,52 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-} ------------------------------------------------------------------------------- module Network.HTTP.Media.Tests (tests) where --------------------------------------------------------------------------------#if !MIN_VERSION_base(4, 8, 0)-import Control.Applicative ((<$>), (<*>))-#endif---------------------------------------------------------------------------------import Control.Monad                        (join, replicateM, (>=>))-import Data.Foldable                        (foldlM)-import Data.Map                             (empty)-import Data.Monoid                          ((<>))-import Data.Word                            (Word16)-import Test.Framework                       (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck---------------------------------------------------------------------------------import Network.HTTP.Media                    hiding (parameters, subType)-import Network.HTTP.Media.Gen                (padString)+import Control.Monad (join, replicateM, (>=>))+import Data.Foldable (foldlM)+import Data.Function (on)+import Data.List (nubBy)+import Data.Map (empty)+import Data.Monoid ((<>))+import Data.Word (Word16)+import Network.HTTP.Media hiding+  ( parameters,+    subType,+  )+import Network.HTTP.Media.Gen (padString) import Network.HTTP.Media.MediaType.Gen import Network.HTTP.Media.MediaType.Internal import Network.HTTP.Media.Quality+import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Prelude hiding ((<>)) --------------------------------------------------------------------------------tests :: [Test]+tests :: [TestTree] tests =-    [ testParse-    , testMatchAccept-    , testMapAccept-    , testMatchContent-    , testMapContent-    , testMatchQuality-    , testMapQuality-    ]-+  [ testParse,+    testMatchAccept,+    testMapAccept,+    testMatchContent,+    testMapContent,+    testMatchQuality,+    testMapQuality+  ] --------------------------------------------------------------------------------testParse :: Test-testParse = testGroup "parseQuality"+testParse :: TestTree+testParse =+  testGroup+    "parseQuality"     [ testProperty "Without quality" $ do-        media    <- medias+        media <- medias         rendered <- padConcat (return . renderHeader) media-        return $ parseQuality rendered === Just (map maxQuality media)-    , testProperty "With quality" $ do-        media    <- qualities+        return $ parseQuality rendered === Just (map maxQuality media),+      testProperty "With quality" $ do+        media <- qualities         rendered <- padConcat padQuality media-        return $ parseQuality rendered === Just media-    , testProperty "With extensions" $ do-        media    <- qualities+        return $ parseQuality rendered === Just media,+      testProperty "With extensions" $ do+        media <- qualities         rendered <- padConcat (padQuality >=> padExtensions) media         return $ parseQuality rendered === Just media     ]@@ -60,145 +56,190 @@     padConcat f l = flip (foldlM (padComma f)) (tail l) =<< f (head l)     padComma f a b = pad a <$> padString "," <*> f b     padQuality qMedia = do-        semi <- padString ";"-        let d = renderHeader (qualityData qMedia)-            v = showQ (qualityValue qMedia)-        return $ d <> semi <> "q=" <> v+      semi <- padString ";"+      let d = renderHeader (qualityData qMedia)+          v = showQ (qualityValue qMedia)+      return $ d <> semi <> "q=" <> v     padExtensions s = genParameters >>= fmap (s <>) . renderParameters     pad a s b = a <> s <> b ---------------------------------------------------------------------------------testMatchAccept :: Test+testMatchAccept :: TestTree testMatchAccept = testMatch "Accept" matchAccept renderHeader ---------------------------------------------------------------------------------testMapAccept :: Test+testMapAccept :: TestTree testMapAccept = testMap "Accept" mapAccept renderHeader ---------------------------------------------------------------------------------testMatchContent :: Test-testMatchContent = testGroup "matchContent"+testMatchContent :: TestTree+testMatchContent =+  testGroup+    "matchContent"     [ testProperty "Matches" $ do         media <- genMediaType-        return $ matchContent [media] (renderHeader media) === Just media-    , testProperty "Nothing" $ do+        return $ matchContent [media] (renderHeader media) === Just media,+      testProperty "Nothing" $ do         content <- genMediaType         parsers <- filter (not . matches content) <$> genServer-        return $ matchContent parsers (renderHeader content) === Nothing-    , testProperty "Against */*" $ do+        return $ matchContent parsers (renderHeader content) === Nothing,+      testProperty "Against */*" $ do         media <- genMediaType         return $-            matchContent [anything] (renderHeader media) === Just anything-    , testProperty "Against type/*" $ do+          matchContent [anything] (renderHeader media) === Just anything,+      testProperty "Against type/*" $ do         media <- genMediaType         let sub = subStarOf media         return $ matchContent [sub] (renderHeader media) === Just sub     ] ---------------------------------------------------------------------------------testMapContent :: Test-testMapContent = testGroup "mapContent"+testMapContent :: TestTree+testMapContent =+  testGroup+    "mapContent"     [ testProperty "Matches" $ do         media <- genMediaType-        return $ mapContent [(media, ())] (renderHeader media) === Just ()-    , testProperty "Nothing" $ do+        return $ mapContent [(media, ())] (renderHeader media) === Just (),+      testProperty "Nothing" $ do         content <- genMediaType         parsers <- join zip . filter (not . matches content) <$> genServer-        return $ mapContent parsers (renderHeader content) === Nothing+        return $ mapContent parsers (renderHeader content) === Nothing,+      testProperty "Overlapping keys" $ do+        (a, b) <- genMatchingPair+        return $ mapContent [(a, False), (b, True)] (renderHeader b)     ] ---------------------------------------------------------------------------------testMatchQuality :: Test+testMatchQuality :: TestTree testMatchQuality = testMatch "Quality" matchQuality id ---------------------------------------------------------------------------------testMapQuality :: Test+testMapQuality :: TestTree testMapQuality = testMap "Quality" mapQuality id ---------------------------------------------------------------------------------testMatch-    :: String-    -> ([MediaType] -> a -> Maybe MediaType)-    -> ([Quality MediaType] -> a)-    -> Test-testMatch name match qToI = testGroup ("match" ++ name)-    [ testProperty "Highest quality" $ do-        server <- genServer-        qs     <- replicateM (length server) $ choose (1, 1000)-        let client = zipWith Quality server qs-            qmax v q = if qualityValue q > qualityValue v then q else v-        return $ match server (qToI client) ===-            Just (qualityData $ foldr1 qmax client)-    , testProperty "Most specific" $ do+testMatch ::+  String ->+  ([MediaType] -> a -> Maybe MediaType) ->+  ([Quality MediaType] -> a) ->+  TestTree+testMatch name match qToI =+  testGroup+    ("match" ++ name)+    [ testProperty "Most specific" $ do         media <- genConcreteMediaType-        let client = qToI $ map maxQuality-                [ MediaType "*" "*" empty-                , media { subType = "*" }-                , media { parameters = empty }-                , media-                ]-        return $ match [media] client === Just media-    , testProperty "Nothing" $ do+        let client =+              qToI $+                map+                  maxQuality+                  [ MediaType "*" "*" empty,+                    media {subType = "*"},+                    media {parameters = empty},+                    media+                  ]+        return $ match [media] client === Just media,+      testProperty "Nothing" $ do         client <- listOf1 genConcreteMediaType         server <- filter (not . flip any client . matches) <$> genServer-        return $ match server (qToI $ map maxQuality client) === Nothing-    , testProperty "Never chooses q=0" $ do-        server <- genServer-        return $ match server (qToI $ map minQuality server) === Nothing-    , testProperty "Left biased" $ do-        server <- genServer+        return $ match server (qToI $ map maxQuality client) === Nothing,+      testProperty "Left biased" $ do+        server <- genNubServer         let client = qToI $ map maxQuality server-        return $ match server client === Just (head server)-    , testProperty "Against */*" $ do-        server <- genServer+        return $ match server client === Just (head server),+      testProperty "Against */*" $ do+        server <- genNubServer         let stars = "*/*" :: MediaType-        return $ match server (qToI [maxQuality stars]) ===-            Just (head server)-    , testProperty "Against type/*" $ do-        server <- genServer+        return $+          match server (qToI [maxQuality stars])+            === Just (head server),+      testProperty "Against type/*" $ do+        server <- genNubServer         let client = qToI [maxQuality (subStarOf $ head server)]-        return $ match server client === Just (head server)+        return $ match server client === Just (head server),+      testQuality match qToI     ] +testQuality ::+  ([MediaType] -> a -> Maybe MediaType) ->+  ([Quality MediaType] -> a) ->+  TestTree+testQuality match qToI =+  testGroup+    "Quality"+    [ testProperty "Highest quality" $ do+        server <- genServer+        qs <- replicateM (length server) $ choose (1, 1000)+        let client = zipWith Quality server qs+            qmax v q = if qualityValue q > qualityValue v then q else v+        return $+          match server (qToI client)+            === Just (qualityData $ foldr1 qmax client),+      testProperty "Most specific quality" $ do+        (a, b) <- genMatchingPair+        c <- genDiffMediaType a+        let client = qToI [quality a "0.5", maxQuality b, maxQuality c]+        return $ match [a, c] client === Just c,+      testQ0 match qToI+    ] --------------------------------------------------------------------------------testMap-    :: String-    -> ([(MediaType, MediaType)] -> a -> Maybe MediaType)-    -> ([Quality MediaType] -> a)-    -> Test-testMap name mapf qToI = testGroup ("map" ++ name)+testQ0 ::+  ([MediaType] -> a -> Maybe MediaType) ->+  ([Quality MediaType] -> a) ->+  TestTree+testQ0 match qToI =+  testGroup+    "q=0"+    [ testProperty "Does not choose a q=0" $ do+        server <- genConcreteMediaType+        return $ match [server] (qToI [minQuality server]) === Nothing,+      testProperty "Does not choose any q=0" $ do+        server <- genServer+        return $ match server (qToI $ map minQuality server) === Nothing,+      testProperty "Does not choose q=0 with less specific type" $ do+        (a, b) <- genMatchingPair+        let client = qToI [minQuality a, maxQuality b]+        return $ match [a] client === Nothing,+      testProperty "Does choose type with q=0 on less specific type" $ do+        (a, b) <- genMatchingPair+        let client = qToI [minQuality b, maxQuality a]+        return $ match [a] client === Just a,+      testProperty "Does not choose q=0 when followed by same type" $ do+        server <- genConcreteMediaType+        let client = qToI [minQuality server, maxQuality server]+        return $ match [server] client === Nothing,+      testProperty "Does not choose q=0 when preceded by same type" $ do+        server <- genConcreteMediaType+        let client = qToI [maxQuality server, minQuality server]+        return $ match [server] client === Nothing+    ]++testMap ::+  String ->+  ([(MediaType, MediaType)] -> a -> Maybe MediaType) ->+  ([Quality MediaType] -> a) ->+  TestTree+testMap name mapf qToI =+  testGroup+    ("map" ++ name)     [ testProperty "Matches" $ do         server <- genServer-        qs     <- replicateM (length server) $ choose (1, 1000 :: Word16)+        qs <- replicateM (length server) $ choose (1, 1000 :: Word16)         let client = zipWith Quality server qs             qmax q v = if qualityValue q >= qualityValue v then q else v             zipped = zip server server-        return $ mapf zipped (qToI client) ===-            Just (qualityData $ foldr1 qmax client)-    , testProperty "Nothing" $ do+        return $+          mapf zipped (qToI client)+            === Just (qualityData $ foldr1 qmax client),+      testProperty "Nothing" $ do         (server, client) <- genServerAndClient-        let zipped = zip server $ repeat "*/*"+        let zipped = map (,"*/*") server         return $ mapf zipped (qToI $ map maxQuality client) === Nothing     ] -------------------------------------------------------------------------------- genServer :: Gen [MediaType] genServer = listOf1 genConcreteMediaType +genNubServer :: Gen [MediaType]+genNubServer = nubBy (on (==) stripParams) <$> genServer ------------------------------------------------------------------------------- genServerAndClient :: Gen ([MediaType], [MediaType]) genServerAndClient = do-    server <- genServer-    client <- filter (not . flip any server . flip matches) <$>-        listOf1 (genDiffMediaTypesWith genConcreteMediaType server)-    return (server, client)+  server <- genServer+  client <-+    filter (not . flip any server . flip matches)+      <$> listOf1 (genDiffMediaTypesWith genConcreteMediaType server)+  return (server, client)
test/Test.hs view
@@ -1,21 +1,22 @@------------------------------------------------------------------------------- module Main (main) where --------------------------------------------------------------------------------import Test.Framework (defaultMain, testGroup)---------------------------------------------------------------------------------import qualified Network.HTTP.Media.Accept.Tests    as Accept-import qualified Network.HTTP.Media.Language.Tests  as Language+import qualified Network.HTTP.Media.Accept.Tests as Accept+import qualified Network.HTTP.Media.Charset.Tests as Charset+import qualified Network.HTTP.Media.Encoding.Tests as Encoding+import qualified Network.HTTP.Media.Language.Tests as Language import qualified Network.HTTP.Media.MediaType.Tests as MediaType-import qualified Network.HTTP.Media.Tests           as Media-+import qualified Network.HTTP.Media.Tests as Media+import Test.Tasty (defaultMain, testGroup) ------------------------------------------------------------------------------- main :: IO ()-main = defaultMain-    [ testGroup "Accept"    Accept.tests-    , testGroup "Language"  Language.tests-    , testGroup "MediaType" MediaType.tests-    , testGroup "Media"     Media.tests-    ]+main =+  defaultMain $+    testGroup+      "http-media"+      [ testGroup "Accept" Accept.tests,+        testGroup "Charset" Charset.tests,+        testGroup "Encoding" Encoding.tests,+        testGroup "Language" Language.tests,+        testGroup "MediaType" MediaType.tests,+        testGroup "Media" Media.tests+      ]