http-media-0.8.1.1/0000755000000000000000000000000007346545000012104 5ustar0000000000000000http-media-0.8.1.1/CHANGES.md0000644000000000000000000000711207346545000013477 0ustar0000000000000000Changelog ========= - [Version 0.8.1.1](https://github.com/zmthy/http-media/releases/tag/v0.8.1.1) Fixed a bug when mapping againt a client-side content header where a match would be overridden by a more specific key earlier in the map. The bounds for tasty have been updated to include the latest version. - [Version 0.8.1.0](https://github.com/zmthy/http-media/releases/tag/v0.8.1.0) Exposed `qualityData` accessor. Added `isAcceptable` to allow filtering out unacceptable items. - [Version 0.8.0.0](https://github.com/zmthy/http-media/releases/tag/v0.8.0.0) Removed official support for GHC 7.8. A separate `QualityOrder` type can now be extracted from a `Quality` value for performing comparisons without the attached data value. The most specific match will now be used to assign a quality value to each server option, ensuring that less specific matches cannot override lower quality values on more specific matches. In particular, if a type is considered unacceptable by the client, then a separate match with a non-zero quality value cannot make it acceptable. Numeric characters are now permitted in the tail of a Language value. Added support for Accept-Encoding and Content-Encoding. Added support for Accept-Charset and Content-Charset. The bounds for QuickCheck have been updated to include the latest version. - [Version 0.7.1.3](https://github.com/zmthy/http-media/releases/tag/v0.7.1.3) Package bounds have been updated for GHC 8.6. - [Version 0.7.1.2](https://github.com/zmthy/http-media/releases/tag/v0.7.1.2) The bounds for QuickCheck have been updated to include the latest version. - [Version 0.7.1.1](https://github.com/zmthy/http-media/releases/tag/v0.7.1.1) The bounds for base have been updated to include support for GHC 8.2. - [Version 0.7.1](https://github.com/zmthy/http-media/releases/tag/v0.7.1) Travis now tests against a range of Stackage LTS environments, instead of using multi-ghc. Support for base-4.6 has now been correctly removed in the Cabal file. - [Version 0.7.0](https://github.com/zmthy/http-media/releases/tag/v0.7.0) The Travis configuration has dropped support for GHC 7.6 and added support for 8.0. More direct constructors for quality values are now available, to avoid having to deal with `Maybe` results when you are certain parsing a quality string will not fail. The bounds for QuickCheck have been updated to include the latest version. - [Version 0.6.4](https://github.com/zmthy/http-media/releases/tag/v0.6.4) The bounds for QuickCheck have been updated to include the latest version. - [Version 0.6.3](https://github.com/zmthy/http-media/releases/tag/v0.6.3) Parse failures more regularly return a `Maybe` value instead of raising an exception. The `(//)` smart constructor now accepts wildcard arguments, but only in the correct order. Most tests will now emit a counter example if their relevant properties are violated. Some tests which were not correctly covering their properties have been fixed. The `-Werror` flag has been removed from the test suite. - [Version 0.6.2](https://github.com/zmthy/http-media/releases/tag/v0.6.2) The test suite now uses the test-framework library instead of cabal-test-quickcheck, and the package no longer depends on Cabal. - [Version 0.6.1](https://github.com/zmthy/http-media/releases/tag/v0.6.1) The type errors and build warnings caused by the BBP have been fixed for GHC 7.10. - [Version 0.6.0](https://github.com/zmthy/http-media/releases/tag/v0.6.0) All of the publicly exposed data types now derive an `Ord` instance. http-media-0.8.1.1/LICENSE0000644000000000000000000000204607346545000013113 0ustar0000000000000000Copyright (c) 2012-2015 Timothy Jones Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. http-media-0.8.1.1/Setup.hs0000644000000000000000000000012707346545000013540 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain http-media-0.8.1.1/http-media.cabal0000644000000000000000000001005507346545000015125 0ustar0000000000000000name: http-media version: 0.8.1.1 license: MIT license-file: LICENSE author: Timothy Jones maintainer: Timothy Jones homepage: https://github.com/zmthy/http-media bug-reports: https://github.com/zmthy/http-media/issues copyright: (c) 2012-2023 Timothy Jones category: Web build-type: Simple cabal-version: >= 1.10 tested-with: GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.5 , GHC == 9.6.2 synopsis: Processing HTTP Content-Type and Accept headers description: This library is intended to be a comprehensive solution to parsing and selecting quality-indexed values in HTTP headers. It is capable of parsing both media types and language parameters from the Accept and Content header families, and can be extended to match against other accept headers as well. Selecting the appropriate header value is achieved by comparing a list of server options against the quality-indexed values supplied by the client. . In the following example, the Accept header is parsed and then matched against a list of server options to serve the appropriate media using 'mapAcceptMedia': . > getHeader >>= maybe send406Error sendResourceWith . mapAcceptMedia > [ ("text/html", asHtml) > , ("application/json", asJson) > ] . Similarly, the Content-Type header can be used to produce a parser for request bodies based on the given content type with 'mapContentMedia': . > getContentType >>= maybe send415Error readRequestBodyWith . mapContentMedia > [ ("application/json", parseJson) > , ("text/plain", parseText) > ] . The API is agnostic to your choice of server. extra-source-files: CHANGES.md library default-language: Haskell2010 ghc-options: -Wall hs-source-dirs: src default-extensions: OverloadedStrings exposed-modules: Network.HTTP.Media Network.HTTP.Media.Accept Network.HTTP.Media.Charset Network.HTTP.Media.Encoding Network.HTTP.Media.Language Network.HTTP.Media.MediaType Network.HTTP.Media.RenderHeader other-modules: Network.HTTP.Media.Charset.Internal Network.HTTP.Media.Encoding.Internal Network.HTTP.Media.Language.Internal Network.HTTP.Media.MediaType.Internal Network.HTTP.Media.Quality Network.HTTP.Media.Utils build-depends: base >= 4.8 && < 5, bytestring >= 0.10 && < 0.12, case-insensitive >= 1.0 && < 1.3, containers >= 0.5 && < 0.7, utf8-string >= 0.3 && < 1.1 test-suite test-http-media type: exitcode-stdio-1.0 main-is: Test.hs default-language: Haskell2010 ghc-options: -Wall hs-source-dirs: src test default-extensions: OverloadedStrings other-extensions: TupleSections other-modules: Network.HTTP.Media Network.HTTP.Media.Accept Network.HTTP.Media.Accept.Tests Network.HTTP.Media.Charset Network.HTTP.Media.Charset.Gen Network.HTTP.Media.Charset.Internal Network.HTTP.Media.Charset.Tests Network.HTTP.Media.Gen Network.HTTP.Media.Encoding Network.HTTP.Media.Encoding.Gen Network.HTTP.Media.Encoding.Internal Network.HTTP.Media.Encoding.Tests Network.HTTP.Media.Language Network.HTTP.Media.Language.Gen Network.HTTP.Media.Language.Internal Network.HTTP.Media.Language.Tests Network.HTTP.Media.MediaType Network.HTTP.Media.MediaType.Gen Network.HTTP.Media.MediaType.Internal Network.HTTP.Media.MediaType.Tests Network.HTTP.Media.Quality Network.HTTP.Media.RenderHeader Network.HTTP.Media.Tests Network.HTTP.Media.Utils build-depends: base >= 4.8 && < 5, bytestring >= 0.10 && < 0.12, case-insensitive >= 1.0 && < 1.3, containers >= 0.5 && < 0.7, utf8-string >= 0.3 && < 1.1, QuickCheck >= 2.8 && < 2.15, tasty >= 0.11 && < 1.6, tasty-quickcheck >= 0.8 && < 0.11 source-repository head type: git location: https://github.com/zmthy/http-media http-media-0.8.1.1/src/Network/HTTP/0000755000000000000000000000000007346545000015103 5ustar0000000000000000http-media-0.8.1.1/src/Network/HTTP/Media.hs0000644000000000000000000002767607346545000016500 0ustar0000000000000000-- | A framework for parsing HTTP media type headers. module Network.HTTP.Media ( -- * Media types MediaType, (//), (/:), mainType, subType, parameters, (/?), (/.), -- * Charsets Charset, -- * Encodings Encoding, -- * Languages Language, toParts, -- * Accept matching matchAccept, mapAccept, mapAcceptMedia, mapAcceptCharset, mapAcceptEncoding, mapAcceptLanguage, mapAcceptBytes, -- * Content matching matchContent, mapContent, mapContentMedia, mapContentCharset, mapContentEncoding, mapContentLanguage, -- * Quality values Quality (qualityData), quality, QualityOrder, qualityOrder, isAcceptable, maxQuality, minQuality, parseQuality, matchQuality, mapQuality, -- * Accept Accept (..), -- * Rendering 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 -- with the same quality level and specificity, then the first one in the -- server list is chosen. -- -- The use of the 'Accept' type class allows the application of either -- 'MediaType' for the standard Accept header or 'ByteString' for any other -- Accept header which can be marked with a quality value. -- -- > matchAccept ["text/html", "application/json"] <$> getHeader -- -- For more information on the matching process see RFC 2616, section 14.1-4. 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. -- -- > getHeader >>= maybe render406Error renderResource . mapAccept -- > [ ("text" // "html", asHtml) -- > , ("application" // "json", asJson) -- > ] 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. -- -- > getHeader >>= maybe render406Error renderResource . mapAcceptMedia -- > [ ("text/html", asHtml) -- > , ("application/json", asJson) -- > ] mapAcceptMedia :: -- | 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 -- > [ ("en-gb", inBritishEnglish) -- > , ("fr", inFrench) -- > ] mapAcceptLanguage :: -- | The map of server-side preferences to values [(Language, b)] -> -- | The client-side header value ByteString -> Maybe b mapAcceptLanguage = mapAccept -- | A specialisation of 'mapAccept' that only takes 'ByteString' as its -- input, to avoid ambiguous-type errors when using string literal -- overloading. -- -- > getHeader >>= maybe render406Error encodeResourceWith . mapAcceptBytes -- > [ ("abc", abc) -- > , ("xyz", xyz) -- > ] mapAcceptBytes :: -- | 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). -- -- > matchContent ["application/json", "text/plain"] <$> getContentType -- -- For more information on the matching process see RFC 2616, section 14.17. 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. -- -- > getContentType >>= maybe send415Error readRequestBodyWith . mapContent -- > [ ("application" // "json", parseJson) -- > , ("text" // "plain", parseText) -- > ] 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. -- -- > getContentType >>= -- > maybe send415Error readRequestBodyWith . mapContentMedia -- > [ ("application/json", parseJson) -- > , ("text/plain", parseText) -- > ] mapContentMedia :: -- | The map of server-side responses [(MediaType, b)] -> -- | The client request's header value ByteString -> Maybe b mapContentMedia = mapContent -- | A specialisation of 'mapContent' that only takes 'Charset' as its input, -- to avoid ambiguous-type errors when using string literal overloading. -- -- > getContentCharset >>= -- > maybe send415Error readRequestBodyWith . mapContentCharset -- > [ ("utf-8", parseUtf8) -- > , ("us-ascii", parseAscii) -- > ] mapContentCharset :: -- | The map of server-side responses [(Charset, b)] -> -- | The client request's header value ByteString -> Maybe b mapContentCharset = mapContent -- | A specialisation of 'mapContent' that only takes 'Encoding' as its input, -- to avoid ambiguous-type errors when using string literal overloading. -- -- > getContentEncoding >>= -- > maybe send415Error readRequestBodyWith . mapContentEncoding -- > [ ("compress", decompress) -- > , ("identity", id) -- > ] mapContentEncoding :: -- | The map of server-side responses [(Encoding, b)] -> -- | The client request's header value ByteString -> Maybe b mapContentEncoding = mapContent -- | A specialisation of 'mapContent' that only takes 'Language' as its input, -- to avoid ambiguous-type errors when using string literal overloading. -- -- > getContentLanguage >>= -- > maybe send415Error readRequestBodyWith . mapContentLanguage -- > [ ("en-gb", parseBritishEnglish) -- > , ("fr", parseFrench) -- > ] mapContentLanguage :: -- | The map of server-side responses [(Language, b)] -> -- | The client request's header value ByteString -> Maybe b mapContentLanguage = mapContent -- | Parses a full Accept header into a list of quality-valued media types. parseQuality :: (Accept a) => ByteString -> Maybe [Quality a] parseQuality = parseQuality' Proxy parseQuality' :: (Accept a) => Proxy a -> ByteString -> Maybe [Quality a] parseQuality' p = (. map trimBS . BS.split ',') . mapM $ \s -> let (accept, q) = fromMaybe (s, Nothing) $ if ext then findQ s else getQ s in maybe (pure maxQuality) (fmap (flip Quality) . readQ) q <*> parseAccept accept where ext = hasExtensionParameters p -- Split on ';', and check if a quality value is there. A value of Nothing -- indicates there was no parameter, whereas a value of Nothing in the -- pair indicates the parameter was not a quality value. getQ s = let (a, b) = trimBS <$> BS.breakEnd (== ';') s in if BS.null a then Nothing else Just ( BS.init a, if BS.isPrefixOf "q=" b then Just (BS.drop 2 b) else Nothing ) -- Trawl backwards through the string, ignoring extension parameters. findQ s = do let q = getQ s (a, m) <- q maybe (findQ a) (const q) m -- | Matches a list of server-side resource options against a pre-parsed -- quality-marked list of client-side preferences. A result of 'Nothing' means -- that nothing matched (which should indicate a 406 error). If two or more -- results arise with the same quality level and specificity, then the first -- one in the server list is chosen. -- -- The use of the 'Accept' type class allows the application of either -- 'MediaType' for the standard Accept header or 'ByteString' for any other -- Accept header which can be marked with a quality value. -- -- > matchQuality ["text/html", "application/json"] <$> parseQuality header -- -- For more information on the matching process see RFC 2616, section 14.1-4. 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. -- -- > parseQuality header >>= maybe render406Error renderResource . mapQuality -- > [ ("text" // "html", asHtml) -- > , ("application" // "json", asJson) -- > ] 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 -- | 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 http-media-0.8.1.1/src/Network/HTTP/Media/0000755000000000000000000000000007346545000016122 5ustar0000000000000000http-media-0.8.1.1/src/Network/HTTP/Media/Accept.hs0000644000000000000000000000406107346545000017656 0ustar0000000000000000-- | Defines the 'Accept' type class, designed to unify types on the matching -- functions in the Media module. module Network.HTTP.Media.Accept ( Accept (..), ) where import Data.ByteString (ByteString) import qualified Data.CaseInsensitive as CI import Data.Proxy (Proxy) -- | Defines methods for a type whose values can be matched against each -- other in terms of an HTTP Accept-* header. -- -- This allows functions to work on both the standard Accept header and -- others such as Accept-Language that still may use quality values. class (Show a) => Accept a where -- | Specifies how to parse an Accept-* header after quality has been -- handled. parseAccept :: ByteString -> Maybe a -- | 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 -- | 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 http-media-0.8.1.1/src/Network/HTTP/Media/Charset.hs0000644000000000000000000000030507346545000020045 0ustar0000000000000000-- | 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 http-media-0.8.1.1/src/Network/HTTP/Media/Charset/0000755000000000000000000000000007346545000017513 5ustar0000000000000000http-media-0.8.1.1/src/Network/HTTP/Media/Charset/Internal.hs0000644000000000000000000000251307346545000021624 0ustar0000000000000000-- | Defines the 'Charset' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Charset.Internal ( Charset (..), ) where import Control.Monad (guard) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.CaseInsensitive (CI, original) import qualified Data.CaseInsensitive as CI import Data.Maybe (fromMaybe) import Data.String (IsString (..)) import Network.HTTP.Media.Accept (Accept (..)) import Network.HTTP.Media.RenderHeader (RenderHeader (..)) import Network.HTTP.Media.Utils (isValidToken) -- | Suitable for HTTP charset as defined in -- . -- -- Specifically: -- -- > charset = token / "*" newtype Charset = Charset (CI ByteString) deriving (Eq, Ord) instance Show Charset where show = BS.unpack . renderHeader instance IsString Charset where fromString str = flip fromMaybe (parseAccept $ BS.pack str) $ error $ "Invalid encoding literal " ++ str instance Accept Charset where parseAccept bs = do guard $ isValidToken bs return $ Charset (CI.mk bs) matches _ (Charset "*") = True matches a b = a == b moreSpecificThan _ (Charset "*") = True moreSpecificThan _ _ = False instance RenderHeader Charset where renderHeader (Charset e) = original e http-media-0.8.1.1/src/Network/HTTP/Media/Encoding.hs0000644000000000000000000000031107346545000020177 0ustar0000000000000000-- | 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 http-media-0.8.1.1/src/Network/HTTP/Media/Encoding/0000755000000000000000000000000007346545000017650 5ustar0000000000000000http-media-0.8.1.1/src/Network/HTTP/Media/Encoding/Internal.hs0000644000000000000000000000305507346545000021763 0ustar0000000000000000-- | Defines the 'Encoding' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Encoding.Internal ( Encoding (..), ) where import Control.Monad (guard) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.CaseInsensitive (CI, original) import qualified Data.CaseInsensitive as CI import Data.Maybe (fromMaybe) import Data.String (IsString (..)) import Network.HTTP.Media.Accept (Accept (..)) import Network.HTTP.Media.RenderHeader (RenderHeader (..)) import Network.HTTP.Media.Utils (isValidToken) -- | Suitable for HTTP encoding as defined in -- . -- -- Specifically: -- -- > codings = content-coding / "identity" / "*" newtype Encoding = Encoding (CI ByteString) deriving (Eq, Ord) instance Show Encoding where show = BS.unpack . renderHeader instance IsString Encoding where fromString str = flip fromMaybe (parseAccept $ BS.pack str) $ error $ "Invalid encoding literal " ++ str instance Accept Encoding where -- This handles the case where the header value is empty, but it also -- allows technically invalid values such as "compress;q=0.8,;q=0.5". parseAccept "" = Just $ Encoding "identity" parseAccept bs = do guard $ isValidToken bs return $ Encoding (CI.mk bs) matches _ (Encoding "*") = True matches a b = a == b moreSpecificThan _ (Encoding "*") = True moreSpecificThan _ _ = False instance RenderHeader Encoding where renderHeader (Encoding e) = original e http-media-0.8.1.1/src/Network/HTTP/Media/Language.hs0000644000000000000000000000070507346545000020203 0ustar0000000000000000-- | Defines the 'Language' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Language ( Language, toParts, ) where import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) import Network.HTTP.Media.Language.Internal -- | Converts 'Language' to a list of its language parts. The wildcard -- produces an empty list. toParts :: Language -> [CI ByteString] toParts (Language l) = l http-media-0.8.1.1/src/Network/HTTP/Media/Language/0000755000000000000000000000000007346545000017645 5ustar0000000000000000http-media-0.8.1.1/src/Network/HTTP/Media/Language/Internal.hs0000644000000000000000000000404207346545000021755 0ustar0000000000000000-- | Defines the 'Language' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Language.Internal ( Language (..), ) where import Control.Monad (guard) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.CaseInsensitive (CI, original) import qualified Data.CaseInsensitive as CI import Data.Char (isAlpha, isAlphaNum) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe) import Data.String (IsString (..)) import Network.HTTP.Media.Accept (Accept (..)) import Network.HTTP.Media.RenderHeader (RenderHeader (..)) -- | Suitable for HTTP language-ranges as defined in -- . -- -- Specifically: -- -- > language-range = (1*8ALPHA *("-" 1*8alphanum)) / "*" newtype Language = Language [CI ByteString] deriving (Eq, Ord) -- Note that internally, Language [] equates to *. instance Show Language where show = BS.unpack . renderHeader instance IsString Language where fromString "*" = Language [] fromString str = flip fromMaybe (parseAccept $ BS.pack str) $ error $ "Invalid language literal " ++ str instance Accept Language where parseAccept "*" = Just $ Language [] parseAccept bs = do let pieces = BS.split '-' bs guard $ not (null pieces) Language <$> mapM check pieces where check part = do let len = BS.length part guard $ len >= 1 && len <= 8 && isAlpha (BS.head part) && BS.all isAlphaNum (BS.tail part) return (CI.mk part) -- Languages match if the right argument is a prefix of the left. matches (Language a) (Language b) = b `isPrefixOf` a -- The left language is more specific than the right if the right -- arguments is a strict prefix of the left. moreSpecificThan (Language a) (Language b) = b `isPrefixOf` a && length a > length b instance RenderHeader Language where renderHeader (Language []) = "*" renderHeader (Language l) = BS.intercalate "-" (map original l) http-media-0.8.1.1/src/Network/HTTP/Media/MediaType.hs0000644000000000000000000000540607346545000020344 0ustar0000000000000000-- | 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, (//), (/:), -- * Querying 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.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 -- | Adds a parameter to a 'MediaType'. Can produce an error if either -- string is invalid. (/:) :: MediaType -> (ByteString, ByteString) -> MediaType (MediaType a b p) /: (k, v) = MediaType a b $ insert (ensureR k) (ensureV v) p -- | Evaluates if a 'MediaType' has a parameter of the given name. (/?) :: MediaType -> ByteString -> Bool (MediaType _ _ p) /? k = Map.member (CI.mk k) p -- | Retrieves a parameter from a 'MediaType'. (/.) :: MediaType -> ByteString -> Maybe (CI ByteString) (MediaType _ _ p) /. k = Map.lookup (CI.mk k) p -- | Ensures that the 'ByteString' matches the ABNF for `reg-name` in RFC -- 4288. ensureR :: ByteString -> CI ByteString ensureR bs = CI.mk $ if l == 0 || l > 127 then error $ "Invalid length for " ++ show bs else ensure isMediaChar bs where l = BS.length bs -- | 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) http-media-0.8.1.1/src/Network/HTTP/Media/MediaType/0000755000000000000000000000000007346545000020003 5ustar0000000000000000http-media-0.8.1.1/src/Network/HTTP/Media/MediaType/Internal.hs0000644000000000000000000000523607346545000022121 0ustar0000000000000000-- | Defined to allow the constructor of 'MediaType' to be exposed to tests. module Network.HTTP.Media.MediaType.Internal ( 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 { -- | 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 instance IsString MediaType where 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 '=' 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) 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) -- | 'MediaType' parameters. type Parameters = Map (CI ByteString) (CI ByteString) http-media-0.8.1.1/src/Network/HTTP/Media/Quality.hs0000644000000000000000000000674107346545000020116 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} -- | Defines the quality value data type. module Network.HTTP.Media.Quality ( Quality (..), quality, QualityOrder, qualityOrder, isAcceptable, maxQuality, minQuality, mostSpecific, showQ, readQ, ) where import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.ByteString.UTF8 (toString) import Data.Char (isDigit) import Data.List (dropWhileEnd) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Word (Word16, Word32) import Network.HTTP.Media.Accept (Accept, moreSpecificThan) import Network.HTTP.Media.RenderHeader (RenderHeader (..)) import Prelude hiding ((<>)) -- | Attaches a quality value to data. data Quality a = Quality { qualityData :: a, qualityValue :: Word16 } deriving (Eq, Functor, Ord) instance (RenderHeader a) => Show (Quality a) where show = BS.unpack . renderHeader instance (RenderHeader h) => RenderHeader (Quality h) where renderHeader (Quality a q) = renderHeader a <> ";q=" <> showQ q -- | Manually construct a quality value. quality :: a -> ByteString -> Quality a quality x q = Quality x $ flip fromMaybe (readQ q) $ error ("Invalid quality value " ++ toString q) -- | An opaque ordered representation of quality values without attached data. newtype QualityOrder = QualityOrder Word16 deriving (Eq, Ord) -- | Whether the quality value is greater than zero; otherwise the value -- should never be accepted, even when no other options are available. isAcceptable :: Quality a -> Bool isAcceptable (Quality _ 0) = False isAcceptable (Quality _ _) = True -- | Remove the attached data from a quality value, retaining only the -- priority of the quality parameter. qualityOrder :: Quality a -> QualityOrder qualityOrder = QualityOrder . qualityValue -- | Attaches the quality value '1'. maxQuality :: a -> Quality a maxQuality = flip Quality 1000 -- | Attaches the quality value '0'. minQuality :: a -> Quality a minQuality = flip Quality 0 -- | Combines quality values by specificity. Selects the more specific of the -- two arguments, but if they are the same returns the data of the left -- argument with the two quality values of both arguments combined. mostSpecific :: (Accept a) => Quality a -> Quality a -> Quality a mostSpecific (Quality a q) (Quality b r) | a `moreSpecificThan` b = Quality a q | b `moreSpecificThan` a = Quality b r | otherwise = Quality a q' where q' = fromIntegral (fromIntegral q * fromIntegral r `div` 1000 :: Word32) -- | Converts the integral value into its standard quality representation. showQ :: Word16 -> ByteString showQ 1000 = "1" showQ 0 = "0" showQ q = "0." <> BS.replicate (3 - length s) '0' <> b 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 where h = BS.head bs t = BS.tail bs read1 :: ByteString -> Maybe Word16 read1 bs | BS.null bs || h == '.' && BS.length t < 4 && BS.all (== '0') t = Just 1000 | otherwise = Nothing where h = BS.head bs t = BS.tail bs read0 :: ByteString -> Maybe Word16 read0 bs | BS.null bs = Just 0 | h == '.' && BS.length t < 4 && BS.all isDigit t = Just (toWord (t <> BS.replicate (3 - BS.length t) '0')) | otherwise = Nothing where h = BS.head bs t = BS.tail bs toWord = read . BS.unpack http-media-0.8.1.1/src/Network/HTTP/Media/RenderHeader.hs0000644000000000000000000000162307346545000021010 0ustar0000000000000000-- | Defines the 'RenderHeader' type class, with the 'renderHeader' method. -- 'renderHeader' can be used to render basic header values (acting as -- identity on 'ByteString's), but it will also work on lists of quality -- values, which provides the necessary interface for rendering the full -- possibilities of Accept headers. module Network.HTTP.Media.RenderHeader ( RenderHeader (..), ) where import Data.ByteString (ByteString, intercalate) -- | A class for header values, so they may be rendered to their 'ByteString' -- representation. Lists of header values and quality-marked header values -- will render appropriately. class RenderHeader h where -- | Render a header value to a UTF-8 'ByteString'. renderHeader :: h -> ByteString instance RenderHeader ByteString where renderHeader = id instance (RenderHeader h) => RenderHeader [h] where renderHeader = intercalate "," . map renderHeader http-media-0.8.1.1/src/Network/HTTP/Media/Utils.hs0000644000000000000000000000363307346545000017563 0ustar0000000000000000-- | Common utilities. module Network.HTTP.Media.Utils ( breakChar, trimBS, mediaChars, isMediaChar, tokenChars, isTokenChar, isValidToken, ) where import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Char (isControl) -- | Equivalent to 'Data.ByteString.break' (on equality against the given -- character), but leaves out the byte that the string is broken on. breakChar :: Char -> ByteString -> Maybe (ByteString, ByteString) breakChar c = safeTail . BS.break (== c) where safeTail (a, b) | BS.null b = Nothing | otherwise = Just (a, BS.tail b) -- | Trims tab and space characters from both ends of a ByteString. trimBS :: ByteString -> ByteString trimBS = fst . BS.spanEnd isLWS . BS.dropWhile isLWS where isLWS c = c == ' ' || c == '\t' -- | List of the valid characters for a media-type `reg-name` as per RFC 4288. mediaChars :: [Char] mediaChars = ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ "!#$&.+-^_" -- | Evaluates whether the given character is valid in a media type `reg-name` -- as per RFC 4288. isMediaChar :: Char -> Bool isMediaChar = (`elem` mediaChars) -- | Evaluates whether the given character is valid in an HTTP header token as -- per RFC 2616. isTokenChar :: Char -> Bool isTokenChar = (||) <$> not . isControl <*> (`notElem` separators) where separators = [ '(', ')', '<', '>', '@', ',', ';', ':', '\\', '"', '/', '[', ']', '?', '=', '{', '}', ' ' ] -- | 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 http-media-0.8.1.1/test/Network/HTTP/Media/Accept/0000755000000000000000000000000007346545000017511 5ustar0000000000000000http-media-0.8.1.1/test/Network/HTTP/Media/Accept/Tests.hs0000644000000000000000000000160607346545000021152 0ustar0000000000000000module Network.HTTP.Media.Accept.Tests (tests) where import Network.HTTP.Media.Accept import Network.HTTP.Media.Gen import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) tests :: [TestTree] tests = [ testMatches, testMoreSpecificThan ] testMatches :: TestTree testMatches = testGroup "matches" [ testProperty "Does match" $ do string <- genByteString return $ matches string string, testProperty "Doesn't match" $ do string <- genByteString string' <- genDiffByteString string return . not $ matches string string' ] -- | Note that this test never actually generates any strings, as they are not -- required for the 'moreSpecificThan' test. testMoreSpecificThan :: TestTree testMoreSpecificThan = testProperty "moreSpecificThan" $ (not .) . moreSpecificThan <$> genByteString <*> genByteString http-media-0.8.1.1/test/Network/HTTP/Media/Charset/0000755000000000000000000000000007346545000017703 5ustar0000000000000000http-media-0.8.1.1/test/Network/HTTP/Media/Charset/Gen.hs0000644000000000000000000000200307346545000020743 0ustar0000000000000000{-# 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 http-media-0.8.1.1/test/Network/HTTP/Media/Charset/Tests.hs0000644000000000000000000000433407346545000021345 0ustar0000000000000000module 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 ] http-media-0.8.1.1/test/Network/HTTP/Media/Encoding/0000755000000000000000000000000007346545000020040 5ustar0000000000000000http-media-0.8.1.1/test/Network/HTTP/Media/Encoding/Gen.hs0000644000000000000000000000220207346545000021101 0ustar0000000000000000{-# 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 http-media-0.8.1.1/test/Network/HTTP/Media/Encoding/Tests.hs0000644000000000000000000000426107346545000021501 0ustar0000000000000000module 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 ] http-media-0.8.1.1/test/Network/HTTP/Media/0000755000000000000000000000000007346545000016312 5ustar0000000000000000http-media-0.8.1.1/test/Network/HTTP/Media/Gen.hs0000644000000000000000000000473207346545000017365 0ustar0000000000000000-- | Contains definitions for generating 'ByteString's. module Network.HTTP.Media.Gen ( genToken, genByteStringFrom, genCIByteStringFrom, genByteString, genCIByteString, genDiffWith, genDiffByteString, genDiffCIByteString, padString, ) where import Control.Monad (join, liftM2) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.CaseInsensitive (CI, original) import qualified Data.CaseInsensitive as CI import Data.Monoid ((<>)) import qualified Network.HTTP.Media.Utils as Utils import Test.QuickCheck.Gen (Gen) import qualified Test.QuickCheck.Gen as Gen import Prelude hiding ((<>)) -- | Generates a valid header token. genToken :: Gen (CI ByteString) genToken = genCIByteStringFrom Utils.tokenChars -- | Produces a non-empty ByteString of random characters from the given set. genByteStringFrom :: String -> Gen ByteString genByteStringFrom = fmap BS.pack . Gen.listOf1 . Gen.elements genCIByteStringFrom :: String -> Gen (CI ByteString) genCIByteStringFrom = fmap CI.mk . genByteStringFrom -- | Produces a non-empty ByteString of random alphanumeric characters with a -- non-numeric head. genByteString :: Gen ByteString genByteString = fmap BS.pack . (:) <$> 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 = Gen.suchThat gen . (/=) -- | Produces a non-empty ByteString of random alphanumeric characters that -- is case-insensitively different to the given one. genDiffByteString :: ByteString -> Gen ByteString genDiffByteString = fmap original . genDiffCIByteString . CI.mk -- | Produces a non-empty case-insensitive ByteString of random alphanumeric -- characters that is different to the given one. genDiffCIByteString :: CI ByteString -> Gen (CI ByteString) genDiffCIByteString = genDiffWith genCIByteString -- | Pad a 'ByteString' with a random amount of tab and space characters. padString :: ByteString -> Gen ByteString padString c = join (liftM2 pad) (BS.pack <$> Gen.listOf (Gen.elements " \t")) where pad a b = a <> c <> b http-media-0.8.1.1/test/Network/HTTP/Media/Language/0000755000000000000000000000000007346545000020035 5ustar0000000000000000http-media-0.8.1.1/test/Network/HTTP/Media/Language/Gen.hs0000644000000000000000000000552007346545000021104 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- | Contains definitions for generating 'Language's. module Network.HTTP.Media.Language.Gen ( -- * Generating Languages anything, genLanguage, genConcreteLanguage, genDiffLanguage, genMatchingLanguage, genDiffMatchingLanguage, genNonMatchingLanguage, genMatchingLanguages, genDiffMatchingLanguages, genNonMatchingLanguages, ) where import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) import qualified Network.HTTP.Media.Gen as Gen import Network.HTTP.Media.Language.Internal import Test.QuickCheck.Gen -- | The Language that matches anything. anything :: Language anything = Language [] -- | Generates any kind of Language. genLanguage :: Gen Language genLanguage = Language <$> listOf genCIByteString -- | Generates a Language that does not match everything. genConcreteLanguage :: Gen Language genConcreteLanguage = Language <$> listOf1 genCIByteString -- | Generates a different Language to the given one. genDiffLanguage :: Language -> Gen Language genDiffLanguage (Language []) = genConcreteLanguage genDiffLanguage l = Gen.genDiffWith genLanguage l -- | Generate a Language that has the given language as a prefix. genMatchingLanguage :: Language -> Gen Language genMatchingLanguage (Language pre) = Language . (pre ++) <$> listOf genCIByteString -- | Generate a Language that has the given language as a proper prefix. genDiffMatchingLanguage :: Language -> Gen Language genDiffMatchingLanguage (Language pre) = Language . (pre ++) <$> listOf1 genCIByteString -- | Generate a Language that does not have the given language as a prefix. genNonMatchingLanguage :: Language -> Gen Language genNonMatchingLanguage (Language []) = genConcreteLanguage genNonMatchingLanguage (Language (pre : _)) = do pre' <- genDiffCIByteString pre genMatchingLanguage $ Language [pre'] -- | A private definition for generating pairs of languagues. genLanguages :: (Language -> Gen Language) -> Gen (Language, Language) genLanguages gen = do pre <- genLanguage (pre,) <$> gen pre -- | Generate two languages, the first of which is a prefix of the second. genMatchingLanguages :: Gen (Language, Language) genMatchingLanguages = genLanguages genMatchingLanguage -- | Generate two languages, the first of which is a proper prefix of the -- second. genDiffMatchingLanguages :: Gen (Language, Language) genDiffMatchingLanguages = genLanguages genDiffMatchingLanguage -- | Generate two languages, the first of which is not a prefix of the second. genNonMatchingLanguages :: Gen (Language, Language) genNonMatchingLanguages = do pre <- genConcreteLanguage (pre,) <$> genNonMatchingLanguage pre genCIByteString :: Gen (CI ByteString) genCIByteString = resize 8 Gen.genCIByteString genDiffCIByteString :: CI ByteString -> Gen (CI ByteString) genDiffCIByteString = Gen.genDiffWith genCIByteString http-media-0.8.1.1/test/Network/HTTP/Media/Language/Tests.hs0000644000000000000000000000533307346545000021477 0ustar0000000000000000module Network.HTTP.Media.Language.Tests (tests) where import Control.Monad (join) import qualified Data.ByteString.Char8 as BS import Data.Monoid ((<>)) import Data.String (fromString) import Network.HTTP.Media.Accept import Network.HTTP.Media.Language import Network.HTTP.Media.Language.Gen import Network.HTTP.Media.RenderHeader import Test.QuickCheck ((===)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Prelude hiding ((<>)) tests :: [TestTree] tests = [ testEq, testShow, testFromString, testMatches, testMoreSpecific, testParseAccept ] -- Equality is derived, but we test it here to get 100% coverage. testEq :: TestTree testEq = testGroup "Eq" [ testProperty "==" $ do lang <- genLanguage return $ lang === lang, testProperty "/=" $ do lang <- genLanguage lang' <- genDiffLanguage lang return $ lang /= lang' ] testShow :: TestTree testShow = testProperty "show" $ do lang <- genLanguage return $ parseAccept (BS.pack $ show lang) === Just lang testFromString :: TestTree testFromString = testProperty "fromString" $ do lang <- genLanguage return $ lang === fromString (show lang) testMatches :: TestTree testMatches = testGroup "matches" [ testProperty "Equal values match" $ join matches <$> genLanguage, testProperty "Right prefix matches left" $ uncurry (flip matches) <$> genMatchingLanguages, testProperty "Left prefix does not match right" $ not . uncurry matches <$> genDiffMatchingLanguages, testProperty "* matches anything" $ flip matches anything <$> genLanguage, testProperty "No concrete language matches *" $ not . matches anything <$> genConcreteLanguage ] testMoreSpecific :: TestTree testMoreSpecific = testGroup "moreSpecificThan" [ testProperty "Against *" $ flip moreSpecificThan anything <$> genConcreteLanguage, testProperty "With *" $ not . moreSpecificThan anything <$> genLanguage, testProperty "Proper prefix lhs" $ not . uncurry moreSpecificThan <$> genDiffMatchingLanguages, testProperty "Proper prefix rhs" $ uncurry (flip moreSpecificThan) <$> genDiffMatchingLanguages, testProperty "Unrelated languages" $ not . uncurry moreSpecificThan <$> genNonMatchingLanguages ] testParseAccept :: TestTree testParseAccept = testGroup "parseAccept" [ testProperty "Valid parse" $ do lang <- genLanguage return $ parseAccept (renderHeader lang) === Just lang, testProperty "Trailing hyphen" $ do bs <- renderHeader <$> genLanguage return $ (parseAccept $ bs <> "-" :: Maybe Language) === Nothing ] http-media-0.8.1.1/test/Network/HTTP/Media/MediaType/0000755000000000000000000000000007346545000020173 5ustar0000000000000000http-media-0.8.1.1/test/Network/HTTP/Media/MediaType/Gen.hs0000644000000000000000000001305407346545000021243 0ustar0000000000000000-- | Contains definitions for generating 'MediaType's. module Network.HTTP.Media.MediaType.Gen ( -- * Generating MediaTypes anything, genMediaType, genSubStar, genMaybeSubStar, subStarOf, genConcreteMediaType, genWithoutParams, genWithParams, stripParams, genDiffMediaTypesWith, genDiffMediaTypeWith, genDiffMediaTypes, genDiffMediaType, genMatchingPair, -- * Generating Parameters genParameters, genMaybeParameters, genDiffParameters, -- * Rendering Parameters renderParameters, ) where import Control.Monad (filterM, liftM2) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI, original) import Data.Foldable (foldlM) import Data.Map (fromList) import qualified Data.Map as Map import Data.Monoid ((<>)) import Network.HTTP.Media.Gen import Network.HTTP.Media.MediaType.Internal import Test.QuickCheck.Gen import Prelude hiding ((<>)) -- | Parameter entry for testing. type ParamEntry = (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 -- | 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} -- | 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 -- | Generates a concrete MediaType with no parameters. genWithoutParams :: Gen MediaType genWithoutParams = do main <- genCIByteString sub <- genCIByteString return $ MediaType main sub Map.empty -- | Generates a MediaType with at least one parameter. genWithParams :: Gen MediaType genWithParams = do main <- genCIByteString sub <- genCIByteString MediaType main sub <$> genParameters -- | Strips the parameters from the given MediaType. stripParams :: MediaType -> MediaType 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' -- | Generates a different MediaType to the given one, using the given -- generator. genDiffMediaTypeWith :: Gen MediaType -> MediaType -> Gen MediaType genDiffMediaTypeWith gen = genDiffMediaTypesWith gen . (: []) -- | Generates a different MediaType to the ones in the given list. genDiffMediaTypes :: [MediaType] -> Gen MediaType genDiffMediaTypes = genDiffMediaTypesWith genMediaType -- | Generates a different MediaType to the given one. genDiffMediaType :: MediaType -> Gen MediaType genDiffMediaType = genDiffMediaTypes . (: []) -- | Reuse for 'mayParams' and 'someParams'. mkGenParams :: (Gen ParamEntry -> Gen [ParamEntry]) -> Gen Parameters mkGenParams = fmap fromList . ($ liftM2 (,) (genDiffCIByteString "q") genCIByteString) -- | 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' -- | Generates a set of parameters that is a strict submap of the given -- parameters. genSubParameters :: Parameters -> Gen (Maybe Parameters) genSubParameters params | Map.null params = return Nothing | otherwise = Just . Map.fromList <$> genStrictSublist where list = Map.toList params genStrictSublist = do sublist <- filterM (const $ choose (False, True)) list if sublist == list then genStrictSublist else return sublist -- | Generates a pair of non-equal MediaType values that are in a 'matches' -- relation, with the more specific value on the left. genMatchingPair :: Gen (MediaType, MediaType) genMatchingPair = do a <- oneof [genSubStar, genConcreteMediaType] b <- if subType a == "*" then return anything else oneof $ withSubParameters a : map return [subStarOf a, anything] return (a, b) where withSubParameters a = do params <- genSubParameters (parameters a) return $ case params of Just sub -> a {parameters = sub} Nothing -> subStarOf a -- | Render parameters with a generated amount of whitespace between the -- semicolons. Note that there is a leading semicolon in front of the -- parameters, as it is expected that this will always be attached to -- a preceding 'MediaType' rendering. renderParameters :: Parameters -> Gen ByteString renderParameters params = foldlM pad "" (Map.toList params) where pad s (k, v) = (s <>) . (<> original k <> "=" <> original v) <$> padString ";" http-media-0.8.1.1/test/Network/HTTP/Media/MediaType/Tests.hs0000644000000000000000000001554207346545000021640 0ustar0000000000000000module Network.HTTP.Media.MediaType.Tests (tests) where import Control.Monad (join) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.CaseInsensitive (foldedCase) import qualified Data.Map as Map import Data.Monoid ((<>)) import Data.String (fromString) import Network.HTTP.Media.Accept import Network.HTTP.Media.Gen import Network.HTTP.Media.MediaType ((/.), (/?)) import Network.HTTP.Media.MediaType.Gen import Network.HTTP.Media.MediaType.Internal import Network.HTTP.Media.RenderHeader (renderHeader) import Test.QuickCheck (property, (.&&.), (===)) import Test.QuickCheck.Gen (Gen) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Prelude hiding ((<>)) tests :: [TestTree] tests = [ testEq, testShow, testFromString, testHas, testGet, testMatches, testMoreSpecificThan, testParseAccept ] -- Equality is derived, but we test it here to get 100% coverage. testEq :: TestTree testEq = testGroup "Eq" [ testProperty "==" $ do media <- genMediaType return $ media === media, testProperty "/=" $ do media <- genMediaType media' <- genDiffMediaType media return $ media /= media' ] testShow :: TestTree testShow = testProperty "show" $ do media <- genMediaType return $ parseAccept (BS.pack $ show media) === Just media testFromString :: TestTree testFromString = testProperty "fromString" $ do media <- genMediaType return $ media === fromString (show media) 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 media <- genWithParams return . not $ any ((stripParams media /?) . foldedCase) (Map.keys $ parameters media) ] testGet :: TestTree testGet = testGroup "(/.)" [ testProperty "Retrieves property it has" $ do 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 media <- genWithParams let is n _ = (.&&. stripParams media /. foldedCase n === Nothing) return $ Map.foldrWithKey is (property True) $ parameters media ] 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 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 media <- genConcreteMediaType sub <- genDiffCIByteString $ subType media return . not $ matches media media {subType = sub} || matches media {subType = sub} media, testProperty "Different parameters don't match" $ not . dotJoin matches stripParams <$> genWithParams, testProperty "Missing parameters match" $ do media <- genWithParams let media' = stripParams media return $ matches media media' && not (matches media' media), testGroup "*/*" [ testProperty "Matches itself" $ matches anything anything, testProperty "Matches anything on the right" $ (`matches` anything) <$> genMediaType, testProperty "Doesn't match more specific on the left" $ 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 :: TestTree testMoreSpecificThan = testGroup "moreSpecificThan" [ testProperty "Against */*" $ (`moreSpecificThan` anything) <$> genMaybeSubStar, testProperty "With */*" $ not . (anything `moreSpecificThan`) <$> genMaybeSubStar, testProperty "Against type/*" $ dotJoin (flip moreSpecificThan) subStarOf <$> genConcreteMediaType, testProperty "With type/*" $ not . dotJoin moreSpecificThan subStarOf <$> genConcreteMediaType, testProperty "With parameters" $ dotJoin (flip moreSpecificThan) stripParams <$> genWithParams, testProperty "Different types" $ do media <- genWithoutParams media' <- genDiffMediaTypeWith genWithoutParams media return . not $ moreSpecificThan media media' || moreSpecificThan media' media, testProperty "Different parameters" $ do media <- genWithParams params <- genDiffParameters $ parameters media return . not $ moreSpecificThan media media {parameters = params} ] testParseAccept :: TestTree testParseAccept = testGroup "parseAccept" [ testProperty "Valid parse" $ do media <- genMediaType let main = mainType media sub = subType media params <- renderParameters (parameters media) let parsed = parseAccept $ foldedCase (main <> "/" <> sub) <> params return $ parsed === Just media, testProperty "No sub" $ do bs <- genByteString return $ (parseAccept bs :: Maybe MediaType) === Nothing, testProperty "Empty main" $ do sep <- padString "/" bs <- (sep <>) <$> genByteString return $ (parseAccept bs :: Maybe MediaType) === Nothing, testProperty "Empty sub" $ do sep <- padString "/" bs <- (<> sep) <$> genByteString return $ (parseAccept bs :: Maybe MediaType) === Nothing, testProperty "Empty parameters" $ do sep <- padString ";" bs <- renderHeader <$> genWithoutParams return $ (parseAccept (bs <> sep) :: Maybe MediaType) === Nothing, testProperty "No value" $ (=== Nothing) <$> genMediaNameAndParams "", testProperty "Empty value" $ do eq <- padString "=" (=== Nothing) <$> genMediaNameAndParams eq ] genMediaNameAndParams :: ByteString -> Gen (Maybe MediaType) genMediaNameAndParams eq = do sep <- padString ";" bs <- renderHeader <$> genByteString name <- genByteString ps <- genMaybeParameters >>= renderParameters return $ parseAccept (bs <> sep <> name <> eq <> sep <> ps) -- | Like 'join', but applies the given function to the first argument. dotJoin :: (a -> a -> b) -> (a -> a) -> a -> b dotJoin f g a = f (g a) a http-media-0.8.1.1/test/Network/HTTP/Media/Tests.hs0000644000000000000000000002027407346545000017755 0ustar0000000000000000{-# LANGUAGE TupleSections #-} module Network.HTTP.Media.Tests (tests) where import Control.Monad (join, replicateM, (>=>)) import Data.Foldable (foldlM) import Data.Function (on) import Data.List (nubBy) import Data.Map (empty) import Data.Monoid ((<>)) import Data.Word (Word16) import Network.HTTP.Media hiding ( parameters, subType, ) import Network.HTTP.Media.Gen (padString) import Network.HTTP.Media.MediaType.Gen import Network.HTTP.Media.MediaType.Internal import Network.HTTP.Media.Quality import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Prelude hiding ((<>)) tests :: [TestTree] tests = [ testParse, testMatchAccept, testMapAccept, testMatchContent, testMapContent, testMatchQuality, testMapQuality ] testParse :: TestTree testParse = testGroup "parseQuality" [ testProperty "Without quality" $ do media <- medias rendered <- padConcat (return . renderHeader) media return $ parseQuality rendered === Just (map maxQuality media), testProperty "With quality" $ do media <- qualities rendered <- padConcat padQuality media return $ parseQuality rendered === Just media, testProperty "With extensions" $ do media <- qualities rendered <- padConcat (padQuality >=> padExtensions) media return $ parseQuality rendered === Just media ] where medias = listOf1 genMediaType qualities = medias >>= mapM (flip fmap (choose (0, 1000)) . Quality) padConcat f l = flip (foldlM (padComma f)) (tail l) =<< f (head l) padComma f a b = pad a <$> padString "," <*> f b padQuality qMedia = do semi <- padString ";" let d = renderHeader (qualityData qMedia) v = showQ (qualityValue qMedia) return $ d <> semi <> "q=" <> v padExtensions s = genParameters >>= fmap (s <>) . renderParameters pad a s b = a <> s <> b testMatchAccept :: TestTree testMatchAccept = testMatch "Accept" matchAccept renderHeader testMapAccept :: TestTree testMapAccept = testMap "Accept" mapAccept renderHeader testMatchContent :: TestTree testMatchContent = testGroup "matchContent" [ testProperty "Matches" $ do media <- genMediaType return $ matchContent [media] (renderHeader media) === Just media, testProperty "Nothing" $ do content <- genMediaType parsers <- filter (not . matches content) <$> genServer return $ matchContent parsers (renderHeader content) === Nothing, testProperty "Against */*" $ do media <- genMediaType return $ matchContent [anything] (renderHeader media) === Just anything, testProperty "Against type/*" $ do media <- genMediaType let sub = subStarOf media return $ matchContent [sub] (renderHeader media) === Just sub ] testMapContent :: TestTree testMapContent = testGroup "mapContent" [ testProperty "Matches" $ do media <- genMediaType return $ mapContent [(media, ())] (renderHeader media) === Just (), testProperty "Nothing" $ do content <- genMediaType parsers <- join zip . filter (not . matches content) <$> genServer return $ mapContent parsers (renderHeader content) === Nothing, testProperty "Overlapping keys" $ do (a, b) <- genMatchingPair return $ mapContent [(a, False), (b, True)] (renderHeader b) ] testMatchQuality :: TestTree testMatchQuality = testMatch "Quality" matchQuality id testMapQuality :: TestTree testMapQuality = testMap "Quality" mapQuality id testMatch :: String -> ([MediaType] -> a -> Maybe MediaType) -> ([Quality MediaType] -> a) -> TestTree testMatch name match qToI = testGroup ("match" ++ name) [ testProperty "Most specific" $ do media <- genConcreteMediaType let client = qToI $ map maxQuality [ MediaType "*" "*" empty, media {subType = "*"}, media {parameters = empty}, media ] return $ match [media] client === Just media, testProperty "Nothing" $ do client <- listOf1 genConcreteMediaType server <- filter (not . flip any client . matches) <$> genServer return $ match server (qToI $ map maxQuality client) === Nothing, testProperty "Left biased" $ do server <- genNubServer let client = qToI $ map maxQuality server return $ match server client === Just (head server), testProperty "Against */*" $ do server <- genNubServer let stars = "*/*" :: MediaType return $ match server (qToI [maxQuality stars]) === Just (head server), testProperty "Against type/*" $ do server <- genNubServer let client = qToI [maxQuality (subStarOf $ head server)] return $ match server client === Just (head server), testQuality match qToI ] 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 ] 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) 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 (server, client) <- genServerAndClient 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) http-media-0.8.1.1/test/0000755000000000000000000000000007346545000013063 5ustar0000000000000000http-media-0.8.1.1/test/Test.hs0000644000000000000000000000140107346545000014332 0ustar0000000000000000module Main (main) where import qualified Network.HTTP.Media.Accept.Tests as Accept import qualified Network.HTTP.Media.Charset.Tests as Charset import qualified Network.HTTP.Media.Encoding.Tests as Encoding import qualified Network.HTTP.Media.Language.Tests as Language import qualified Network.HTTP.Media.MediaType.Tests as MediaType import qualified Network.HTTP.Media.Tests as Media import Test.Tasty (defaultMain, testGroup) main :: IO () main = defaultMain $ testGroup "http-media" [ testGroup "Accept" Accept.tests, testGroup "Charset" Charset.tests, testGroup "Encoding" Encoding.tests, testGroup "Language" Language.tests, testGroup "MediaType" MediaType.tests, testGroup "Media" Media.tests ]