http-media-0.7.1.3/0000755000000000000000000000000000000000000012043 5ustar0000000000000000http-media-0.7.1.3/CHANGES.md0000755000000000000000000000440000000000000013436 0ustar0000000000000000Changelog ========= - [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.7.1.3/LICENSE0000644000000000000000000000204600000000000013052 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.7.1.3/Setup.hs0000644000000000000000000000012700000000000013477 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain http-media-0.7.1.3/http-media.cabal0000644000000000000000000000716000000000000015067 0ustar0000000000000000name: http-media version: 0.7.1.3 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-2017 Timothy Jones category: Web build-type: Simple cabal-version: >= 1.10 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 other-extensions: CPP exposed-modules: Network.HTTP.Media Network.HTTP.Media.Accept Network.HTTP.Media.Language Network.HTTP.Media.MediaType Network.HTTP.Media.RenderHeader other-modules: 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, 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: CPP TupleSections other-modules: Network.HTTP.Media Network.HTTP.Media.Accept Network.HTTP.Media.Accept.Tests Network.HTTP.Media.Gen 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.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 source-repository head type: git location: https://github.com/zmthy/http-media http-media-0.7.1.3/src/Network/HTTP/0000755000000000000000000000000000000000000015042 5ustar0000000000000000http-media-0.7.1.3/src/Network/HTTP/Media.hs0000644000000000000000000002605400000000000016424 0ustar0000000000000000{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ -- | A framework for parsing HTTP media type headers. module Network.HTTP.Media ( -- * Media types MediaType , (//) , (/:) , mainType , subType , parameters , (/?) , (/.) -- * Languages , Language , toParts -- * Accept matching , matchAccept , mapAccept , mapAcceptMedia , mapAcceptLanguage , mapAcceptBytes -- * Content matching , matchContent , mapContent , mapContentMedia , mapContentLanguage -- * Quality values , Quality , quality , maxQuality , minQuality , parseQuality , matchQuality , mapQuality -- * 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) ------------------------------------------------------------------------------ -- | 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 => [a] -- ^ The server-side options -> ByteString -- ^ The client-side header value -> 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 => [(a, b)] -- ^ The map of server-side preferences to values -> ByteString -- ^ The client-side header value -> 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 :: [(MediaType, b)] -- ^ The map of server-side preferences to values -> ByteString -- ^ The client-side header value -> Maybe b mapAcceptMedia = 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) -- > ] mapAcceptLanguage :: [(Language, b)] -- ^ The map of server-side preferences to values -> ByteString -- ^ The client-side header value -> 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) -- > ] mapAcceptBytes :: [(ByteString, b)] -- ^ The map of server-side preferences to values -> ByteString -- ^ The client-side header value -> 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 => [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 ------------------------------------------------------------------------------ -- | 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 => [(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 ------------------------------------------------------------------------------ -- | A specialisation of 'mapContent' that only takes 'MediaType' as its -- input, to avoid ambiguous-type errors when using string literal -- overloading. -- -- > getContentType >>= -- > maybe send415Error readRequestBodyWith . mapContentMedia -- > [ ("application/json", parseJson) -- > , ("text/plain", parseText) -- > ] mapContentMedia :: [(MediaType, b)] -- ^ The map of server-side responses -> ByteString -- ^ The client request's header value -> Maybe b mapContentMedia = mapContent ------------------------------------------------------------------------------ -- | A specialisation of 'mapContent' that only takes 'Language' as its input, -- to avoid ambiguous-type errors when using string literal overloading. -- -- > getContentType >>= -- > maybe send415Error readRequestBodyWith . mapContentLanguage -- > [ ("application/json", parseJson) -- > , ("text/plain", parseText) -- > ] mapContentLanguage :: [(Language, b)] -- ^ The map of server-side responses -> ByteString -- ^ The client request's header value -> 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 => [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 ------------------------------------------------------------------------------ -- | 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 => [(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 ------------------------------------------------------------------------------ -- | 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 http-media-0.7.1.3/src/Network/HTTP/Media/0000755000000000000000000000000000000000000016061 5ustar0000000000000000http-media-0.7.1.3/src/Network/HTTP/Media/Accept.hs0000644000000000000000000000512500000000000017617 0ustar0000000000000000------------------------------------------------------------------------------ -- | Defines the 'Accept' type class, designed to unify types on the matching -- functions in the Media module. module Network.HTTP.Media.Accept ( Accept (..) , mostSpecific ) where import qualified Data.CaseInsensitive as CI import Data.ByteString (ByteString) 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 ------------------------------------------------------------------------------ -- | Evaluates to whichever argument is more specific. Left biased. mostSpecific :: Accept a => a -> a -> a mostSpecific a b | b `moreSpecificThan` a = b | otherwise = a http-media-0.7.1.3/src/Network/HTTP/Media/Language.hs0000644000000000000000000000125400000000000020142 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.7.1.3/src/Network/HTTP/Media/Language/0000755000000000000000000000000000000000000017604 5ustar0000000000000000http-media-0.7.1.3/src/Network/HTTP/Media/Language/Internal.hs0000644000000000000000000000503000000000000021712 0ustar0000000000000000{-# 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 (..)) ------------------------------------------------------------------------------ -- | Suitable for HTTP language-ranges as defined in -- . -- -- Specifically: -- -- > language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" ) 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 && BS.all isAlpha 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.7.1.3/src/Network/HTTP/Media/MediaType.hs0000644000000000000000000000751000000000000020301 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 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) 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 ------------------------------------------------------------------------------ -- | 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 isValidChar 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.7.1.3/src/Network/HTTP/Media/MediaType/0000755000000000000000000000000000000000000017742 5ustar0000000000000000http-media-0.7.1.3/src/Network/HTTP/Media/MediaType/Internal.hs0000644000000000000000000000633400000000000022060 0ustar0000000000000000------------------------------------------------------------------------------ -- | 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) ------------------------------------------------------------------------------ -- | 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) 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.7.1.3/src/Network/HTTP/Media/Quality.hs0000644000000000000000000000577700000000000020065 0ustar0000000000000000------------------------------------------------------------------------------ -- | 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) import Network.HTTP.Media.RenderHeader (RenderHeader (..)) ------------------------------------------------------------------------------ -- | 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 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) ------------------------------------------------------------------------------ -- | 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 ------------------------------------------------------------------------------ -- | 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.7.1.3/src/Network/HTTP/Media/RenderHeader.hs0000644000000000000000000000210600000000000020744 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.7.1.3/src/Network/HTTP/Media/Utils.hs0000644000000000000000000000274700000000000017527 0ustar0000000000000000----------------------------------------------------------------------------- -- | Common utilities. module Network.HTTP.Media.Utils ( breakChar , trimBS , validChars , isValidChar ) where import qualified Data.ByteString.Char8 as BS import Data.ByteString (ByteString) ------------------------------------------------------------------------------ -- | 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. validChars :: [Char] validChars = ['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) http-media-0.7.1.3/test/Network/HTTP/Media/Accept/0000755000000000000000000000000000000000000017450 5ustar0000000000000000http-media-0.7.1.3/test/Network/HTTP/Media/Accept/Tests.hs0000644000000000000000000000355600000000000021117 0ustar0000000000000000{-# 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 ------------------------------------------------------------------------------ tests :: [Test] tests = [ testMatches , testMoreSpecificThan , testMostSpecific ] ------------------------------------------------------------------------------ testMatches :: Test 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 :: Test testMoreSpecificThan = testProperty "moreSpecificThan" $ (not .) . moreSpecificThan <$> genByteString <*> genByteString ------------------------------------------------------------------------------ testMostSpecific :: Test testMostSpecific = testProperty "mostSpecific" $ do string <- genByteString (=== string) . mostSpecific string <$> genByteString http-media-0.7.1.3/test/Network/HTTP/Media/0000755000000000000000000000000000000000000016251 5ustar0000000000000000http-media-0.7.1.3/test/Network/HTTP/Media/Gen.hs0000644000000000000000000000604400000000000017322 0ustar0000000000000000{-# 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 ------------------------------------------------------------------------------ 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) ------------------------------------------------------------------------------ -- | Produces a non-empty ByteString of random characters from the given set. genByteStringFrom :: String -> Gen ByteString genByteStringFrom = fmap BS.pack . listOf1 . elements ------------------------------------------------------------------------------ genCIByteStringFrom :: String -> Gen (CI ByteString) genCIByteStringFrom = fmap CI.mk . genByteStringFrom ------------------------------------------------------------------------------ -- | Produces a non-empty ByteString of random alphanumeric characters. genByteString :: Gen ByteString genByteString = genByteStringFrom (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']) ------------------------------------------------------------------------------ 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 ------------------------------------------------------------------------------ -- | 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 http-media-0.7.1.3/test/Network/HTTP/Media/Language/0000755000000000000000000000000000000000000017774 5ustar0000000000000000http-media-0.7.1.3/test/Network/HTTP/Media/Language/Gen.hs0000644000000000000000000001052000000000000021037 0ustar0000000000000000{-# LANGUAGE CPP, 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 ------------------------------------------------------------------------------ #if !MIN_VERSION_base(4, 8, 0) import Control.Applicative ((<$>)) #endif 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 ------------------------------------------------------------------------------ -- | 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.genCIByteStringFrom (['a'..'z'] ++ ['A'..'Z']) ------------------------------------------------------------------------------ genDiffCIByteString :: CI ByteString -> Gen (CI ByteString) genDiffCIByteString = Gen.genDiffWith genCIByteString http-media-0.7.1.3/test/Network/HTTP/Media/Language/Tests.hs0000644000000000000000000001077400000000000021443 0ustar0000000000000000{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ module Network.HTTP.Media.Language.Tests (tests) where ------------------------------------------------------------------------------ #if !MIN_VERSION_base(4, 8, 0) import Data.Functor ((<$>)) #endif ------------------------------------------------------------------------------ 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 Network.HTTP.Media.Accept import Network.HTTP.Media.Language import Network.HTTP.Media.Language.Gen import Network.HTTP.Media.RenderHeader ------------------------------------------------------------------------------ tests :: [Test] tests = [ testEq , testShow , testFromString , testMatches , testMoreSpecific , testMostSpecific , testParseAccept ] ------------------------------------------------------------------------------ -- Equality is derived, but we test it here to get 100% coverage. testEq :: Test testEq = testGroup "Eq" [ testProperty "==" $ do lang <- genLanguage return $ lang === lang , testProperty "/=" $ do lang <- genLanguage lang' <- genDiffLanguage lang return $ lang /= lang' ] ------------------------------------------------------------------------------ testShow :: Test testShow = testProperty "show" $ do lang <- genLanguage return $ parseAccept (BS.pack $ show lang) === Just lang ------------------------------------------------------------------------------ testFromString :: Test testFromString = testProperty "fromString" $ do lang <- genLanguage return $ lang === fromString (show lang) ------------------------------------------------------------------------------ testMatches :: Test 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 :: Test 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 ] ------------------------------------------------------------------------------ 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 lang <- genLanguage return $ parseAccept (renderHeader lang) === Just lang , testProperty "Trailing hyphen" $ do bs <- renderHeader <$> genLanguage return $ (parseAccept $ bs <> "-" :: Maybe Language) === Nothing ] http-media-0.7.1.3/test/Network/HTTP/Media/MediaType/0000755000000000000000000000000000000000000020132 5ustar0000000000000000http-media-0.7.1.3/test/Network/HTTP/Media/MediaType/Gen.hs0000644000000000000000000001511000000000000021175 0ustar0000000000000000{-# 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 Parameters , genParameters , genMaybeParameters , genDiffParameters -- * Rendering Parameters , renderParameters ) where ------------------------------------------------------------------------------ #if !MIN_VERSION_base(4, 8, 0) import Data.Functor ((<$>)) #endif ------------------------------------------------------------------------------ import qualified Data.Map as Map ------------------------------------------------------------------------------ import Control.Monad (liftM, liftM2) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI, original) import Data.Foldable (foldlM) import Data.Map (fromList) import Data.Monoid ((<>)) import Test.QuickCheck.Gen ------------------------------------------------------------------------------ import Network.HTTP.Media.Gen import Network.HTTP.Media.MediaType.Internal ------------------------------------------------------------------------------ -- | 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 params <- genParameters return $ MediaType main sub params ------------------------------------------------------------------------------ -- | 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 = liftM 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' ------------------------------------------------------------------------------ -- | 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.7.1.3/test/Network/HTTP/Media/MediaType/Tests.hs0000644000000000000000000002315200000000000021573 0ustar0000000000000000{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ module Network.HTTP.Media.MediaType.Tests (tests) where ------------------------------------------------------------------------------ #if !MIN_VERSION_base(4, 8, 0) import Data.Functor ((<$>)) #endif ------------------------------------------------------------------------------ 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 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) ------------------------------------------------------------------------------ tests :: [Test] tests = [ testEq , testShow , testFromString , testHas , testGet , testMatches , testMoreSpecificThan , testMostSpecific , testParseAccept ] ------------------------------------------------------------------------------ -- Equality is derived, but we test it here to get 100% coverage. testEq :: Test testEq = testGroup "Eq" [ testProperty "==" $ do media <- genMediaType return $ media === media , testProperty "/=" $ do media <- genMediaType media' <- genDiffMediaType media return $ media /= media' ] ------------------------------------------------------------------------------ testShow :: Test testShow = testProperty "show" $ do media <- genMediaType return $ parseAccept (BS.pack $ show media) === Just media ------------------------------------------------------------------------------ testFromString :: Test testFromString = testProperty "fromString" $ do media <- genMediaType return $ media === fromString (show media) ------------------------------------------------------------------------------ testHas :: Test 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 $ all (not . (stripParams media /?) . foldedCase) (Map.keys $ parameters media) ] ------------------------------------------------------------------------------ testGet :: Test 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 :: Test 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" $ liftM (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 ] ] ------------------------------------------------------------------------------ testMoreSpecificThan :: Test 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 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 } ] ------------------------------------------------------------------------------ testMostSpecific :: Test testMostSpecific = testGroup "mostSpecific" [ testProperty "With */*" $ do media <- genConcreteMediaType return $ mostSpecific media anything === media .&&. mostSpecific anything media === media , testProperty "With type/*" $ do media <- genConcreteMediaType let m1 = media { parameters = Map.empty } m2 = m1 { subType = "*" } return $ mostSpecific m1 m2 === m1 .&&. mostSpecific m2 m1 === m1 , testProperty "With parameters" $ do media <- genMediaType params <- genParameters let media' = media { parameters = params } media'' = media { parameters = Map.empty } return $ mostSpecific media' media'' === media' .&&. mostSpecific media'' media' === media' , testProperty "Different types" $ do media <- genConcreteMediaType media' <- genDiffMediaTypeWith genConcreteMediaType media return $ mostSpecific media media' === media , testProperty "Left biased" $ do media <- genConcreteMediaType media' <- genConcreteMediaType let media'' = media' { parameters = parameters media } return $ mostSpecific media media'' === media .&&. mostSpecific media'' media === media'' ] ------------------------------------------------------------------------------ testParseAccept :: Test 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.7.1.3/test/Network/HTTP/Media/Tests.hs0000644000000000000000000001725200000000000017716 0ustar0000000000000000{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ 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 Network.HTTP.Media.MediaType.Gen import Network.HTTP.Media.MediaType.Internal import Network.HTTP.Media.Quality ------------------------------------------------------------------------------ tests :: [Test] tests = [ testParse , testMatchAccept , testMapAccept , testMatchContent , testMapContent , testMatchQuality , testMapQuality ] ------------------------------------------------------------------------------ testParse :: Test 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 :: Test testMatchAccept = testMatch "Accept" matchAccept renderHeader ------------------------------------------------------------------------------ testMapAccept :: Test testMapAccept = testMap "Accept" mapAccept renderHeader ------------------------------------------------------------------------------ testMatchContent :: Test testMatchContent = testGroup "matchContent" [ testProperty "Matches" $ do media <- genMediaType return $ matchContent [media] (renderHeader media) === Just media , testProperty "Nothing" $ do content <- genMediaType parsers <- filter (not . matches content) <$> genServer return $ matchContent parsers (renderHeader content) === Nothing , testProperty "Against */*" $ do media <- genMediaType return $ matchContent [anything] (renderHeader media) === Just anything , testProperty "Against type/*" $ do media <- genMediaType let sub = subStarOf media return $ matchContent [sub] (renderHeader media) === Just sub ] ------------------------------------------------------------------------------ testMapContent :: Test testMapContent = testGroup "mapContent" [ 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 ] ------------------------------------------------------------------------------ testMatchQuality :: Test testMatchQuality = testMatch "Quality" matchQuality id ------------------------------------------------------------------------------ testMapQuality :: Test 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 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 "Never chooses q=0" $ do server <- genServer return $ match server (qToI $ map minQuality server) === Nothing , testProperty "Left biased" $ do server <- genServer let client = qToI $ map maxQuality server return $ match server client === Just (head server) , testProperty "Against */*" $ do server <- genServer let stars = "*/*" :: MediaType return $ match server (qToI [maxQuality stars]) === Just (head server) , testProperty "Against type/*" $ do server <- genServer let client = qToI [maxQuality (subStarOf $ head server)] return $ match server client === Just (head server) ] ------------------------------------------------------------------------------ testMap :: String -> ([(MediaType, MediaType)] -> a -> Maybe MediaType) -> ([Quality MediaType] -> a) -> Test 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 = zip server $ repeat "*/*" return $ mapf zipped (qToI $ map maxQuality client) === Nothing ] ------------------------------------------------------------------------------ genServer :: Gen [MediaType] genServer = listOf1 genConcreteMediaType ------------------------------------------------------------------------------ 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.7.1.3/test/0000755000000000000000000000000000000000000013022 5ustar0000000000000000http-media-0.7.1.3/test/Test.hs0000644000000000000000000000152300000000000014276 0ustar0000000000000000------------------------------------------------------------------------------ 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.MediaType.Tests as MediaType import qualified Network.HTTP.Media.Tests as Media ------------------------------------------------------------------------------ main :: IO () main = defaultMain [ testGroup "Accept" Accept.tests , testGroup "Language" Language.tests , testGroup "MediaType" MediaType.tests , testGroup "Media" Media.tests ]