http-media-0.8.0.0/src/0000755000000000000000000000000013455175661012703 5ustar0000000000000000http-media-0.8.0.0/src/Network/0000755000000000000000000000000013455175661014334 5ustar0000000000000000http-media-0.8.0.0/src/Network/HTTP/0000755000000000000000000000000013455206164015104 5ustar0000000000000000http-media-0.8.0.0/src/Network/HTTP/Media/0000755000000000000000000000000013455206164016123 5ustar0000000000000000http-media-0.8.0.0/src/Network/HTTP/Media/Charset/0000755000000000000000000000000013455206164017514 5ustar0000000000000000http-media-0.8.0.0/src/Network/HTTP/Media/Encoding/0000755000000000000000000000000013455206164017651 5ustar0000000000000000http-media-0.8.0.0/src/Network/HTTP/Media/Language/0000755000000000000000000000000013455206164017646 5ustar0000000000000000http-media-0.8.0.0/src/Network/HTTP/Media/MediaType/0000755000000000000000000000000013455175661020013 5ustar0000000000000000http-media-0.8.0.0/test/0000755000000000000000000000000013455206164013064 5ustar0000000000000000http-media-0.8.0.0/test/Network/0000755000000000000000000000000013455175661014524 5ustar0000000000000000http-media-0.8.0.0/test/Network/HTTP/0000755000000000000000000000000013455175661015303 5ustar0000000000000000http-media-0.8.0.0/test/Network/HTTP/Media/0000755000000000000000000000000013455206164016313 5ustar0000000000000000http-media-0.8.0.0/test/Network/HTTP/Media/Accept/0000755000000000000000000000000013455206164017512 5ustar0000000000000000http-media-0.8.0.0/test/Network/HTTP/Media/Charset/0000755000000000000000000000000013455206164017704 5ustar0000000000000000http-media-0.8.0.0/test/Network/HTTP/Media/Encoding/0000755000000000000000000000000013455206164020041 5ustar0000000000000000http-media-0.8.0.0/test/Network/HTTP/Media/Language/0000755000000000000000000000000013455206164020036 5ustar0000000000000000http-media-0.8.0.0/test/Network/HTTP/Media/MediaType/0000755000000000000000000000000013455206164020174 5ustar0000000000000000http-media-0.8.0.0/src/Network/HTTP/Media.hs0000644000000000000000000003320613455206164016463 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 , quality , QualityOrder , qualityOrder , maxQuality , minQuality , parseQuality , matchQuality , mapQuality -- * Accept , Accept (..) -- * Rendering , RenderHeader (..) ) where import Control.Applicative ((<|>)) import qualified Data.ByteString.Char8 as BS import Control.Monad (guard, (>=>)) import Data.ByteString (ByteString) import Data.Foldable (foldl', maximumBy) import Data.Function (on) import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (Proxy)) import Network.HTTP.Media.Accept as Accept import Network.HTTP.Media.Charset as Charset import Network.HTTP.Media.Encoding as Encoding import Network.HTTP.Media.Language as Language import Network.HTTP.Media.MediaType as MediaType import Network.HTTP.Media.Quality import Network.HTTP.Media.RenderHeader import Network.HTTP.Media.Utils (trimBS) ------------------------------------------------------------------------------ -- | 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 '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 :: [(Charset, b)] -- ^ The map of server-side preferences to values -> ByteString -- ^ The client-side header value -> 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 :: [(Encoding, b)] -- ^ The map of server-side preferences to values -> ByteString -- ^ The client-side header value -> 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 :: [(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 -- > [ ("abc", abc) -- > , ("xyz", xyz) -- > ] 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 '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 :: [(Charset, b)] -- ^ The map of server-side responses -> ByteString -- ^ The client request's header value -> 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 :: [(Encoding, b)] -- ^ The map of server-side responses -> ByteString -- ^ The client request's header value -> 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 :: [(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 guard $ not (null options) Quality m q <- maximumBy (compare `on` fmap qualityOrder) optionsq guard $ q /= 0 return m where optionsq = reverse $ map addQuality options addQuality opt = withQValue opt <$> foldl' (mfold opt) Nothing acceptq withQValue opt qv = qv { qualityData = opt } mfold opt cur acq@(Quality acd _) | opt `matches` acd = mostSpecific acq <$> cur <|> Just acq | otherwise = cur ------------------------------------------------------------------------------ -- | 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.8.0.0/src/Network/HTTP/Media/Accept.hs0000644000000000000000000000446213455206164017664 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 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 http-media-0.8.0.0/src/Network/HTTP/Media/Charset.hs0000644000000000000000000000044413455206164020052 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.0.0/src/Network/HTTP/Media/Encoding.hs0000644000000000000000000000045013455206164020204 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.0.0/src/Network/HTTP/Media/Language.hs0000644000000000000000000000125413455175661020213 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.0.0/src/Network/HTTP/Media/MediaType.hs0000644000000000000000000000751013455206164020343 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 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.0.0/src/Network/HTTP/Media/RenderHeader.hs0000644000000000000000000000210613455175661021015 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.0.0/src/Network/HTTP/Media/Charset/Internal.hs0000644000000000000000000000333713455206164021632 0ustar0000000000000000------------------------------------------------------------------------------ -- | Defines the 'Charset' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Charset.Internal ( Charset (..) ) where import qualified Data.ByteString.Char8 as BS import qualified Data.CaseInsensitive as CI import Control.Monad (guard) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI, original) import Data.Maybe (fromMaybe) import Data.String (IsString (..)) import Network.HTTP.Media.Accept (Accept (..)) import Network.HTTP.Media.RenderHeader (RenderHeader (..)) import Network.HTTP.Media.Utils (isValidToken) ------------------------------------------------------------------------------ -- | 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.0.0/src/Network/HTTP/Media/Encoding/Internal.hs0000644000000000000000000000371113455206164021763 0ustar0000000000000000------------------------------------------------------------------------------ -- | Defines the 'Encoding' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Encoding.Internal ( Encoding (..) ) where import qualified Data.ByteString.Char8 as BS import qualified Data.CaseInsensitive as CI import Control.Monad (guard) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI, original) import Data.Maybe (fromMaybe) import Data.String (IsString (..)) import Network.HTTP.Media.Accept (Accept (..)) import Network.HTTP.Media.RenderHeader (RenderHeader (..)) import Network.HTTP.Media.Utils (isValidToken) ------------------------------------------------------------------------------ -- | 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.0.0/src/Network/HTTP/Media/Language/Internal.hs0000644000000000000000000000474113455206164021764 0ustar0000000000000000------------------------------------------------------------------------------ -- | Defines the 'Language' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Language.Internal ( Language (..) ) where import qualified Data.ByteString.Char8 as BS import qualified Data.CaseInsensitive as CI import Control.Monad (guard) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI, original) import Data.Char (isAlpha, isAlphaNum) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe) import Data.String (IsString (..)) import Network.HTTP.Media.Accept (Accept (..)) import Network.HTTP.Media.RenderHeader (RenderHeader (..)) ------------------------------------------------------------------------------ -- | 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.0.0/src/Network/HTTP/Media/MediaType/Internal.hs0000644000000000000000000000633413455175661022131 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.8.0.0/src/Network/HTTP/Media/Quality.hs0000644000000000000000000001042613455206164020112 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} ------------------------------------------------------------------------------ -- | Defines the quality value data type. module Network.HTTP.Media.Quality ( Quality (..) , quality , QualityOrder , qualityOrder , maxQuality , minQuality , mostSpecific , showQ , readQ ) where import qualified Data.ByteString.Char8 as BS import Data.ByteString (ByteString) import Data.ByteString.UTF8 (toString) import Data.Char (isDigit) import Data.List (dropWhileEnd) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Word (Word16, Word32) import Network.HTTP.Media.Accept (Accept, moreSpecificThan) import Network.HTTP.Media.RenderHeader (RenderHeader (..)) ------------------------------------------------------------------------------ -- | 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) ------------------------------------------------------------------------------ -- | 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.0.0/src/Network/HTTP/Media/Utils.hs0000644000000000000000000000472613455206164017570 0ustar0000000000000000----------------------------------------------------------------------------- -- | Common utilities. module Network.HTTP.Media.Utils ( breakChar , trimBS , mediaChars , isMediaChar , tokenChars , isTokenChar , isValidToken ) where import qualified Data.ByteString.Char8 as BS import Data.ByteString (ByteString) import Data.Char (isControl) ------------------------------------------------------------------------------ -- | Equivalent to 'Data.ByteString.break' (on equality against the given -- character), but leaves out the byte that the string is broken on. breakChar :: Char -> ByteString -> Maybe (ByteString, ByteString) breakChar c = safeTail . BS.break (== c) where safeTail (a, b) | BS.null b = Nothing | otherwise = Just (a, BS.tail b) ------------------------------------------------------------------------------ -- | 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.0.0/test/Test.hs0000644000000000000000000000164713455206164014347 0ustar0000000000000000------------------------------------------------------------------------------ module Main (main) where import Test.Framework (defaultMain, testGroup) import qualified Network.HTTP.Media.Accept.Tests as Accept import qualified Network.HTTP.Media.Charset.Tests as Charset import qualified Network.HTTP.Media.Encoding.Tests as Encoding import qualified Network.HTTP.Media.Language.Tests as Language import qualified Network.HTTP.Media.MediaType.Tests as MediaType import qualified Network.HTTP.Media.Tests as Media ------------------------------------------------------------------------------ main :: IO () main = defaultMain [ testGroup "Accept" Accept.tests , testGroup "Charset" Charset.tests , testGroup "Encoding" Encoding.tests , testGroup "Language" Language.tests , testGroup "MediaType" MediaType.tests , testGroup "Media" Media.tests ] http-media-0.8.0.0/test/Network/HTTP/Media/Accept/Tests.hs0000644000000000000000000000240413455206164021150 0ustar0000000000000000------------------------------------------------------------------------------ module Network.HTTP.Media.Accept.Tests (tests) where import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Network.HTTP.Media.Accept import Network.HTTP.Media.Gen ------------------------------------------------------------------------------ tests :: [Test] tests = [ testMatches , testMoreSpecificThan ] ------------------------------------------------------------------------------ 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 http-media-0.8.0.0/test/Network/HTTP/Media/Charset/Gen.hs0000644000000000000000000000303213455206164020747 0ustar0000000000000000{-# LANGUAGE TupleSections #-} ------------------------------------------------------------------------------ -- | Contains definitions for generating 'Charset's. module Network.HTTP.Media.Charset.Gen ( anything , genCharset , genConcreteCharset , genDiffCharset , genDiffConcreteCharsets ) where import Test.QuickCheck.Gen import Network.HTTP.Media.Gen (genDiffWith, genToken) import Network.HTTP.Media.Charset.Internal ------------------------------------------------------------------------------ -- | 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.0.0/test/Network/HTTP/Media/Charset/Tests.hs0000644000000000000000000000602113455206164021341 0ustar0000000000000000------------------------------------------------------------------------------ module Network.HTTP.Media.Charset.Tests (tests) where import qualified Data.ByteString.Char8 as BS import Control.Monad (join) import Data.String (fromString) import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck ((===)) import Network.HTTP.Media.Accept import Network.HTTP.Media.Charset (Charset) import Network.HTTP.Media.Charset.Gen import Network.HTTP.Media.RenderHeader ------------------------------------------------------------------------------ tests :: [Test] tests = [ testEq , testShow , testFromString , testMatches , testMoreSpecific , testParseAccept ] ------------------------------------------------------------------------------ -- Equality is derived, but we test it here to get 100% coverage. testEq :: Test testEq = testGroup "Eq" [ testProperty "==" $ do enc <- genCharset return $ enc === enc , testProperty "/=" $ do enc <- genCharset enc' <- genDiffCharset enc return $ enc /= enc' ] ------------------------------------------------------------------------------ testShow :: Test testShow = testProperty "show" $ do enc <- genCharset return $ parseAccept (BS.pack $ show enc) === Just enc ------------------------------------------------------------------------------ testFromString :: Test testFromString = testProperty "fromString" $ do enc <- genCharset return $ enc === fromString (show enc) ------------------------------------------------------------------------------ testMatches :: Test 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 :: Test testMoreSpecific = testGroup "moreSpecificThan" [ testProperty "Against *" $ flip moreSpecificThan anything <$> genConcreteCharset , testProperty "With *" $ not . moreSpecificThan anything <$> genConcreteCharset , testProperty "Unrelated encodings" $ not . uncurry moreSpecificThan <$> genDiffConcreteCharsets ] ------------------------------------------------------------------------------ testParseAccept :: Test 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.0.0/test/Network/HTTP/Media/Gen.hs0000644000000000000000000000650513455206164017366 0ustar0000000000000000------------------------------------------------------------------------------ -- | Contains definitions for generating 'ByteString's. module Network.HTTP.Media.Gen ( genToken , genByteStringFrom , genCIByteStringFrom , genByteString , genCIByteString , genDiffWith , genDiffByteString , genDiffCIByteString , padString ) where import qualified Data.ByteString.Char8 as BS import qualified Data.CaseInsensitive as CI import qualified Test.QuickCheck.Gen as Gen import qualified Network.HTTP.Media.Utils as Utils import Control.Monad (join, liftM2) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI, original) import Data.Monoid ((<>)) import Test.QuickCheck.Gen (Gen) ------------------------------------------------------------------------------ -- | 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.0.0/test/Network/HTTP/Media/Encoding/Gen.hs0000644000000000000000000000335213455206164021111 0ustar0000000000000000{-# LANGUAGE TupleSections #-} ------------------------------------------------------------------------------ -- | Contains definitions for generating 'Encoding's. module Network.HTTP.Media.Encoding.Gen ( anything , identity , genEncoding , genConcreteEncoding , genDiffEncoding , genDiffConcreteEncodings ) where import Test.QuickCheck.Gen import Network.HTTP.Media.Encoding.Internal import Network.HTTP.Media.Gen (genDiffWith, genToken) ------------------------------------------------------------------------------ -- | 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.0.0/test/Network/HTTP/Media/Encoding/Tests.hs0000644000000000000000000000572213455206164021505 0ustar0000000000000000------------------------------------------------------------------------------ module Network.HTTP.Media.Encoding.Tests (tests) where import qualified Data.ByteString.Char8 as BS import Control.Monad (join) import Data.String (fromString) import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck ((===)) import Network.HTTP.Media.Accept import Network.HTTP.Media.Encoding.Gen import Network.HTTP.Media.RenderHeader ------------------------------------------------------------------------------ tests :: [Test] tests = [ testEq , testShow , testFromString , testMatches , testMoreSpecific , testParseAccept ] ------------------------------------------------------------------------------ -- Equality is derived, but we test it here to get 100% coverage. testEq :: Test testEq = testGroup "Eq" [ testProperty "==" $ do enc <- genEncoding return $ enc === enc , testProperty "/=" $ do enc <- genEncoding enc' <- genDiffEncoding enc return $ enc /= enc' ] ------------------------------------------------------------------------------ testShow :: Test testShow = testProperty "show" $ do enc <- genEncoding return $ parseAccept (BS.pack $ show enc) === Just enc ------------------------------------------------------------------------------ testFromString :: Test testFromString = testProperty "fromString" $ do enc <- genEncoding return $ enc === fromString (show enc) ------------------------------------------------------------------------------ testMatches :: Test 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 :: Test testMoreSpecific = testGroup "moreSpecificThan" [ testProperty "Against *" $ flip moreSpecificThan anything <$> genConcreteEncoding , testProperty "With *" $ not . moreSpecificThan anything <$> genConcreteEncoding , testProperty "Unrelated encodings" $ not . uncurry moreSpecificThan <$> genDiffConcreteEncodings ] ------------------------------------------------------------------------------ testParseAccept :: Test 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.0.0/test/Network/HTTP/Media/Language/Gen.hs0000644000000000000000000001010713455206164021102 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 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.genCIByteString ------------------------------------------------------------------------------ genDiffCIByteString :: CI ByteString -> Gen (CI ByteString) genDiffCIByteString = Gen.genDiffWith genCIByteString http-media-0.8.0.0/test/Network/HTTP/Media/Language/Tests.hs0000644000000000000000000000701013455206164021472 0ustar0000000000000000------------------------------------------------------------------------------ module Network.HTTP.Media.Language.Tests (tests) where import qualified Data.ByteString.Char8 as BS import Control.Monad (join) import Data.Monoid ((<>)) import Data.String (fromString) import Test.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 , 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 ] ------------------------------------------------------------------------------ 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.8.0.0/test/Network/HTTP/Media/MediaType/Gen.hs0000644000000000000000000001722713455206164021252 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 qualified Data.Map as Map import Control.Monad (filterM, 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' ------------------------------------------------------------------------------ -- | 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.0.0/test/Network/HTTP/Media/MediaType/Tests.hs0000644000000000000000000002001713455206164021632 0ustar0000000000000000------------------------------------------------------------------------------ module Network.HTTP.Media.MediaType.Tests (tests) where import qualified Data.ByteString.Char8 as BS import qualified Data.Map as Map import Control.Monad (join, 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 , 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 } ] ------------------------------------------------------------------------------ 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.8.0.0/test/Network/HTTP/Media/Tests.hs0000644000000000000000000002307313455206164017756 0ustar0000000000000000------------------------------------------------------------------------------ module Network.HTTP.Media.Tests (tests) where import Control.Monad (join, replicateM, (>=>)) import Data.Foldable (foldlM) import Data.Function (on) import Data.List (nubBy) import Data.Map (empty) import Data.Monoid ((<>)) import Data.Word (Word16) import Test.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 "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) -> Test 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) -> Test testQ0 match qToI = testGroup "q=0" [ testProperty "Does not choose a q=0" $ do server <- genConcreteMediaType return $ match [server] (qToI [minQuality server]) === Nothing , testProperty "Does not choose any q=0" $ do server <- genServer return $ match server (qToI $ map minQuality server) === Nothing , testProperty "Does not choose q=0 with less specific type" $ do (a, b) <- genMatchingPair let client = qToI [minQuality a, maxQuality b] return $ match [a] client === Nothing , testProperty "Does choose type with q=0 on less specific type" $ do (a, b) <- genMatchingPair let client = qToI [minQuality b, maxQuality a] return $ match [a] client === Just a , testProperty "Does not choose q=0 when followed by same type" $ do server <- genConcreteMediaType let client = qToI [minQuality server, maxQuality server] return $ match [server] client === Nothing , testProperty "Does not choose q=0 when preceded by same type" $ do server <- genConcreteMediaType let client = qToI [maxQuality server, minQuality server] return $ match [server] client === Nothing ] ------------------------------------------------------------------------------ testMap :: String -> ([(MediaType, MediaType)] -> a -> Maybe MediaType) -> ([Quality MediaType] -> a) -> Test testMap name mapf qToI = testGroup ("map" ++ name) [ 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 ------------------------------------------------------------------------------ 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.0.0/LICENSE0000644000000000000000000000204613455175661013123 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.0.0/Setup.hs0000644000000000000000000000012713455175661013550 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain http-media-0.8.0.0/http-media.cabal0000644000000000000000000000777513455206164015145 0ustar0000000000000000name: http-media version: 0.8.0.0 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-2019 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 exposed-modules: Network.HTTP.Media Network.HTTP.Media.Accept Network.HTTP.Media.Charset Network.HTTP.Media.Encoding Network.HTTP.Media.Language Network.HTTP.Media.MediaType Network.HTTP.Media.RenderHeader other-modules: Network.HTTP.Media.Charset.Internal Network.HTTP.Media.Encoding.Internal Network.HTTP.Media.Language.Internal Network.HTTP.Media.MediaType.Internal Network.HTTP.Media.Quality Network.HTTP.Media.Utils build-depends: base >= 4.7 && < 4.13, bytestring >= 0.10 && < 0.11, 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.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.8 && < 2.14, 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.8.0.0/CHANGES.md0000644000000000000000000000615413455206341013502 0ustar0000000000000000Changelog ========= - [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.