diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2012 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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain + diff --git a/http-media.cabal b/http-media.cabal new file mode 100644 --- /dev/null +++ b/http-media.cabal @@ -0,0 +1,81 @@ +name: http-media +version: 0.1.0 +license: MIT +license-file: LICENSE +author: Timothy Jones +maintainer: Timothy Jones +homepage: http://github.com/zimothy/http-media +bug-reports: http://github.com/zimothy/http-media/issues +category: Web +copyright: (c) 2013 Timothy Jones +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 media + types, including quality parameters, in HTTP headers. It addresses parsing of + the Content-Type and Accept headers, and includes general data types for + matching against the other accept headers as well. It encodes MIME parameters + into a 'MediaType' data, and allows the matching of the final value by + comparing quality values from the client. + +library + hs-source-dirs: src + + ghc-options: -Wall + + default-language: Haskell2010 + default-extensions: + OverloadedStrings + + exposed-modules: + Network.HTTP.Media + Network.HTTP.Media.MediaType + other-modules: + Network.HTTP.Media.Match + Network.HTTP.Media.MediaType.Internal + Network.HTTP.Media.Quality + Network.HTTP.Media.Utils + build-depends: + base >= 4.6.0 && < 5.0, + bytestring >= 0.10.0 && < 0.11, + containers >= 0.5.0 && < 0.6, + utf8-string >= 0.3.7 && < 0.4 + +test-suite test-http-media + type: detailed-0.9 + hs-source-dirs: src test + + default-language: Haskell2010 + default-extensions: + OverloadedStrings + + test-module: Tests + other-modules: + Network.HTTP.Media + Network.HTTP.Media.Gen + Network.HTTP.Media.Match + Network.HTTP.Media.Match.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.Tests + Network.HTTP.Media.Utils + + ghc-options: -Wall -fhpc + + build-depends: + base >= 4.6.0 && < 5.0, + bytestring >= 0.10.0 && < 0.11, + Cabal >= 1.18.0 && < 1.19, + cabal-test-quickcheck >= 0.1.0 && < 0.2, + containers >= 0.5.0 && < 0.6, + QuickCheck >= 2.6 && < 2.7, + utf8-string >= 0.3.7 && < 0.4 + +source-repository head + type: git + location: git://github.com/zimothy/http-media.git + diff --git a/src/Network/HTTP/Media.hs b/src/Network/HTTP/Media.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Media.hs @@ -0,0 +1,140 @@ +------------------------------------------------------------------------------ +-- | A framework for parsing HTTP media type headers. +module Network.HTTP.Media + ( + -- * Media types + MediaType + , (//) + , (/:) + , mainType + , subType + , parameters + , (/?) + , (/.) + , matches + , Quality + + -- * Parsing + , parseAccept + + -- * Accept matching + , matchAccept + , mapAccept + + -- * Content matching + , matchContent + , mapContent + ) where + +------------------------------------------------------------------------------ +import qualified Data.ByteString as BS + +------------------------------------------------------------------------------ +import Control.Applicative (pure, (<*>), (<|>)) +import Control.Monad (guard) +import Data.ByteString (ByteString, split) +import Data.ByteString.UTF8 (toString) + +------------------------------------------------------------------------------ +import Network.HTTP.Media.Match as Match +import Network.HTTP.Media.MediaType as MediaType +import Network.HTTP.Media.Quality +import Network.HTTP.Media.Utils + + +------------------------------------------------------------------------------ +-- | Parses a full Accept header into a list of quality-valued media types. +parseAccept :: ByteString -> Maybe [Quality MediaType] +parseAccept = (. split comma) . mapM $ \bs -> + let (accept, q) = BS.breakSubstring ";q=" $ BS.filter (/= space) bs + in (<*> parse accept) $ if BS.null q + then pure maxQuality else fmap (flip Quality) $ readQ + (toString $ BS.takeWhile (/= semi) $ BS.drop 3 q) + + +------------------------------------------------------------------------------ +-- | 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 'Match' 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. The standard +-- application of this function for 'MediaType' should be in conjunction with +-- 'parseAccepts'. +-- +-- > parseAccepts header >>= matchQuality resourceTypeOptions +-- +-- For more information on the matching process see RFC 2616, section 14. +matchAccept + :: Match a + => [a] -- ^ The server-side options + -> [Quality a] -- ^ The client-side preferences + -> Maybe a +matchAccept server clientq = guard (hq /= 0) >> specific qs + where + merge (Quality c q) = map (`Quality` q) $ filter (`matches` c) server + matched = concatMap merge clientq + (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 + + +------------------------------------------------------------------------------ +-- | 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. +-- +-- > maybe render406Error renderResource $ parseAccepts header >>= mapQuality +-- > [ ("text/html", asHtml) +-- > , ("application/json", asJson) +-- > ] +mapAccept + :: Match a + => [(a, b)] -- ^ The map of server-side preferences to values + -> [Quality a] -- ^ The client-side preferences + -> Maybe b +mapAccept s c = matchAccept (map fst s) c >>= lookupMatches s + + +------------------------------------------------------------------------------ +-- | 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). +-- +-- As with the Accept parsing, he use of the 'Match' type class allows the +-- application of either 'MediaType' or 'ByteString'. +matchContent + :: Match a + => a -- ^ The client's request value + -> [a] -- ^ The server-side response options + -> Maybe a +matchContent client = foldl choose Nothing + where choose m server = m <|> (guard (matches client server) >> Just server) + + +------------------------------------------------------------------------------ +-- | The equivalent of 'matchContent' above, except the resulting choice is +-- mapped to another value. +mapContent + :: Match a + => a -- ^ The client request's header value + -> [(a, b)] -- ^ The map of server-side responses + -> Maybe b +mapContent c s = matchContent c (map fst s) >>= lookupMatches s + + +------------------------------------------------------------------------------ +-- | The equivalent of 'lookupBy matches'. +lookupMatches :: Match a => [(a, b)] -> a -> Maybe b +lookupMatches ((k, v) : r) a + | Match.matches k a = Just v + | otherwise = lookupMatches r a +lookupMatches [] _ = Nothing + diff --git a/src/Network/HTTP/Media/Match.hs b/src/Network/HTTP/Media/Match.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Media/Match.hs @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- | Defines the 'Match' type class, designed to unify types on the +-- matching functions in the Media module. +module Network.HTTP.Media.Match + ( + Match (..) + , mostSpecific + ) where + +------------------------------------------------------------------------------ +import Data.ByteString + + +------------------------------------------------------------------------------ +-- | Defines methods for a type whose values can be matched against each +-- other in terms of a HTTP media 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 Match a where + + -- | Evaluates whether either the left argument matches the right one + -- (order may be important). + matches :: a -> a -> Bool + + -- | Evaluates whether the left argument is more specific than the right. + moreSpecificThan :: a -> a -> Bool + +instance Match ByteString where + matches = (==) + moreSpecificThan _ _ = False + + +------------------------------------------------------------------------------ +-- | Evaluates to whichever argument is more specific. Left biased. +mostSpecific :: Match a => a -> a -> a +mostSpecific a b + | b `moreSpecificThan` a = b + | otherwise = a + diff --git a/src/Network/HTTP/Media/MediaType.hs b/src/Network/HTTP/Media/MediaType.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Media/MediaType.hs @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ +-- | Defines the media type types and functions. +module Network.HTTP.Media.MediaType + ( + -- * Type and creation + MediaType + , Parameters + , (//) + , (/:) + , parse + , toByteString + + -- * Querying + , mainType + , subType + , parameters + , (/?) + , (/.) + ) where + +------------------------------------------------------------------------------ +import qualified Data.ByteString as BS +import qualified Data.Map as Map + +------------------------------------------------------------------------------ +import Data.ByteString (ByteString) +import Data.Map (empty, insert) +import Data.Word (Word8) + +------------------------------------------------------------------------------ +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 -> ByteString +mainType = Internal.mainType + + +------------------------------------------------------------------------------ +-- | Retrieves the sub type of a 'MediaType'. +subType :: MediaType -> 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 = 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 k p + + +------------------------------------------------------------------------------ +-- | Retrieves a parameter from a 'MediaType'. +(/.) :: MediaType -> ByteString -> Maybe ByteString +(MediaType _ _ p) /. k = Map.lookup k p + + +------------------------------------------------------------------------------ +-- | Ensures that the 'ByteString' matches the ABNF for `reg-name` in RFC +-- 4288. +ensureR :: ByteString -> ByteString +ensureR bs = 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 -> ByteString +ensureV = ensure (`notElem` [44, 59]) + + +------------------------------------------------------------------------------ +-- | Ensures the predicate matches for every character in the given string. +ensure :: (Word8 -> Bool) -> ByteString -> ByteString +ensure f bs = maybe + (error $ "Invalid character in " ++ show bs) (const bs) (BS.find f bs) + diff --git a/src/Network/HTTP/Media/MediaType/Internal.hs b/src/Network/HTTP/Media/MediaType/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Media/MediaType/Internal.hs @@ -0,0 +1,91 @@ +------------------------------------------------------------------------------ +-- | Defined to allow the constructor of 'MediaType' to be exposed to tests. +module Network.HTTP.Media.MediaType.Internal + ( MediaType (..) + , Parameters + , toByteString + , parse + ) where + +------------------------------------------------------------------------------ +import qualified Data.ByteString as BS +import qualified Data.ByteString.UTF8 as BS +import qualified Data.Map as Map + +------------------------------------------------------------------------------ +import Control.Monad (guard) +import Data.ByteString (ByteString) +import Data.ByteString.UTF8 (toString) +import Data.String (IsString (..)) +import Data.Map (Map) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) + +------------------------------------------------------------------------------ +import Network.HTTP.Media.Match (Match (..)) +import Network.HTTP.Media.Utils + + +------------------------------------------------------------------------------ +-- | An HTTP media type, consisting of the type, subtype, and parameters. +data MediaType = MediaType + { mainType :: ByteString -- ^ The main type of the MediaType + , subType :: ByteString -- ^ The sub type of the MediaType + , parameters :: Parameters -- ^ The parameters of the MediaType + } deriving (Eq) + +instance Show MediaType where + show (MediaType a b p) = + Map.foldrWithKey f (toString a ++ '/' : toString b) p + where + f k v = (++ ';' : toString k ++ '=' : toString v) + +instance IsString MediaType where + fromString str = flip fromMaybe (parse $ BS.fromString str) $ + error $ "Invalid media type literal " ++ str + +instance Match MediaType where + 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) + + +------------------------------------------------------------------------------ +-- | 'MediaType' parameters. +type Parameters = Map ByteString ByteString + + +------------------------------------------------------------------------------ +-- | Parses a media type header into a 'MediaType'. +parse :: ByteString -> Maybe MediaType +parse bs = do + let pieces = BS.split semi bs + guard $ not (null pieces) + let (m : ps) = pieces + (a, b) = breakByte slash m + guard $ BS.elem slash m && (a /= "*" || b == "*") + return $ MediaType a b $ + foldr (uncurry Map.insert . breakByte equal) Map.empty ps + + +------------------------------------------------------------------------------ +-- | Converts 'MediaType' to 'ByteString'. +toByteString :: MediaType -> ByteString +toByteString (MediaType a b p) = Map.foldrWithKey f (a <> "/" <> b) p + where + f k v = (<> ";" <> k <> "=" <> v) + diff --git a/src/Network/HTTP/Media/Quality.hs b/src/Network/HTTP/Media/Quality.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Media/Quality.hs @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- | Defines the quality value data type. +module Network.HTTP.Media.Quality + ( Quality (..) + , maxQuality + , minQuality + , readQ + ) where + +------------------------------------------------------------------------------ +import Data.Maybe (listToMaybe) +import Data.Word (Word16) + + +------------------------------------------------------------------------------ +-- | Attaches a quality value to data. +data Quality a = Quality + { qualityData :: a + , qualityValue :: Word16 + } deriving (Eq) + +instance Show a => Show (Quality a) where + show (Quality a q) = show a ++ ";q=" ++ showQ 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 + + +------------------------------------------------------------------------------ +showQ :: Word16 -> String +showQ 1000 = "1" +showQ 0 = "0" +showQ q = '0' : '.' : let s = show q in replicate (3 - length s) '0' ++ s + + +------------------------------------------------------------------------------ +readQ :: String -> Maybe Word16 +readQ "1" = Just 1000 +readQ "0" = Just 0 +readQ ('1' : '.' : t) + | length t <= 3 && all (== '0') t = Just 1000 + | otherwise = Nothing +readQ ('0' : '.' : t) + | length t <= 3 = fmap fst . listToMaybe . filter (null . snd) . reads $ + t ++ replicate (3 - length t) '0' + | otherwise = Nothing +readQ _ = Nothing + diff --git a/src/Network/HTTP/Media/Utils.hs b/src/Network/HTTP/Media/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Media/Utils.hs @@ -0,0 +1,60 @@ +----------------------------------------------------------------------------- +-- | Common utilities. +module Network.HTTP.Media.Utils + ( + breakByte + , trimBS + + , validChars + , isValidChar + + , slash + , semi + , comma + , space + , equal + ) where + +------------------------------------------------------------------------------ +import qualified Data.ByteString as BS + +------------------------------------------------------------------------------ +import Data.ByteString (ByteString) +import Data.Word (Word8) + + +------------------------------------------------------------------------------ +-- | Equivalent to 'Data.ByteString.breakByte', but leaves out the byte the +-- string is broken on. +breakByte :: Word8 -> ByteString -> (ByteString, ByteString) +breakByte w = fmap BS.tail . BS.breakByte w + + +------------------------------------------------------------------------------ +-- | Trims space characters from both ends of a ByteString. +trimBS :: ByteString -> ByteString +trimBS = BS.reverse . dropSpace . BS.reverse . dropSpace + where + dropSpace = BS.dropWhile (== space) + + +------------------------------------------------------------------------------ +-- | List of the valid characters for a media-type `reg-name` as per RFC 4288. +validChars :: [Word8] +validChars = + [33, 35, 36, 37, 43, 45, 46, 94, 95] ++ [48..57] ++ [65..90] ++ [97..122] + + +------------------------------------------------------------------------------ +-- | Evaluates whether the given character is valid in a media type `reg-name` +-- as per RFC 4288. +isValidChar :: Word8 -> Bool +isValidChar c = c >= 97 && c <= 122 || c >= 48 && c <= 57 || + c >= 65 && c <= 90 || c `elem` [33, 35, 36, 37, 43, 45, 46, 94, 95] + + +------------------------------------------------------------------------------ +-- | 'ByteString' compatible characters. +slash, semi, comma, space, equal :: Word8 +[slash, semi, comma, space, equal] = [47, 59, 44, 32, 61] + diff --git a/test/Network/HTTP/Media/Gen.hs b/test/Network/HTTP/Media/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Media/Gen.hs @@ -0,0 +1,29 @@ +------------------------------------------------------------------------------ +-- | Contains definitions for generating 'ByteString's. +module Network.HTTP.Media.Gen + ( genByteString + , genDiffByteString + ) where + +------------------------------------------------------------------------------ +import Control.Monad (liftM) +import Data.ByteString (ByteString, pack) +import Test.QuickCheck.Gen (Gen, listOf1, oneof) + + +------------------------------------------------------------------------------ +-- | Produces a ByteString of random alpha characters. +genByteString :: Gen ByteString +genByteString = liftM pack $ listOf1 (oneof $ map return validChars) + where + validChars = [48..57] ++ [65..90] ++ [97..122] + + +------------------------------------------------------------------------------ +-- | Produces a random ByteString different to the given one. +genDiffByteString :: ByteString -> Gen ByteString +genDiffByteString bs = do + bs' <- genByteString + if bs == bs' then genDiffByteString bs else return bs' + + diff --git a/test/Network/HTTP/Media/Match/Tests.hs b/test/Network/HTTP/Media/Match/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Media/Match/Tests.hs @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +module Network.HTTP.Media.Match.Tests (tests) where + +------------------------------------------------------------------------------ +import Control.Monad (join, liftM, liftM2) +import Distribution.TestSuite.QuickCheck + +------------------------------------------------------------------------------ +import Network.HTTP.Media.Gen +import Network.HTTP.Media.Match + + +------------------------------------------------------------------------------ +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" $ + join (liftM2 ((not .) . moreSpecificThan)) genByteString + + +------------------------------------------------------------------------------ +testMostSpecific :: Test +testMostSpecific = testProperty "mostSpecific" $ do + string <- genByteString + liftM ((== string) . mostSpecific string) genByteString + diff --git a/test/Network/HTTP/Media/MediaType/Gen.hs b/test/Network/HTTP/Media/MediaType/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Media/MediaType/Gen.hs @@ -0,0 +1,174 @@ +------------------------------------------------------------------------------ +-- | Contains definitions for generating 'MediaType's. +module Network.HTTP.Media.MediaType.Gen + ( + -- * Generating ByteStrings + genByteString + , genDiffByteString + + -- * Generating MediaTypes + , anything + , genMediaType + , genSubStar + , genMaybeSubStar + , subStarOf + , genConcreteMediaType + , genWithoutParams + , genWithParams + , stripParams + , genDiffMediaTypesWith + , genDiffMediaTypeWith + , genDiffMediaTypes + , genDiffMediaType + + -- * Generating Parameters + , genParameters + , genMaybeParameters + , genDiffParameters + ) where + +------------------------------------------------------------------------------ +import qualified Data.Map as Map + +------------------------------------------------------------------------------ +import Control.Monad (liftM, liftM2) +import Data.ByteString (ByteString) +import Data.Map (fromList) +import Test.QuickCheck.Gen + +------------------------------------------------------------------------------ +import Network.HTTP.Media.Gen +import Network.HTTP.Media.MediaType.Internal + + +------------------------------------------------------------------------------ +-- | Parameter entry for testing. +type ParamEntry = (ByteString, 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 <- genByteString + 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 <- genByteString + sub <- genByteString + params <- oneof [return Map.empty, genParameters] + return $ MediaType main sub params + + +------------------------------------------------------------------------------ +-- | Generates a concrete MediaType with no parameters. +genWithoutParams :: Gen MediaType +genWithoutParams = do + main <- genByteString + sub <- genByteString + return $ MediaType main sub Map.empty + + +------------------------------------------------------------------------------ +-- | Generates a MediaType with at least one parameter. +genWithParams :: Gen MediaType +genWithParams = do + main <- genByteString + sub <- genByteString + 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 (,) (genDiffByteString "q") genByteString) + + +------------------------------------------------------------------------------ +-- | 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' + diff --git a/test/Network/HTTP/Media/MediaType/Tests.hs b/test/Network/HTTP/Media/MediaType/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Media/MediaType/Tests.hs @@ -0,0 +1,204 @@ +------------------------------------------------------------------------------ +module Network.HTTP.Media.MediaType.Tests (tests) where + +------------------------------------------------------------------------------ +import qualified Data.ByteString.UTF8 as BS +import qualified Data.Map as Map + +------------------------------------------------------------------------------ +import Control.Monad (join, liftM) +import Data.String (fromString) +import Data.Maybe (isNothing) +import Data.Monoid ((<>), mconcat) +import Distribution.TestSuite.QuickCheck + +------------------------------------------------------------------------------ +import Network.HTTP.Media.Match +import Network.HTTP.Media.MediaType ((/?), (/.)) +import Network.HTTP.Media.MediaType.Internal +import Network.HTTP.Media.MediaType.Gen + + +------------------------------------------------------------------------------ +tests :: [Test] +tests = + [ testEq + , testShow + , testFromString + , testHas + , testGet + , testMatches + , testMoreSpecificThan + , testMostSpecific + , testParse + ] + + +------------------------------------------------------------------------------ +-- 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 $ parse (BS.fromString $ 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 /?) (Map.keys $ parameters media) + , testProperty "False for property it doesn't have" $ do + media <- genWithParams + return $ all (not . (stripParams media /?)) + (Map.keys $ parameters media) + ] + + +------------------------------------------------------------------------------ +testGet :: Test +testGet = testGroup "(/.)" + [ testProperty "Retrieves property it has" $ do + media <- genWithParams + let is n v = (&& media /. n == Just v) + return $ Map.foldrWithKey is True $ parameters media + , testProperty "Nothing for property it doesn't have" $ do + media <- genWithParams + let is n _ = (&& isNothing (stripParams media /. n)) + return $ Map.foldrWithKey is 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 <- genDiffByteString $ 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 <- genDiffByteString $ 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 "isMoreSpecific" + [ 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'' + ] + + +------------------------------------------------------------------------------ +testParse :: Test +testParse = testProperty "parse" $ do + media <- genMediaType + let main = mainType media + sub = subType media + params = parameters media + let (Just parsed) = parse $ main <> "/" <> sub <> mconcat + (map (uncurry ((<>) . (<> "=") . (";" <>))) $ Map.toList params) + return $ parsed == media + + +------------------------------------------------------------------------------ +-- | 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 + diff --git a/test/Network/HTTP/Media/Tests.hs b/test/Network/HTTP/Media/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Media/Tests.hs @@ -0,0 +1,109 @@ +------------------------------------------------------------------------------ +module Network.HTTP.Media.Tests (tests) where + +------------------------------------------------------------------------------ +import Control.Monad (replicateM) +import Data.ByteString.UTF8 (fromString) +import Data.List (intercalate) +import Data.Map (empty) +import Data.Maybe (isNothing) +import Data.Word (Word16) +import Distribution.TestSuite.QuickCheck +import Test.QuickCheck + +------------------------------------------------------------------------------ +import Network.HTTP.Media hiding (parameters, subType) +import Network.HTTP.Media.MediaType.Gen +import Network.HTTP.Media.MediaType.Internal +import Network.HTTP.Media.Quality + + +------------------------------------------------------------------------------ +tests :: [Test] +tests = + [ testParse + , testMatch + , testMap + ] + + +------------------------------------------------------------------------------ +testParse :: Test +testParse = testGroup "parseAccept" + [ testProperty "Without quality" $ do + media <- medias + return $ + parseAccept (group media) == Just (map maxQuality media) + , testProperty "With quality" $ do + media <- medias >>= mapM (flip fmap (choose (0, 1000)) . Quality) + return $ parseAccept (group media) == Just media + ] + where + medias = listOf1 genMediaType + group media = fromString $ intercalate "," (map show media) + + +------------------------------------------------------------------------------ +testMatch :: Test +testMatch = testGroup "match" + [ 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 $ matchAccept server client == + Just (qualityData $ foldr1 qmax client) + , testProperty "Most specific" $ do + media <- genConcreteMediaType + let client = map maxQuality + [ MediaType "*" "*" empty + , media { subType = "*" } + , media { parameters = empty } + , media + ] + return $ matchAccept [media] client == Just media + , testProperty "Nothing" $ do + server <- genServer + client <- listOf1 $ genDiffMediaTypesWith genConcreteMediaType server + let client' = filter (not . flip any server . matches) client + return . isNothing $ matchAccept server (map maxQuality client') + , testProperty "Never chooses q=0" $ do + server <- genServer + return . isNothing $ matchAccept server (map minQuality server) + , testProperty "Left biased" $ do + server <- genServer + let client = map maxQuality server + return $ matchAccept server client == Just (head server) + , testProperty "Against */*" $ do + server <- genServer + return $ matchAccept server [maxQuality "*/*"] == Just (head server) + , testProperty "Against type/*" $ do + server <- genServer + let client = [maxQuality (subStarOf $ head server)] + return $ matchAccept server client == Just (head server) + ] + + +------------------------------------------------------------------------------ +testMap :: Test +testMap = testGroup "map" + [ 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 $ mapAccept zipped client == + Just (qualityData $ foldr1 qmax client) + , testProperty "Nothing" $ do + server <- genServer + client <- listOf1 $ genDiffMediaTypesWith genConcreteMediaType server + let zipped = zip server $ repeat () + return . isNothing $ mapAccept zipped (map maxQuality client) + ] + + +------------------------------------------------------------------------------ +genServer :: Gen [MediaType] +genServer = listOf1 genConcreteMediaType + diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,20 @@ +------------------------------------------------------------------------------ +module Tests (tests) where + +------------------------------------------------------------------------------ +import Distribution.TestSuite + +------------------------------------------------------------------------------ +import qualified Network.HTTP.Media.Tests as Media +import qualified Network.HTTP.Media.Match.Tests as Match +import qualified Network.HTTP.Media.MediaType.Tests as MediaType + + +------------------------------------------------------------------------------ +tests :: IO [Test] +tests = return + [ testGroup "MediaType" MediaType.tests + , testGroup "Match" Match.tests + , testGroup "Media" Media.tests + ] +