packages feed

http-media 0.1.1 → 0.2.0

raw patch · 15 files changed

+440/−212 lines, 15 filesdep ~Cabaldep ~QuickCheck

Dependency ranges changed: Cabal, QuickCheck

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2012 Timothy Jones+Copyright (c) 2012-2014 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
dist/build/test-http-mediaStub/test-http-mediaStub-tmp/test-http-mediaStub.hs view
@@ -1,5 +1,5 @@ module Main ( main ) where-import Distribution.Simple.Test ( stubMain )+import Distribution.Simple.Test.LibV09 ( stubMain ) import Tests ( tests ) main :: IO () main = stubMain tests
http-media.cabal view
@@ -1,13 +1,13 @@ name:          http-media-version:       0.1.1+version:       0.2.0 license:       MIT license-file:  LICENSE author:        Timothy Jones-maintainer:    Timothy Jones <git@zimothy.com>-homepage:      http://github.com/zimothy/http-media-bug-reports:   http://github.com/zimothy/http-media/issues+maintainer:    Timothy Jones <git@zmthy.io>+homepage:      http://github.com/zmthy/http-media+bug-reports:   http://github.com/zmthy/http-media/issues category:      Web-copyright:     (c) 2013 Timothy Jones+copyright:     (c) 2012-2014 Timothy Jones build-type:    Simple cabal-version: >= 1.10 synopsis:      Processing HTTP Content-Type and Accept headers@@ -18,7 +18,26 @@   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.+  .+  In the following example, the Accept header is parsed, and then matched+  against a list of server options to serve the appropriate media:+  .+  > 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:+  .+  > getContentType >>= maybe send415Error readRequestBodyWith . mapContentMedia+  >     [ ("application/json", parseJson)+  >     , ("text/plain",       parseText)+  >     ]+  .+  The API is agnostic to your choice of server. + library   hs-source-dirs: src @@ -30,7 +49,7 @@    exposed-modules:     Network.HTTP.Media-    Network.HTTP.Media.Match+    Network.HTTP.Media.Accept     Network.HTTP.Media.MediaType   other-modules:     Network.HTTP.Media.MediaType.Internal@@ -53,9 +72,9 @@   test-module: Tests   other-modules:     Network.HTTP.Media+    Network.HTTP.Media.Accept+    Network.HTTP.Media.Accept.Tests     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@@ -69,13 +88,13 @@   build-depends:     base                  >= 4.6.0  && < 5.0,     bytestring            >= 0.10.0 && < 0.11,-    Cabal                 >= 1.18.0 && < 1.19,+    Cabal                 >= 1.18.0 && < 1.21,     cabal-test-quickcheck >= 0.1.0  && < 0.2,     containers            >= 0.5.0  && < 0.6,-    QuickCheck            >= 2.6    && < 2.7,+    QuickCheck            >= 2.6    && < 2.9,     utf8-string           >= 0.3.7  && < 0.4  source-repository head   type:     git-  location: git://github.com/zimothy/http-media.git+  location: git://github.com/zmthy/http-media.git
src/Network/HTTP/Media.hs view
@@ -11,81 +11,64 @@     , parameters     , (/?)     , (/.)-    , Quality -    -- * Parsing-    , parseAccept-     -- * Accept matching     , matchAccept     , mapAccept+    , mapAcceptMedia+    , mapAcceptBytes      -- * Content matching     , matchContent     , mapContent+    , mapContentMedia -    -- * Match-    , Match (..)+    -- * Quality values+    , Quality+    , parseQuality+    , matchQuality+    , mapQuality++    -- * Accept+    , Accept (..)     ) where  ------------------------------------------------------------------------------ import qualified Data.ByteString as BS  -------------------------------------------------------------------------------import Control.Applicative  (pure, (<*>), (<|>))-import Control.Monad        (guard)+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.Accept    as Accept 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+-- 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. The standard--- application of this function for 'MediaType' should be in conjunction with--- 'parseAccepts'.+-- Accept header which can be marked with a quality value. ----- > parseAccepts header >>= matchQuality resourceTypeOptions+-- > matchAccept ["text/html", "application/json"] <$> getHeader ----- For more information on the matching process see RFC 2616, section 14.+-- For more information on the matching process see RFC 2616, section 14.1-4. matchAccept-    :: Match a-    => [a]          -- ^ The server-side options-    -> [Quality a]  -- ^ The client-side preferences+    :: Accept a+    => [a]         -- ^ The server-side options+    -> ByteString  -- ^ The client-side header value     -> 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+matchAccept = (parseQuality >=>) . matchQuality   ------------------------------------------------------------------------------@@ -93,50 +76,167 @@ -- mapped to another value. Convenient for specifying how to translate the -- resource into each of its available formats. ----- > maybe render406Error renderResource $ parseAccepts header >>= mapQuality+-- > 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) -- >     ]-mapAccept-    :: Match a-    => [(a, b)]     -- ^ The map of server-side preferences to values-    -> [Quality a]  -- ^ The client-side preferences+mapAcceptMedia ::+    [(MediaType, b)]  -- ^ The map of server-side preferences to values+    -> ByteString     -- ^ The client-side header value     -> Maybe b-mapAccept s c = matchAccept (map fst s) c >>= lookupMatches s+mapAcceptMedia = mapAccept   ------------------------------------------------------------------------------+-- | A specialisation of 'mapAccept' that only takes ByteString as its input,+-- to avoid ambiguous-type errors when using string literal overloading.+--+-- > getHeader >>= maybe render406Error encodeResourceWith . mapAcceptBytes+-- >     [ ("compress", compress)+-- >     , ("gzip",     gzip)+-- >     ]+mapAcceptBytes ::+    [(ByteString, b)]  -- ^ The map of server-side preferences to values+    -> ByteString      -- ^ The client-side header value+    -> Maybe b+mapAcceptBytes = mapAccept+++------------------------------------------------------------------------------ -- | Matches a list of server-side parsing options against a the client-side -- content value. A result of 'Nothing' means that nothing matched (which -- should indicate a 415 error). ----- As with the Accept parsing, he use of the 'Match' type class allows the--- application of either 'MediaType' or 'ByteString'.+-- > matchContent ["application/json", "text/plain"] <$> getContentType+--+-- For more information on the matching process see RFC 2616, section 14.17. matchContent-    :: Match a-    => a         -- ^ The client's request value-    -> [a]       -- ^ The server-side response options+    :: Accept a+    => [a]         -- ^ The server-side response options+    -> ByteString  -- ^ The client's request value     -> Maybe a-matchContent client = foldl choose Nothing-  where choose m server = m <|> (guard (matches client server) >> Just server)+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-    :: Match a-    => a         -- ^ The client request's header value-    -> [(a, b)]  -- ^ The map of server-side responses+    :: Accept a+    => [(a, b)]    -- ^ The map of server-side responses+    -> ByteString  -- ^ The client request's header value     -> Maybe b-mapContent c s = matchContent c (map fst s) >>= lookupMatches s+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+++------------------------------------------------------------------------------+-- | Parses a full Accept header into a list of quality-valued media types.+parseQuality :: Accept a => ByteString -> Maybe [Quality a]+parseQuality = (. split comma) . mapM $ \bs ->+    let (accept, q) = BS.breakSubstring ";q=" $ BS.filter (/= space) bs+    in (<*> parseAccept accept) $ if BS.null q+        then pure maxQuality else flip Quality <$> readQ+            (toString $ BS.takeWhile (/= semi) $ BS.drop 3 q)+++------------------------------------------------------------------------------+-- | Matches a list of server-side resource options against a pre-parsed+-- quality-marked list of client-side preferences. A result of 'Nothing' means+-- that nothing matched (which should indicate a 406 error). If two or more+-- results arise with the same quality level and specificity, then the first+-- one in the server list is chosen.+--+-- The use of the 'Accept' type class allows the application of either+-- 'MediaType' for the standard Accept header or 'ByteString' for any other+-- Accept header which can be marked with a quality value.+--+-- > matchQuality ["text/html", "application/json"] <$> parseQuality header+--+-- For more information on the matching process see RFC 2616, section 14.1-4.+matchQuality+    :: Accept a+    => [a]          -- ^ The server-side options+    -> [Quality a]  -- ^ The pre-parsed client-side header value+    -> Maybe a+matchQuality options acceptq = do+    let merge (Quality c q) = map (`Quality` q) $ filter (`matches` c) options+        matched = concatMap merge acceptq+        (hq, qs) = foldr qfold (0, []) matched+        qfold (Quality v q) (mq, vs) = case compare q mq of+            GT -> (q, [v])+            EQ -> (mq, v : vs)+            LT -> (mq, vs)+        specific (a : ms) = Just $ foldl mostSpecific a ms+        specific []       = Nothing+    guard (hq /= 0)+    specific qs+++------------------------------------------------------------------------------+-- | The equivalent of 'matchQuality' above, except the resulting choice is+-- mapped to another value. Convenient for specifying how to translate the+-- resource into each of its available formats.+--+-- > parseQuality header >>= maybe render406Error renderResource . mapQuality+-- >     [ ("text" // "html",        asHtml)+-- >     , ("application" // "json", asJson)+-- >     ]+mapQuality+    :: Accept a+    => [(a, b)]     -- ^ The map of server-side preferences to values+    -> [Quality a]  -- ^ The client-side header value+    -> Maybe b+mapQuality options accept =+    matchQuality (map fst options) accept >>= lookupMatches options+++------------------------------------------------------------------------------ -- | The equivalent of 'lookupBy matches'.-lookupMatches :: Match a => [(a, b)] -> a -> Maybe b+lookupMatches :: Accept a => [(a, b)] -> a -> Maybe b lookupMatches ((k, v) : r) a-    | Match.matches k a = Just v+    | Accept.matches k a = Just v     | otherwise         = lookupMatches r a lookupMatches [] _ = Nothing
+ src/Network/HTTP/Media/Accept.hs view
@@ -0,0 +1,54 @@+------------------------------------------------------------------------------+-- | Defines the 'Accept' type class, designed to unify types on the matching+-- functions in the Media module.+module Network.HTTP.Media.Accept+    ( Accept (..)+    , mostSpecific+    ) where++------------------------------------------------------------------------------+import Data.ByteString+import Data.ByteString.UTF8 (toString)+++------------------------------------------------------------------------------+-- | 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++    -- | Specifies how to show an Accept-* header. Defaults to the standard+    -- show method.+    --+    -- Mostly useful just for avoiding quotes when rendering 'ByteString's+    -- with accompanying quality.+    showAccept :: a -> String+    showAccept = show++    -- | 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 Accept ByteString where+    parseAccept = Just+    showAccept = toString+    matches = (==)+    moreSpecificThan _ _ = False+++------------------------------------------------------------------------------+-- | Evaluates to whichever argument is more specific. Left biased.+mostSpecific :: Accept a => a -> a -> a+mostSpecific a b+    | b `moreSpecificThan` a = b+    | otherwise              = a+
− src/Network/HTTP/Media/Match.hs 
@@ -1,39 +0,0 @@---------------------------------------------------------------------------------- | 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-
src/Network/HTTP/Media/MediaType.hs view
@@ -7,7 +7,6 @@     , Parameters     , (//)     , (/:)-    , parse     , toByteString      -- * Querying
src/Network/HTTP/Media/MediaType/Internal.hs view
@@ -4,7 +4,6 @@     ( MediaType (..)     , Parameters     , toByteString-    , parse     ) where  ------------------------------------------------------------------------------@@ -22,7 +21,7 @@ import Data.Monoid          ((<>))  -------------------------------------------------------------------------------import Network.HTTP.Media.Match (Match (..))+import Network.HTTP.Media.Accept (Accept (..)) import Network.HTTP.Media.Utils  @@ -41,10 +40,19 @@         f k v = (++ ';' : toString k ++ '=' : toString v)  instance IsString MediaType where-    fromString str = flip fromMaybe (parse $ BS.fromString str) $+    fromString str = flip fromMaybe (parseAccept $ BS.fromString str) $         error $ "Invalid media type literal " ++ str -instance Match MediaType where+instance Accept MediaType where+    parseAccept 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+     matches a b         | mainType b == "*" = params         | subType b == "*"  = mainType a == mainType b && params@@ -67,19 +75,6 @@ ------------------------------------------------------------------------------ -- | '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   ------------------------------------------------------------------------------
src/Network/HTTP/Media/Quality.hs view
@@ -11,6 +11,8 @@ import Data.Maybe (listToMaybe) import Data.Word  (Word16) +------------------------------------------------------------------------------+import Network.HTTP.Media.Accept  ------------------------------------------------------------------------------ -- | Attaches a quality value to data.@@ -19,8 +21,8 @@     , qualityValue :: Word16     } deriving (Eq) -instance Show a => Show (Quality a) where-    show (Quality a q) = show a ++ ";q=" ++ showQ q+instance Accept a => Show (Quality a) where+    show (Quality a q) = showAccept a ++ ";q=" ++ showQ q   ------------------------------------------------------------------------------
+ test/Network/HTTP/Media/Accept/Tests.hs view
@@ -0,0 +1,48 @@+------------------------------------------------------------------------------+module Network.HTTP.Media.Accept.Tests (tests) where++------------------------------------------------------------------------------+import Control.Monad                     (join, liftM, liftM2)+import Distribution.TestSuite.QuickCheck++------------------------------------------------------------------------------+import Network.HTTP.Media.Accept+import Network.HTTP.Media.Gen+++------------------------------------------------------------------------------+tests :: [Test]+tests =+    [ testMatches+    , testMoreSpecificThan+    , testMostSpecific+    ]+++------------------------------------------------------------------------------+testMatches :: Test+testMatches = testGroup "matches"+    [ testProperty "Does match" $ do+        string <- genByteString+        return $ matches string string+    , testProperty "Doesn't match" $ do+        string  <- genByteString+        string' <- genDiffByteString string+        return . not $ matches string string'+    ]+++------------------------------------------------------------------------------+-- | Note that this test never actually generates any strings, as they are not+-- required for the 'moreSpecificThan' test.+testMoreSpecificThan :: Test+testMoreSpecificThan = testProperty "moreSpecificThan" $+    join (liftM2 ((not .) . moreSpecificThan)) genByteString+++------------------------------------------------------------------------------+testMostSpecific :: Test+testMostSpecific = testProperty "mostSpecific" $ do+    string <- genByteString+    liftM ((== string) . mostSpecific string) genByteString+
test/Network/HTTP/Media/Gen.hs view
@@ -26,4 +26,3 @@     bs' <- genByteString     if bs == bs' then genDiffByteString bs else return bs' -
− test/Network/HTTP/Media/Match/Tests.hs 
@@ -1,48 +0,0 @@--------------------------------------------------------------------------------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-
test/Network/HTTP/Media/MediaType/Tests.hs view
@@ -13,7 +13,7 @@ import Distribution.TestSuite.QuickCheck  -------------------------------------------------------------------------------import Network.HTTP.Media.Match+import Network.HTTP.Media.Accept import Network.HTTP.Media.MediaType          ((/?), (/.)) import Network.HTTP.Media.MediaType.Internal import Network.HTTP.Media.MediaType.Gen@@ -30,7 +30,7 @@     , testMatches     , testMoreSpecificThan     , testMostSpecific-    , testParse+    , testParseAccept     ]  @@ -52,7 +52,7 @@ testShow :: Test testShow = testProperty "show" $ do     media <- genMediaType-    return $ parse (BS.fromString $ show media) == Just media+    return $ parseAccept (BS.fromString $ show media) == Just media   ------------------------------------------------------------------------------@@ -186,13 +186,13 @@   -------------------------------------------------------------------------------testParse :: Test-testParse = testProperty "parse" $ do+testParseAccept :: Test+testParseAccept = testProperty "parseAccept" $ do     media <- genMediaType     let main   = mainType media         sub    = subType media         params = parameters media-    let (Just parsed) = parse $ main <> "/" <> sub <> mconcat+    let (Just parsed) = parseAccept $ main <> "/" <> sub <> mconcat             (map (uncurry ((<>) . (<> "=") . (";" <>))) $ Map.toList params)     return $ parsed == media
test/Network/HTTP/Media/Tests.hs view
@@ -3,10 +3,11 @@  ------------------------------------------------------------------------------ import Control.Monad                     (replicateM)+import Data.ByteString                   (ByteString) import Data.ByteString.UTF8              (fromString) import Data.List                         (intercalate) import Data.Map                          (empty)-import Data.Maybe                        (isNothing)+import Data.Maybe                        (isNothing, listToMaybe) import Data.Word                         (Word16) import Distribution.TestSuite.QuickCheck import Test.QuickCheck@@ -22,21 +23,25 @@ tests :: [Test] tests =     [ testParse-    , testMatch-    , testMap+    , testMatchAccept+    , testMapAccept+    , testMatchContent+    , testMapContent+    , testMatchQuality+    , testMapQuality     ]   ------------------------------------------------------------------------------ testParse :: Test-testParse = testGroup "parseAccept"+testParse = testGroup "parseQuality"     [ testProperty "Without quality" $ do         media <- medias         return $-            parseAccept (group media) == Just (map maxQuality media)+            parseQuality (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+        return $ parseQuality (group media) == Just media     ]   where     medias = listOf1 genMediaType@@ -44,66 +49,160 @@   -------------------------------------------------------------------------------testMatch :: Test-testMatch = testGroup "match"+testMatchAccept :: Test+testMatchAccept = testMatch "Accept" matchAccept qToBS+++------------------------------------------------------------------------------+testMapAccept :: Test+testMapAccept = testMap "Accept" mapAccept qToBS+++------------------------------------------------------------------------------+testMatchContent :: Test+testMatchContent = testGroup "matchContent"+    [ testProperty "Most specific" $ do+        media <- genConcreteMediaType+        let client = toBS+                [ MediaType "*" "*" empty+                , media { subType = "*" }+                , media { parameters = empty }+                , media+                ]+        return $ matchAccept [media] client == Just media+    , testProperty "Nothing" $ do+        (server, client) <- genServerAndClient+        let client' = filter (not . flip any server . matches) client+        return . isNothing $ matchAccept server (toBS client')+    , testProperty "Left biased" $ do+        server <- genServer+        return $ matchAccept server (toBS server) == Just (head server)+    , testProperty "Against */*" $ do+        server <- genServer+        let stars = "*/*" :: ByteString+        return $ matchAccept server (toBS [stars]) == Just (head server)+    , testProperty "Against type/*" $ do+        server <- genServer+        let client = toBS [subStarOf $ head server]+        return $ matchAccept server client == Just (head server)+    ]+++------------------------------------------------------------------------------+testMapContent :: Test+testMapContent = testGroup "mapContent"+    [ testProperty "Matches" $ do+        server <- genServer+        let zipped = zip server server+        return $ mapAccept zipped (toBS server) == listToMaybe server+    , testProperty "Nothing" $ do+        server <- genServer+        client <- listOf1 $ genDiffMediaTypesWith genConcreteMediaType server+        let zipped = zip server $ repeat ()+        return . isNothing $ mapAccept zipped (toBS client)+    ]+++------------------------------------------------------------------------------+testMatchQuality :: Test+testMatchQuality = testMatch "Quality" matchQuality id+++------------------------------------------------------------------------------+testMapQuality :: Test+testMapQuality = testMap "Quality" mapQuality id+++------------------------------------------------------------------------------+testMatch+    :: String+    -> ([MediaType] -> a -> Maybe MediaType)+    -> ([Quality MediaType] -> a)+    -> Test+testMatch name match qToI = testGroup ("match" ++ name)     [ testProperty "Highest quality" $ do         server <- genServer         qs     <- replicateM (length server) $ choose (1, 1000)         let client = zipWith Quality server qs             qmax v q = if qualityValue q > qualityValue v then q else v-        return $ matchAccept server client ==+        return $ match server (qToI client) ==             Just (qualityData $ foldr1 qmax client)     , testProperty "Most specific" $ do         media <- genConcreteMediaType-        let client = map maxQuality+        let client = qToI $ map maxQuality                 [ MediaType "*" "*" empty                 , media { subType = "*" }                 , media { parameters = empty }                 , media                 ]-        return $ matchAccept [media] client == Just media+        return $ match [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')+        return . isNothing $ match server+            (qToI $ map maxQuality client')     , testProperty "Never chooses q=0" $ do         server <- genServer-        return . isNothing $ matchAccept server (map minQuality server)+        return . isNothing $+            match server (qToI $ map minQuality server)     , testProperty "Left biased" $ do         server <- genServer-        let client = map maxQuality server-        return $ matchAccept server client == Just (head server)+        let client = qToI $ map maxQuality server+        return $ match server client == Just (head server)     , testProperty "Against */*" $ do         server <- genServer-        return $ matchAccept server [maxQuality "*/*"] == Just (head server)+        let stars = "*/*" :: MediaType+        return $ match server (qToI [maxQuality stars]) ==+            Just (head server)     , testProperty "Against type/*" $ do         server <- genServer-        let client = [maxQuality (subStarOf $ head server)]-        return $ matchAccept server client == Just (head server)+        let client = qToI [maxQuality (subStarOf $ head server)]+        return $ match server client == Just (head server)     ]   -------------------------------------------------------------------------------testMap :: Test-testMap = testGroup "map"+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 $ mapAccept zipped client ==+        return $ mapf zipped (qToI 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)+        (server, client) <- genServerAndClient+        let zipped = zip server $ repeat "*/*"+        return . isNothing $ mapf zipped (qToI $ map maxQuality client)     ]   ------------------------------------------------------------------------------ genServer :: Gen [MediaType] genServer = listOf1 genConcreteMediaType+++------------------------------------------------------------------------------+genServerAndClient :: Gen ([MediaType], [MediaType])+genServerAndClient = do+    server <- genServer+    client <- listOf1 $ genDiffMediaTypesWith genConcreteMediaType server+    return (server, client)+++------------------------------------------------------------------------------+toBS :: Accept a => [a] -> ByteString+toBS = fromString . intercalate "," . map showAccept+++------------------------------------------------------------------------------+qToBS :: Accept a => [Quality a] -> ByteString+qToBS = fromString . intercalate "," . map show
test/Tests.hs view
@@ -6,7 +6,7 @@  ------------------------------------------------------------------------------ import qualified Network.HTTP.Media.Tests           as Media-import qualified Network.HTTP.Media.Match.Tests     as Match+import qualified Network.HTTP.Media.Accept.Tests    as Accept import qualified Network.HTTP.Media.MediaType.Tests as MediaType  @@ -14,7 +14,7 @@ tests :: IO [Test] tests = return     [ testGroup "MediaType" MediaType.tests-    , testGroup "Match"     Match.tests+    , testGroup "Accept"    Accept.tests     , testGroup "Media"     Media.tests     ]